haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fix incorrect code generation for polymorphic datatypes

Browse Source
This commit is contained in:
d86leader 2020-09-22 15:33:43 +07:00
parent 62b418a801
commit 4c4584fde8
2 changed files with 14 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
yesod-core/src/Yesod/Core/Internal/TH.hs
View File

@ -141,9 +141,12 @@ mkYesodGeneral appCxt' namestr mtys isSub f resS = do
let name = mkName namestr let name = mkName namestr
-- Generate as many variable names as the arity indicates -- Generate as many variable names as the arity indicates
vns <- replicateM (arity - length mtys) $ newName "t" vns <- replicateM (arity - length mtys) $ newName "t"
-- Base type (site type with variables) -- types that you apply to get a concrete site name
let argtypes = fmap nameToType mtys ++ fmap VarT vns let argtypes = fmap nameToType mtys ++ fmap VarT vns
site = foldl' AppT (ConT name) argtypes -- typevars that should appear in synonym head
let argvars = (fmap mkName . filter isTvar) mtys ++ vns
-- Base type (site type with variables)
let site = foldl' AppT (ConT name) argtypes
res = map (fmap (parseType . dropBracket)) resS res = map (fmap (parseType . dropBracket)) resS
renderRouteDec <- mkRenderRouteInstance appCxt site res renderRouteDec <- mkRenderRouteInstance appCxt site res
routeAttrsDec <- mkRouteAttrsInstance appCxt site res routeAttrsDec <- mkRouteAttrsInstance appCxt site res
@ -160,7 +163,7 @@ mkYesodGeneral appCxt' namestr mtys isSub f resS = do
, renderRouteDec , renderRouteDec
, [routeAttrsDec] , [routeAttrsDec]
, resourcesDec , resourcesDec
, if isSub then [] else masterTypeSyns vns site , if isSub then [] else masterTypeSyns argvars site
] ]
return (dataDec, dispatchDec) return (dataDec, dispatchDec)

10
yesod-core/src/Yesod/Routes/Parse.hs
View File

@ -11,6 +11,7 @@ module Yesod.Routes.Parse
, TypeTree (..) , TypeTree (..)
, dropBracket , dropBracket
, nameToType , nameToType
, isTvar
) where ) where
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax
@ -264,8 +265,13 @@ ttToType (TTApp x y) = ttToType x `AppT` ttToType y
ttToType (TTList t) = ListT `AppT` ttToType t ttToType (TTList t) = ListT `AppT` ttToType t
nameToType :: String -> Type nameToType :: String -> Type
nameToType t@(h:_) | isLower h = VarT $ mkName t nameToType t = if isTvar t
nameToType t = ConT $ mkName t then VarT $ mkName t
else ConT $ mkName t
isTvar :: String -> Bool
isTvar (h:_) = isLower h
isTvar _ = False
pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String) pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String)
pieceFromString ('#':'!':x) = Right $ (False, Dynamic $ dropBracket x) pieceFromString ('#':'!':x) = Right $ (False, Dynamic $ dropBracket x)