diff --git a/polyplate/Data/Generics/Polyplate/GenInstances.hs b/polyplate/Data/Generics/Polyplate/GenInstances.hs index 7ee6548..9089347 100644 --- a/polyplate/Data/Generics/Polyplate/GenInstances.hs +++ b/polyplate/Data/Generics/Polyplate/GenInstances.hs @@ -30,9 +30,15 @@ import qualified Data.Map as Map import qualified Data.Set as Set data GenOverlappedOption = GenWithOverlapped | GenWithoutOverlapped + deriving (Eq) data GenClassOption = GenClassPerType | GenOneClass | GenSlowDelegate + deriving (Eq) +-- | Given the first line of the file (first parameter, which may be a directive +-- to GHC with some options), a module name (second parameter), generates a list +-- of lines that form the header of the module. You can easily just write a similar +-- function yourself if you want more control over the comments. genHeader :: String -> String -> [String] genHeader firstLine moduleName = [firstLine @@ -41,8 +47,249 @@ genHeader firstLine moduleName ,"-- and should NOT be edited directly." ,"module " ++ moduleName ++ " where"] +-- | A type that represents a generator for instances of a set of types. newtype GenInstance = GenInstance (TypeMapM ()) +-- | Generates instances for all types within the given type. Therefore you should +-- only need one or two of these calls to cover all of a complex data structure, +-- by calling this on the largest types in your structure. The function is non-strict +-- in its argument, so the easiest way to call it is: +-- +-- > genInstance (undefined :: MyType) +genInstance :: Data t => t -> GenInstance +genInstance = GenInstance . findTypesIn + +-- Explanation of Polyplate's instances: +-- +-- Polyplate is a type-class system for automatically applying generic transformations +-- to the first instance of a specific type in a large data structure. +-- +-- A set of operations is represented as a tuple list, e.g. +-- +-- > (a -> m a, (b -> m b, (c -> m c, ()))) +-- +-- The unit type is the list terminator. +-- +-- The Polyplate class takes four parameters: +-- +-- * The first is the type currently being processed. +-- +-- * The second is the list of operations still to be checked against the current type. +-- +-- * The third is the list of operations to be applied if we end up processing +-- the current type's children. +-- +-- * The fourth is the monad in which it operates, which is just passed through. +-- +-- There are broadly four types of instance generated by this module: +-- +-- * The "exact match" instance. These are of the form: +-- +-- > instance Monad m => PolyplateM a (a -> m a, r) ops m where +-- > transformM (f,_) _ v = f v +-- +-- This just applies the transformation directly, as you can see, ignoring the +-- other bits and bobs. +-- +-- * The "process children" instance. For a data type: +-- +-- > data Foo = ConstrBar Bar | ConstrBazQuux Baz Quux +-- +-- This is of the form: +-- +-- > instance (Monad m, +-- > PolyplateM Bar (f,ops) () m, +-- > PolyplateM Baz (f,ops) () m, +-- > PolyplateM Quux (f,ops) () m) => +-- > PolyplateM Foo () (f, ops) m where +-- > transformM () ops (ConstrBar a0) +-- > = do r0 <- transformM ops () a0 +-- > return (ConstrBar r0) +-- > transformM () ops (ConstrBazQuux a0 a1) +-- > = do r0 <- transformM ops () a0 +-- > r1 <- transformM ops () a1 +-- > return (ConstrBazQuux r0 r1) +-- +-- The reason for using (f, ops) in the type-class header is to distinguish this +-- from the empty set of operations (see lower down). The operations that are +-- to be applied on descent (the third parameter) are passed to the sub-instances +-- as the list of operations to be checked (the second parameter), with a new blank +-- list of operations to apply on descent. The bodies of the methods just apply +-- transformM to each child of the constructor, and pull the data-type back together +-- again. +-- +-- +-- * The "can contain" instance. This is of the form: +-- +-- > instance (Monad m, PolyplateM t r (a -> m a, ops) m) => +-- > PolyplateM t (a -> m a, r) ops m where +-- > transformM (f, rest) ops v = transformM rest (f, ops) v +-- +-- Here, the type being considered, t, /can/ contain the type referred to by the +-- operation, a. So we transfer the operation from the list we're processing onto +-- the list to apply in case of direct recursion. Then we continue processing +-- the list of operations. +-- +-- * The "cannot contain" instance. This is of the form: +-- +-- > instance (Monad m, PolyplateM t r ops m) => +-- > PolyplateM t (a -> m a, r) ops m where +-- > transformM (_, rest) ops v = transformM rest ops v +-- +-- This instance is based on the logic that if we have worked out that a big type +-- (like Foo) cannot contain a certain type (say, String) then by implication, +-- neither of its children can contain Strings either. So we omit the transformation +-- of the type (in this example String) when we directly descend into Foo, by not +-- copying the transformation onto the third parameter. +-- +-- The final thing we need, is a base case +-- for when both the second and third parameters are empty. This means there are +-- no operations left to examine, but also none available for direct recursion. +-- At this point we just return the value unchanged. + + +-- | Instances for a particular data type (i.e. where that data type is the +-- first argument to 'Polyplate'). +instancesFrom :: forall t. Data t => GenOverlappedOption -> GenClassOption -> [DataBox] -> t -> IO [String] +instancesFrom genOverlapped genClass@GenOneClass boxes w + = do containedTypes <- findTypesIn' w + containedKeys <- liftM Set.fromList + (sequence [typeKey c | DataBox c <- justBoxes containedTypes]) + wKey <- typeKey w + otherInsts <- sequence [do ck <- typeKey c + return (otherInst wKey containedKeys c ck) + | DataBox c <- boxes] + return $ baseInst ++ concat otherInsts + where + wName = show $ typeOf w + wDType = dataTypeOf w + wCtrs = if isAlgType wDType then dataTypeConstrs wDType else [] + + -- The module prefix of this type, so we can use it in constructor names. + modPrefix + = if '.' `elem` (takeWhile (\c -> isAlphaNum c || c == '.') wName) + then takeWhile (/= '.') wName ++ "." + else "" + + ctrArgs ctr + = gmapQ DataBox (fromConstr ctr :: t) + ctrArgTypes ctr + = [show $ typeOf w | DataBox w <- ctrArgs ctr] + + -- | An instance that describes what to do when we have no transformations + -- left to apply. + baseInst :: [String] + baseInst + = [ "instance (" ++ concat (intersperse ", " context) ++ ") =>" + , " PolyplateM (" ++ wName ++ ") () (f, ops) m where" + ] ++ + (if isAlgType wDType + -- An algebraic type: apply to each child if we're following. + then (concatMap constrCase wCtrs) + -- A primitive type: just return it. + else [" transformM () _ v = return v"]) ++ + ["" + , "instance PolyplateM (" ++ wName ++ ") () () m where" + , " transformM () () v = return v" + ] ++ + if genOverlapped == GenWithoutOverlapped then [] else + [ "instance (Monad m" + , " ,PolyplateM (" ++ wName ++ ") r ops m) =>" + , " PolyplateM (" ++ wName ++ ") (a -> m a, r) ops m where" + , " transformM (_, rest) ops v = transformM rest ops v" + ] + + -- | Class context for 'baseInst'. + -- We need an instance of Polyplate for each of the types directly contained within + -- this type, so we can recurse into them. + context :: [String] + context + = ["Monad m"] ++ + ["PolyplateM (" ++ argType ++ ") (f,ops) () m" + | argType <- nub $ sort $ concatMap ctrArgTypes wCtrs] + + -- | A 'transformM' case for a particular constructor of this (algebraic) + -- data type: pull the value apart, apply 'transformM' to each part of it, + -- then stick it back together. + constrCase :: Constr -> [String] + constrCase ctr + = [ " transformM () " ++ (if argNums == [] then "_" else "ops") ++ + " (" ++ ctrInput ++ ")" + , " = do" + ] ++ + [ " r" ++ show i ++ " <- transformM ops () a" ++ show i + | i <- argNums] ++ + [ " return (" ++ ctrResult ++ ")" + ] + where + argNums = [0 .. ((length $ ctrArgs ctr) - 1)] + ctrS = show ctr + ctrName = modPrefix ++ ctrS + makeCtr vs = ctrName ++ concatMap (" " ++) vs + ctrInput = makeCtr ["a" ++ show i | i <- argNums] + ctrResult = makeCtr ["r" ++ show i | i <- argNums] + + + -- | An instance that describes how to apply -- or not apply -- a + -- transformation. + otherInst :: Data s => Int -> Set.Set Int -> s -> Int -> [String] + otherInst wKey containedKeys c cKey + = if not shouldGen then [] else + [ "instance (Monad m" ++ other ++ ") =>" + , " PolyplateM (" ++ wName ++ ") ((" ++ cName ++ ") -> m (" ++ cName ++ "), r)" + , " ops m where" + , impl + , "" + ] + where + cName = show $ typeOf c + (shouldGen, other, impl) + -- This type matches the transformation: apply it. + | wKey == cKey + = (True + ,"" + ," transformM (f, _) _ v = f v") + -- This type might contain the type that the transformation acts + -- upon + | cKey `Set.member` containedKeys + = (True + ,", PolyplateM (" ++ wName ++ ") r ((" ++ cName ++ ") -> m (" ++ cName ++ "), ops) m" + ," 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" + ," transformM (_, rest) ops v = transformM rest ops v") + -- This is covered by one big overlapping instance: + | otherwise = (False,"","") + +-- | Generates all the given instances (eliminating any duplicates) +-- with the given options. +genInstances :: GenOverlappedOption -> GenClassOption -> [GenInstance] -> IO [String] +genInstances op1 op2 insts + = do typeMap <- flip execStateT Map.empty (sequence [g | GenInstance g <- insts]) + liftM concat $ sequence [instancesFrom op1 op2 (justBoxes typeMap) w | DataBox w <- justBoxes typeMap] + +-- | Generates the instances according to the options and writes it to stdout with +-- the header for the given first line and module name. +writeInstances :: GenOverlappedOption -> GenClassOption -> [GenInstance] -> String + -> String -> IO () +writeInstances op1 op2 inst firstLine moduleName + = do instLines <- genInstances op1 op2 inst + putStr (unlines (genHeader firstLine moduleName ++ instLines)) + +-- | Generates the instances according to the options and writes it to a file with +-- the header and given module name. +writeInstancesTo :: GenOverlappedOption -> GenClassOption -> [GenInstance] -> String + -> String -> FilePath -> IO () +writeInstancesTo op1 op2 inst firstLine moduleName fileName + = do instLines <- genInstances op1 op2 inst + writeFile fileName (unlines (genHeader firstLine moduleName ++ instLines)) + + +--{{{ Various SYB-based functions that we don't export, for discovering contained types: + -- | A type that can contain any 'Data' item. data DataBox = forall t. Data t => DataBox t @@ -89,220 +336,4 @@ justBoxes = map snd . sortBy cmp . Map.elems where cmp (l, _) (r, _) = compare l r --- | Generates instances for all types within the given type. Therefore you should --- only need one or two of these calls to cover all of a complex data structure. -genInstance :: Data t => t -> GenInstance -genInstance = GenInstance . findTypesIn - --- Explanation of Polyplate (as Neil understands it): --- --- Polyplate is a type-class system for automatically applying generic transformations --- to the first instance of a specific type in a large data structure. --- --- A set of operations is represented as a tuple list, e.g. --- --- > (a -> m a, (b -> m b, (c -> m c, ()))) --- --- The unit type is the list terminator. --- --- The Polyplate class takes four parameters. The first is the monad in which --- it operates, which is just passed through. The second is the list of operations --- still to be checked against the current type. The third is the list of operations --- to be applied if we directly recurse, and the fourth is the type currently being --- processed. --- --- There are broadly four types of instance generated by this module: --- --- * The "exact match" instance. This is of the form: --- --- > instance Monad m => Polyplate m (a -> m a, r) ops a where --- > transformM (f,_) _ v = f v --- --- This just applies the transformation directly, as you can see, ignoring the --- other bits and bobs. --- --- --- * The "directly recurse" instance. For a data type: --- --- > data Foo = ConstrBar Bar | ConstrBazQuux Baz Quux --- --- This is of the form: --- --- > instance (Monad m, Polyplate m (f,ops) () Bar, Polyplate m (f,ops) () Baz, Polyplate m (f,ops) () Quux) => --- > Polyplate m () (f, ops) Foo where --- > transformM () ops (ConstrBar a0) --- > = do r0 <- transformM ops () a0 --- > return (ConstrBar r0) --- > transformM () ops (ConstrBazQuux a0 a1) --- > = do r0 <- transformM ops () a0 --- > r1 <- transformM ops () a1 --- > return (ConstrBazQuux r0 r1) --- --- The reason for using (f, ops) in the type-class header is to distinguish this --- from the empty set of operations (see lower down). The operations that are --- to be applied on descent (the third parameter) are passed to the sub-instances --- as the list of operations to be checked (the second parameter), with a new blank --- list of operations to apply on descent. The bodies of the methods just apply --- transformM to each child of the constructor, and pull the data-type back together --- again. --- --- --- * The "can contain" instance. This is of the form: --- --- > instance (Monad m, Polyplate m r (a -> m a, ops) t) => --- > Polyplate m (a -> m a, r) ops t where --- > transformM (f, rest) ops v = transformM rest (f, ops) v --- --- Here, the type being considered, t, can contain the type referred to by the --- operation, a. So we transfer the operation from the list we're processing onto --- the list to apply in case of direct recursion. Then we continue processing --- the list of operations. --- --- * The "cannot contain" instance. This is of the form: --- --- > instance (Monad m, Polyplate m r ops t) => --- > Polyplate m (a -> m a, r) ops t where --- > transformM (_, rest) ops v = transformM rest ops v --- --- This instance is based on the logic that if we have worked out that a big type --- (like Foo) cannot contain a certain type (say, String) then by implication, --- neither of its children can contain Strings either. So we omit the transformation --- of the type (in this example String) when we directly descend into Foo, by not --- copying the transformation onto the third parameter. --- --- The final thing we need, which is generated in the header above, is a base case --- for when both the second and third parameters are empty. This means there are --- no operations left to examine, but also none available for direct recursion. --- At this point we just return the value unchanged. - - - --- | Instances for a particular data type (i.e. where that data type is the --- last argument to 'Polyplate'). -instancesFrom :: forall t. Data t => [DataBox] -> t -> IO [String] -instancesFrom boxes w - = do containedTypes <- findTypesIn' w - containedKeys <- liftM Set.fromList - (sequence [typeKey c | DataBox c <- justBoxes containedTypes]) - wKey <- typeKey w - otherInsts <- sequence [do ck <- typeKey c - return (otherInst wKey containedKeys c ck) - | DataBox c <- boxes] - return $ baseInst ++ concat otherInsts - where - wName = show $ typeOf w - wDType = dataTypeOf w - wCtrs = if isAlgType wDType then dataTypeConstrs wDType else [] - - -- The module prefix of this type, so we can use it in constructor names. - modPrefix - = if '.' `elem` (takeWhile (\c -> isAlphaNum c || c == '.') wName) - then takeWhile (/= '.') wName ++ "." - else "" - - ctrArgs ctr - = gmapQ DataBox (fromConstr ctr :: t) - ctrArgTypes ctr - = [show $ typeOf w | DataBox w <- ctrArgs ctr] - - -- | An instance that describes what to do when we have no transformations - -- left to apply. - baseInst :: [String] - baseInst - = [ "instance (" ++ concat (intersperse ", " context) ++ ") =>" - , " Polyplate (" ++ wName ++ ") () (f, ops) m where" - ] ++ - (if isAlgType wDType - -- An algebraic type: apply to each child if we're following. - then (concatMap constrCase wCtrs) - -- A primitive type: just return it. - else [" transformM () _ v = return v"]) ++ - [""] - - -- | Class context for 'baseInst'. - -- We need an instance of Polyplate for each of the types contained within - -- this type, so we can recurse into them. - context :: [String] - context - = ["Monad m"] ++ - ["Polyplate (" ++ argType ++ ") (f,ops) () m" - | argType <- nub $ sort $ concatMap ctrArgTypes wCtrs] - - -- | A 'transformM' case for a particular constructor of this (algebraic) - -- data type: pull the value apart, apply 'transformM' to each part of it, - -- then stick it back together. - constrCase :: Constr -> [String] - constrCase ctr - = [ " transformM () " ++ (if argNums == [] then "_" else "ops") ++ - " (" ++ ctrInput ++ ")" - , " = do" - ] ++ - [ " r" ++ show i ++ " <- transformM ops () a" ++ show i - | i <- argNums] ++ - [ " return (" ++ ctrResult ++ ")" - ] - where - (isTuple, argNums) - -- FIXME: Should work for 3+-tuples too - | ctrS == "(,)" = (True, [0 .. 1]) - | otherwise = (False, [0 .. ((length $ ctrArgs ctr) - 1)]) - ctrS = show ctr - ctrName = modPrefix ++ ctrS - makeCtr vs - = if isTuple - then "(" ++ (concat $ intersperse ", " vs) ++ ")" - else ctrName ++ concatMap (" " ++) vs - ctrInput = makeCtr ["a" ++ show i | i <- argNums] - ctrResult = makeCtr ["r" ++ show i | i <- argNums] - - - -- | An instance that describes how to apply -- or not apply -- a - -- transformation. - otherInst :: Data s => Int -> Set.Set Int -> s -> Int -> [String] - otherInst wKey containedKeys c cKey - = [ "instance (Monad m" ++ other - , " Polyplate (" ++ wName ++ ") ((" ++ cName ++ ") -> m (" ++ cName ++ "), r)" - , " ops m where" - , impl - , "" - ] - where - cName = show $ typeOf c - (other, impl) - -- This type matches the transformation: apply it. - | wKey == cKey - = (") =>" - ," transformM (f, _) _ v = f v") - -- This type might contain the type that the transformation acts - -- upon: set the flag to say we need to recurse into it. - | cKey `Set.member` containedKeys - = (", Polyplate (" ++ wName ++ ") r ((" ++ cName ++ ") -> m (" ++ cName ++ "), ops) m) =>" - ," 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. - | otherwise - = (", Polyplate (" ++ wName ++ ") r ops m) =>" - ," transformM (_, rest) ops v = transformM rest ops v") - --- | Generates all the given instances (eliminating any duplicates) --- with the given options. -genInstances :: GenOverlappedOption -> GenClassOption -> [GenInstance] -> IO [String] -genInstances _ _ insts - = do typeMap <- flip execStateT Map.empty (sequence [g | GenInstance g <- insts]) - liftM concat $ sequence [instancesFrom (justBoxes typeMap) w | DataBox w <- justBoxes typeMap] - --- | Generates the instances according to the options and writes it to stdout with --- the header for the given first line and module name. -writeInstances :: GenOverlappedOption -> GenClassOption -> [GenInstance] -> String - -> String -> IO () -writeInstances op1 op2 inst firstLine moduleName - = do instLines <- genInstances op1 op2 inst - putStr (unlines (genHeader firstLine moduleName ++ instLines)) - --- | Generates the instances according to the options and writes it to a file with --- the header and given module name. -writeInstancesTo :: GenOverlappedOption -> GenClassOption -> [GenInstance] -> String - -> String -> FilePath -> IO () -writeInstancesTo op1 op2 inst firstLine moduleName fileName - = do instLines <- genInstances op1 op2 inst - writeFile fileName (unlines (genHeader firstLine moduleName ++ instLines)) +--}}}