Pulled out some of the details of generating a Polyplate instance into a helper function, to help make it easier to configure
This commit is contained in:
parent
624e10b9ff
commit
14d6dec1d1
|
@ -220,30 +220,32 @@ instancesFrom genOverlapped genClass@GenOneClass boxes w
|
||||||
ctrArgTypes types
|
ctrArgTypes types
|
||||||
= [show $ typeOf w | DataBox w <- types]
|
= [show $ typeOf w | DataBox w <- types]
|
||||||
|
|
||||||
|
genInst :: [String] -> String -> String -> [String] -> [String]
|
||||||
|
genInst context ops0 ops1 body
|
||||||
|
= ["instance (Monad m" ++ concatMap (", " ++) context ++ ") =>"
|
||||||
|
," PolyplateM (" ++ wName ++ ") " ++ ops0 ++ " " ++ ops1 ++ " m where"
|
||||||
|
] ++ map (" " ++) body
|
||||||
|
|
||||||
-- | An instance that describes what to do when we have no transformations
|
-- | An instance that describes what to do when we have no transformations
|
||||||
-- left to apply. You can pass it an override for the case of processing children
|
-- left to apply. You can pass it an override for the case of processing children
|
||||||
-- (and the types that make up the children).
|
-- (and the types that make up the children).
|
||||||
baseInst :: Maybe ([DataBox], [String]) -> [String]
|
baseInst :: Maybe ([DataBox], [String]) -> [String]
|
||||||
baseInst mdoChildren
|
baseInst mdoChildren
|
||||||
= [ "instance (" ++ concat (intersperse ", " context) ++ ") =>"
|
= concat
|
||||||
, " PolyplateM (" ++ wName ++ ") () (f, ops) m where"
|
[genInst context "()" "(f, ops)" $
|
||||||
] ++
|
|
||||||
maybe
|
maybe
|
||||||
(if isAlgType wDType
|
(if isAlgType wDType
|
||||||
-- An algebraic type: apply to each child if we're following.
|
-- An algebraic type: apply to each child if we're following.
|
||||||
then (concatMap constrCase wCtrs)
|
then (concatMap constrCase wCtrs)
|
||||||
-- A primitive (or non-represented) type: just return it.
|
-- A primitive (or non-represented) type: just return it.
|
||||||
else ["transformM () _ v = return v"])
|
else ["transformM () _ v = return v"])
|
||||||
(map (" " ++) . snd) mdoChildren ++
|
snd mdoChildren
|
||||||
[""
|
,genInst [] "()" "()" ["transformM () () v = return v"]
|
||||||
, "instance Monad m => PolyplateM (" ++ wName ++ ") () () m where"
|
,if genOverlapped == GenWithoutOverlapped then [] else
|
||||||
, " transformM () () v = return v"
|
genInst
|
||||||
] ++
|
[ "PolyplateM (" ++ wName ++ ") r ops m" ]
|
||||||
if genOverlapped == GenWithoutOverlapped then [] else
|
"(a -> m a, r)" "ops"
|
||||||
[ "instance (Monad m"
|
["transformM (_, rest) ops v = transformM rest ops v"]
|
||||||
, " ,PolyplateM (" ++ wName ++ ") r ops m) =>"
|
|
||||||
, " PolyplateM (" ++ wName ++ ") (a -> m a, r) ops m where"
|
|
||||||
, " transformM (_, rest) ops v = transformM rest ops v"
|
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
-- | Class context for 'baseInst'.
|
-- | Class context for 'baseInst'.
|
||||||
|
@ -251,8 +253,7 @@ instancesFrom genOverlapped genClass@GenOneClass boxes w
|
||||||
-- this type, so we can recurse into them.
|
-- this type, so we can recurse into them.
|
||||||
context :: [String]
|
context :: [String]
|
||||||
context
|
context
|
||||||
= ["Monad m"] ++
|
= ["PolyplateM (" ++ argType ++ ") (f,ops) () m"
|
||||||
["PolyplateM (" ++ argType ++ ") (f,ops) () m"
|
|
||||||
| argType <- nub $ sort $ concatMap ctrArgTypes $
|
| argType <- nub $ sort $ concatMap ctrArgTypes $
|
||||||
maybe (map ctrArgs wCtrs) ((:[]) . fst) mdoChildren]
|
maybe (map ctrArgs wCtrs) ((:[]) . fst) mdoChildren]
|
||||||
|
|
||||||
|
@ -283,34 +284,32 @@ instancesFrom genOverlapped genClass@GenOneClass boxes w
|
||||||
otherInst :: Data s => Int -> Set.Set Int -> s -> Int -> [String]
|
otherInst :: Data s => Int -> Set.Set Int -> s -> Int -> [String]
|
||||||
otherInst wKey containedKeys c cKey
|
otherInst wKey containedKeys c cKey
|
||||||
= if not shouldGen then [] else
|
= if not shouldGen then [] else
|
||||||
[ "instance (Monad m" ++ other ++ ") =>"
|
genInst context
|
||||||
, " PolyplateM (" ++ wName ++ ") ((" ++ cName ++ ") -> m (" ++ cName ++ "), r)"
|
("((" ++ cName ++ ") -> m (" ++ cName ++ "), r)")
|
||||||
, " ops m where"
|
"ops"
|
||||||
, impl
|
impl
|
||||||
, ""
|
|
||||||
]
|
|
||||||
where
|
where
|
||||||
cName = show $ typeOf c
|
cName = show $ typeOf c
|
||||||
(shouldGen, other, impl)
|
(shouldGen, context, impl)
|
||||||
-- This type matches the transformation: apply it.
|
-- This type matches the transformation: apply it.
|
||||||
| wKey == cKey
|
| wKey == cKey
|
||||||
= (True
|
= (True
|
||||||
,""
|
,[]
|
||||||
," transformM (f, _) _ v = f v")
|
,["transformM (f, _) _ v = f v"])
|
||||||
-- This type might contain the type that the transformation acts
|
-- This type might contain the type that the transformation acts
|
||||||
-- upon
|
-- upon
|
||||||
| cKey `Set.member` containedKeys
|
| cKey `Set.member` containedKeys
|
||||||
= (True
|
= (True
|
||||||
,", PolyplateM (" ++ wName ++ ") r ((" ++ cName ++ ") -> m (" ++ cName ++ "), ops) m"
|
,["PolyplateM (" ++ wName ++ ") r ((" ++ cName ++ ") -> m (" ++ cName ++ "), ops) m"]
|
||||||
," transformM (f, rest) ops v = transformM rest (f, ops) v")
|
,["transformM (f, rest) ops v = transformM rest (f, ops) v"])
|
||||||
-- This type can't contain the transformed type; just move on to the
|
-- This type can't contain the transformed type; just move on to the
|
||||||
-- next transformation.
|
-- next transformation.
|
||||||
| genOverlapped == GenWithoutOverlapped
|
| genOverlapped == GenWithoutOverlapped
|
||||||
= (True
|
= (True
|
||||||
,", PolyplateM (" ++ wName ++ ") r ops m"
|
,["PolyplateM (" ++ wName ++ ") r ops m"]
|
||||||
," transformM (_, rest) ops v = transformM rest ops v")
|
,["transformM (_, rest) ops v = transformM rest ops v"])
|
||||||
-- This is covered by one big overlapping instance:
|
-- This is covered by one big overlapping instance:
|
||||||
| otherwise = (False,"","")
|
| otherwise = (False,[],[])
|
||||||
|
|
||||||
-- | Generates all the given instances (eliminating any duplicates)
|
-- | Generates all the given instances (eliminating any duplicates)
|
||||||
-- with the given options.
|
-- with the given options.
|
||||||
|
|
Loading…
Reference in New Issue
Block a user