Pulled out more commonality, this time relating to contexts
This commit is contained in:
parent
14d6dec1d1
commit
7ee2475363
|
@ -220,12 +220,34 @@ instancesFrom genOverlapped genClass@GenOneClass boxes w
|
||||||
ctrArgTypes types
|
ctrArgTypes types
|
||||||
= [show $ typeOf w | DataBox w <- types]
|
= [show $ typeOf w | DataBox w <- types]
|
||||||
|
|
||||||
|
-- Given the context (a list of instance requirements), the left-hand ops,
|
||||||
|
-- the right-hand ops, and a list of lines for the body of the class, generates
|
||||||
|
-- an instance.
|
||||||
|
--
|
||||||
|
-- For GenOneClass this will be an instance of PolyplateM.
|
||||||
|
--
|
||||||
|
-- For GenClassPerType this will be an instance of PolyplateMFoo (or whatever)
|
||||||
|
--
|
||||||
|
-- For GenSlowDelegate this will be an instance of PolyplateM', with the first
|
||||||
|
-- and last arguments swapped.
|
||||||
genInst :: [String] -> String -> String -> [String] -> [String]
|
genInst :: [String] -> String -> String -> [String] -> [String]
|
||||||
genInst context ops0 ops1 body
|
genInst context ops0 ops1 body
|
||||||
= ["instance (Monad m" ++ concatMap (", " ++) context ++ ") =>"
|
= ["instance (Monad m" ++ concatMap (", " ++) context ++ ") =>"
|
||||||
," PolyplateM (" ++ wName ++ ") " ++ ops0 ++ " " ++ ops1 ++ " m where"
|
," PolyplateM (" ++ wName ++ ") " ++ ops0 ++ " " ++ ops1 ++ " m where"
|
||||||
] ++ map (" " ++) body
|
] ++ map (" " ++) body
|
||||||
|
|
||||||
|
-- Generates the name of an instance for the same type with the given two ops
|
||||||
|
-- sets. The class name will be the same as genInst.
|
||||||
|
contextSameType :: String -> String -> String
|
||||||
|
contextSameType ops0 ops1
|
||||||
|
= "PolyplateM (" ++ wName ++ ") " ++ ops0 ++ " " ++ ops1 ++ " m"
|
||||||
|
|
||||||
|
-- Generates the name of an instance for a different type (for processing children).
|
||||||
|
-- This will be PolyplateM or PolyplateM'.
|
||||||
|
contextNewType :: String -> String -> String -> String
|
||||||
|
contextNewType cName ops0 ops1
|
||||||
|
= "PolyplateM (" ++ cName ++ ") " ++ ops0 ++ " " ++ ops1 ++ " m"
|
||||||
|
|
||||||
-- | 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).
|
||||||
|
@ -243,7 +265,7 @@ instancesFrom genOverlapped genClass@GenOneClass boxes w
|
||||||
,genInst [] "()" "()" ["transformM () () v = return v"]
|
,genInst [] "()" "()" ["transformM () () v = return v"]
|
||||||
,if genOverlapped == GenWithoutOverlapped then [] else
|
,if genOverlapped == GenWithoutOverlapped then [] else
|
||||||
genInst
|
genInst
|
||||||
[ "PolyplateM (" ++ wName ++ ") r ops m" ]
|
[ contextSameType "r" "ops" ]
|
||||||
"(a -> m a, r)" "ops"
|
"(a -> m a, r)" "ops"
|
||||||
["transformM (_, rest) ops v = transformM rest ops v"]
|
["transformM (_, rest) ops v = transformM rest ops v"]
|
||||||
]
|
]
|
||||||
|
@ -253,7 +275,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
|
||||||
= ["PolyplateM (" ++ argType ++ ") (f,ops) () m"
|
= [ contextNewType argType "(f,ops)" "()"
|
||||||
| argType <- nub $ sort $ concatMap ctrArgTypes $
|
| argType <- nub $ sort $ concatMap ctrArgTypes $
|
||||||
maybe (map ctrArgs wCtrs) ((:[]) . fst) mdoChildren]
|
maybe (map ctrArgs wCtrs) ((:[]) . fst) mdoChildren]
|
||||||
|
|
||||||
|
@ -300,13 +322,13 @@ instancesFrom genOverlapped genClass@GenOneClass boxes w
|
||||||
-- upon
|
-- upon
|
||||||
| cKey `Set.member` containedKeys
|
| cKey `Set.member` containedKeys
|
||||||
= (True
|
= (True
|
||||||
,["PolyplateM (" ++ wName ++ ") r ((" ++ cName ++ ") -> m (" ++ cName ++ "), ops) m"]
|
,[contextSameType "r" ("((" ++ cName ++ ") -> m (" ++ cName ++ "), ops)")]
|
||||||
,["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"]
|
,[contextSameType "r" "ops"]
|
||||||
,["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,[],[])
|
||||||
|
|
Loading…
Reference in New Issue
Block a user