From 7ee2475363443913b45a6c506ff6fd1aa80bb6ac Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Wed, 3 Dec 2008 16:55:48 +0000 Subject: [PATCH] Pulled out more commonality, this time relating to contexts --- .../Data/Generics/Polyplate/GenInstances.hs | 30 ++++++++++++++++--- 1 file changed, 26 insertions(+), 4 deletions(-) diff --git a/polyplate/Data/Generics/Polyplate/GenInstances.hs b/polyplate/Data/Generics/Polyplate/GenInstances.hs index 7733959..771cddc 100644 --- a/polyplate/Data/Generics/Polyplate/GenInstances.hs +++ b/polyplate/Data/Generics/Polyplate/GenInstances.hs @@ -220,12 +220,34 @@ instancesFrom genOverlapped genClass@GenOneClass boxes w ctrArgTypes 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 context ops0 ops1 body = ["instance (Monad m" ++ concatMap (", " ++) context ++ ") =>" ," PolyplateM (" ++ wName ++ ") " ++ ops0 ++ " " ++ ops1 ++ " m where" ] ++ 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 -- left to apply. You can pass it an override for the case of processing children -- (and the types that make up the children). @@ -243,7 +265,7 @@ instancesFrom genOverlapped genClass@GenOneClass boxes w ,genInst [] "()" "()" ["transformM () () v = return v"] ,if genOverlapped == GenWithoutOverlapped then [] else genInst - [ "PolyplateM (" ++ wName ++ ") r ops m" ] + [ contextSameType "r" "ops" ] "(a -> m a, r)" "ops" ["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. context :: [String] context - = ["PolyplateM (" ++ argType ++ ") (f,ops) () m" + = [ contextNewType argType "(f,ops)" "()" | argType <- nub $ sort $ concatMap ctrArgTypes $ maybe (map ctrArgs wCtrs) ((:[]) . fst) mdoChildren] @@ -300,13 +322,13 @@ instancesFrom genOverlapped genClass@GenOneClass boxes w -- upon | cKey `Set.member` containedKeys = (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"]) -- This type can't contain the transformed type; just move on to the -- next transformation. | genOverlapped == GenWithoutOverlapped = (True - ,["PolyplateM (" ++ wName ++ ") r ops m"] + ,[contextSameType "r" "ops"] ,["transformM (_, rest) ops v = transformM rest ops v"]) -- This is covered by one big overlapping instance: | otherwise = (False,[],[])