mirror of
https://github.com/lexi-lambda/freer-simple.git
synced 2024-09-11 08:05:51 +03:00
Generalize makeEffect to work with more complicated GADTs
This commit is contained in:
parent
b86b90ddec
commit
cd7b4c62fd
@ -36,8 +36,6 @@ where
|
|||||||
import Control.Monad (forM, unless)
|
import Control.Monad (forM, unless)
|
||||||
import Control.Monad.Freer (send, Member, Eff)
|
import Control.Monad.Freer (send, Member, Eff)
|
||||||
import Data.Char (toLower)
|
import Data.Char (toLower)
|
||||||
import Data.List (nub)
|
|
||||||
import Data.Maybe (mapMaybe)
|
|
||||||
import Language.Haskell.TH
|
import Language.Haskell.TH
|
||||||
import Prelude
|
import Prelude
|
||||||
|
|
||||||
@ -110,41 +108,54 @@ genDecl (GadtC [cName] tArgs _ ) = do
|
|||||||
[]
|
[]
|
||||||
genDecl _ = fail "genDecl expects a GADT constructor"
|
genDecl _ = fail "genDecl expects a GADT constructor"
|
||||||
|
|
||||||
-- | Generates a type signature of the form
|
-- | Generates a function type from the corresponding GADT type constructor
|
||||||
-- @x :: Member (Effect e) effs => a -> b -> c -> Eff effs r@.
|
-- @x :: Member (Effect e) effs => a -> b -> c -> Eff effs r@.
|
||||||
genSig :: Con -> Q Dec
|
genType :: Con -> Q Type
|
||||||
genSig (ForallC _ _ con ) = genSig con
|
genType (ForallC tyVarBindings conCtx con)
|
||||||
genSig (GadtC [cName] tArgs' ctrType@(AppT eff tRet)) = do
|
= ForallT tyVarBindings conCtx <$> genType con
|
||||||
|
genType (GadtC _ tArgs' (AppT eff tRet)) = do
|
||||||
effs <- newName "effs"
|
effs <- newName "effs"
|
||||||
let
|
let
|
||||||
fnName = getDeclName cName
|
tArgs = fmap snd tArgs'
|
||||||
tArgs = fmap snd tArgs'
|
|
||||||
otherVars = unapply ctrType
|
|
||||||
quantifiedVars =
|
|
||||||
fmap PlainTV . nub $ effs : mapMaybe freeVarName (tArgs ++ otherVars)
|
|
||||||
memberConstraint = ConT ''Member `AppT` eff `AppT` VarT effs
|
memberConstraint = ConT ''Member `AppT` eff `AppT` VarT effs
|
||||||
resultType = ConT ''Eff `AppT` VarT effs `AppT` tRet
|
resultType = ConT ''Eff `AppT` VarT effs `AppT` tRet
|
||||||
|
|
||||||
return
|
return
|
||||||
. SigD fnName
|
. ForallT [PlainTV effs] [memberConstraint]
|
||||||
. ForallT quantifiedVars [memberConstraint]
|
|
||||||
. foldArrows
|
. foldArrows
|
||||||
$ tArgs
|
$ tArgs
|
||||||
++ [resultType]
|
++ [resultType]
|
||||||
-- TODO: Although this should never happen, we obviously need a better error message below.
|
-- TODO: Although this should never happen, we obviously need a better error message below.
|
||||||
genSig GadtC{} = fail "genSig can only look at applications (AppT)"
|
genType _ = fail "genSig expects a GADT constructor"
|
||||||
genSig _ = fail "genSig expects a GADT constructor"
|
|
||||||
|
|
||||||
-- | Gets the name of the free variable in the 'Type', if it exists.
|
-- | Turn all (KindedTV tv StarT) into (PlainTV tv) in the given type
|
||||||
freeVarName :: Type -> Maybe Name
|
-- This can prevent the need for KindSignatures
|
||||||
freeVarName (VarT n) = Just n
|
simplifyBndrs :: Type -> Type
|
||||||
freeVarName _ = Nothing
|
simplifyBndrs (ForallT bndrs tcxt t) = ForallT (map simplifyBndr bndrs) tcxt (simplifyBndrs t)
|
||||||
|
simplifyBndrs (AppT t1 t2) = AppT (simplifyBndrs t1) (simplifyBndrs t2)
|
||||||
|
simplifyBndrs (SigT t k) = SigT (simplifyBndrs t) k
|
||||||
|
simplifyBndrs (InfixT t1 n t2) = InfixT (simplifyBndrs t1) n (simplifyBndrs t2)
|
||||||
|
simplifyBndrs (UInfixT t1 n t2) = InfixT (simplifyBndrs t1) n (simplifyBndrs t2)
|
||||||
|
simplifyBndrs (ParensT t) = ParensT (simplifyBndrs t)
|
||||||
|
simplifyBndrs t = t
|
||||||
|
|
||||||
|
-- | Turn TvVarBndrs of the form (KindedTV tv StarT) into (PlainTV tv)
|
||||||
|
-- This can prevent the need for KindSignatures
|
||||||
|
simplifyBndr :: TyVarBndr -> TyVarBndr
|
||||||
|
simplifyBndr (KindedTV tv StarT) = PlainTV tv
|
||||||
|
simplifyBndr bndr = bndr
|
||||||
|
|
||||||
|
-- | Generates a type signature of the form
|
||||||
|
-- @x :: Member (Effect e) effs => a -> b -> c -> Eff effs r@.
|
||||||
|
genSig :: Con -> Q Dec
|
||||||
|
genSig con = do
|
||||||
|
let
|
||||||
|
getConName (ForallC _ _ c) = getConName c
|
||||||
|
getConName (GadtC [n] _ _) = pure n
|
||||||
|
getConName c = fail $ "failed to get GADT name from " ++ show c
|
||||||
|
conName <- getConName con
|
||||||
|
SigD (getDeclName conName) <$> simplifyBndrs <$> genType con
|
||||||
|
|
||||||
-- | Folds a list of 'Type's into a right-associative arrow 'Type'.
|
-- | Folds a list of 'Type's into a right-associative arrow 'Type'.
|
||||||
foldArrows :: [Type] -> Type
|
foldArrows :: [Type] -> Type
|
||||||
foldArrows = foldr1 (AppT . AppT ArrowT)
|
foldArrows = foldr1 (AppT . AppT ArrowT)
|
||||||
|
|
||||||
-- | Unfolds a type into any types which were applied together.
|
|
||||||
unapply :: Type -> [Type]
|
|
||||||
unapply (AppT a b) = unapply a ++ unapply b
|
|
||||||
unapply a = [a]
|
|
||||||
|
@ -32,3 +32,20 @@ runPrepender = interpret
|
|||||||
|
|
||||||
testGeneratedFunction :: String -> String
|
testGeneratedFunction :: String -> String
|
||||||
testGeneratedFunction s = run . runPrepender $ prependSomething s
|
testGeneratedFunction s = run . runPrepender $ prependSomething s
|
||||||
|
|
||||||
|
-- Create a more complicated test GADT
|
||||||
|
data Complicated a where
|
||||||
|
Mono :: Int -> Complicated Bool
|
||||||
|
Poly :: a -> Complicated a
|
||||||
|
PolyIn :: a -> Complicated Bool
|
||||||
|
PolyOut :: Int -> Complicated a
|
||||||
|
Lots :: a -> b -> c -> d -> e -> f -> Complicated ()
|
||||||
|
Nested :: Maybe b -> Complicated (Maybe a)
|
||||||
|
MultiNested :: (Maybe a, [b]) -> Complicated (Maybe a, [b])
|
||||||
|
Existential :: (forall e. e -> Maybe e) -> Complicated a
|
||||||
|
LotsNested :: Maybe a -> [b] -> (c, c) -> Complicated (a, b, c)
|
||||||
|
Dict :: (Ord a) => a -> Complicated a
|
||||||
|
MultiDict :: (Eq a, Ord b, Enum a, Num c) => a -> b -> c -> Complicated ()
|
||||||
|
|
||||||
|
-- Make TH generate our effect functions.
|
||||||
|
makeEffect ''Complicated
|
||||||
|
Loading…
Reference in New Issue
Block a user