diff --git a/polyplate/Data/Generics/Polyplate.hs b/polyplate/Data/Generics/Polyplate.hs index d942606..57dbc17 100644 --- a/polyplate/Data/Generics/Polyplate.hs +++ b/polyplate/Data/Generics/Polyplate.hs @@ -133,6 +133,7 @@ module Data.Generics.Polyplate (PolyplateMRoute(..), PolyplateM(..), Polyplate(. ExtOpM, extOpM, ExtOpMRoute, extOpMRoute, ExtOp, extOp, OneOpMRoute, OneOpM, OneOp, TwoOpM, TwoOp ) where +import Control.Applicative import Control.Monad.Identity import Data.Maybe import Data.Tree @@ -180,6 +181,7 @@ import Data.Generics.Polyplate.Route -- use the helper functions lower down in this module. class PolyplateMRoute t o o' where transformMRoute :: Monad m => o m outer -> o' m outer -> (t, Route t outer) -> m t + transformARoute :: Applicative f => o f outer -> o' f outer -> (t, Route t outer) -> f t -- | A derivative of PolyplateMRoute without all the route stuff. -- @@ -218,8 +220,8 @@ class PolyplateMRoute t o o' where -- Generally you will not use this function or type-class directly, but will instead -- use the helper functions lower down in this module. class PolyplateM t o o' where - transformM :: (Monad m) => o m -> o' m -> t -> m t - + transformM :: Monad m => o m -> o' m -> t -> m t + transformA :: Applicative f => o f -> o' f -> t -> f t instance ( PolyplateMRoute t o o' @@ -231,6 +233,12 @@ instance ( where fakeRoute :: t -> Route t () fakeRoute = const $ error "transformM" + transformA o o' t = transformARoute (convertOpsToIgnoreRoute o) + (convertOpsToIgnoreRoute o') + (t, fakeRoute t) + where + fakeRoute :: t -> Route t () + fakeRoute = const $ error "transformA" -- | A non-monadic equivalent of PolyplateM. All ops sets are of the form: -- @@ -266,16 +274,16 @@ type Recurse opT = forall t. Polyplate t opT BaseOp => t -> t -- | Given a set of operations (as described in the 'Polyplate' type-class), -- makes a modifier function that applies the operations directly. makeRecurse :: opT -> Recurse opT -makeRecurse ops = transform ops () +makeRecurse ops = transform ops baseOp -- | A type representing a modifier function that applies the given ops -- (opT) to the children of the given type (t). -type Descend opT = forall t. Polyplate t () opT => t -> t +type Descend opT = forall t. Polyplate t BaseOp opT => t -> t -- | Given a set of operations (as described in the 'PolyplateM' type-class), -- makes a descent modifier function that applies the operation to the type's children. makeDescend :: opT -> Descend opT -makeDescend ops = transform () ops +makeDescend ops = transform baseOp ops {- type RecurseQ a opQ = forall t. PolyplateSpine t opQ () a => t -> Tree (Maybe a) @@ -395,8 +403,8 @@ instance ConvertSpineOpsToFull b r r' => ConvertSpineOpsToFull b (a, r) (a, r') -- | A helper class to convert operations not expecting a route to those that ignore -- the route (which will have the unit type as its outer type). -class ConvertOpsToIgnoreRoute o o' | o -> o' where - convertOpsToIgnoreRoute :: Monad m => o m -> o' m () +class ConvertOpsToIgnoreRoute (o :: (* -> *) -> *) o' | o -> o' where + convertOpsToIgnoreRoute :: o m -> o' m () instance ConvertOpsToIgnoreRoute BaseOpM BaseOpMRoute where convertOpsToIgnoreRoute = const baseOpMRoute diff --git a/polyplate/Data/Generics/Polyplate/GenInstances.hs b/polyplate/Data/Generics/Polyplate/GenInstances.hs index b1bd11e..6a23cdb 100644 --- a/polyplate/Data/Generics/Polyplate/GenInstances.hs +++ b/polyplate/Data/Generics/Polyplate/GenInstances.hs @@ -102,8 +102,7 @@ data Witness | Detailed { witness :: DataBox , directlyContains :: [DataBox] -- First is funcSameType, second is funcNewType: - , processChildrenMod :: (String, String) -> [String] - , processChildrenSpine :: (String, String) -> [String] + , processChildrenMod :: (Bool -> String, Bool -> String) -> [String] } -- The Eq instance is based on the inner type. @@ -111,6 +110,18 @@ instance Eq Witness where (==) wx wy = case (witness wx, witness wy) of (DataBox x, DataBox y) -> typeOf x == typeOf y +funcPlain :: Bool -> String +funcPlain True = "return" +funcPlain False = "pure" + +funcAp :: Bool -> String +funcAp True = "`ap`" +funcAp False = "<*>" + +funcTraverse :: Bool -> String +funcTraverse True = "T.mapM" +funcTraverse False = "T.traverse" + -- | Generates an instance for the 'Data.Map.Map' type. Map is a difficult type -- because its instance of Data hides its implementation, so we can't actually -- use the Data instance to work out what the children are (as we can do for other @@ -128,15 +139,12 @@ genMapInstance k v tk <- liftIO $ typeKey m modify (Map.insert tk (show $ typeOf m, Detailed (DataBox m) [DataBox (k, v), DataBox k, DataBox v] - (\(funcSameType, funcNewType) -> - [funcSameType ++ " _ ops (v, r) = let mns = zip (Map.toList v) (map ((r @->) . routeDataMap) [0..]) in" - ," do m <- mapM (" ++ funcNewType ++ " ops BaseOpMRoute) mns" - ," return (Map.fromList m)" - ]) - (\(funcSameType, funcNewType) -> - [funcSameType ++ " _ ops q v = Node q (map (" - ++ funcNewType ++ " ops BaseOpMRoute Nothing) (Map.toList v))" - ]) + (\(funcSameType, funcNewType) -> concat [ + [funcSameType b ++ " _ ops (v, r) = let mns = zip (Map.toList v) (map ((r @->) . routeDataMap) [0..]) in" + ," " ++ funcPlain b ++ " Map.fromList " ++ funcAp b + ++ " (" ++ funcTraverse b ++ " (" ++ funcNewType b ++ " ops BaseOpMRoute) mns)" + ] + | b <- [True, False]]) )) where m :: Map k v @@ -152,15 +160,12 @@ genSetInstance x tk <- liftIO $ typeKey s modify (Map.insert tk (show $ typeOf s, Detailed (DataBox s) [DataBox x] - (\(funcSameType, funcNewType) -> - [funcSameType ++ " _ ops (v, r) = let sns = zip (Set.toList v) (map ((r @->) . routeDataSet) [0..]) in" - ," do s <- mapM (" ++ funcNewType ++ " ops BaseOpMRoute) sns" - ," return (Set.fromList s)" - ]) - (\(funcSameType, funcNewType) -> - [funcSameType ++ " _ ops q v = Node q (map (" - ++ funcNewType ++ " ops BaseOpMRoute Nothing) (Set.toList v))" - ]) + (\(funcSameType, funcNewType) -> concat [ + [funcSameType b ++ " _ ops (v, r) = let sns = zip (Set.toList v) (map ((r @->) . routeDataSet) [0..]) in" + ," " ++ funcPlain b ++ " Set.fromList " ++ funcAp b + ++ " (" ++ funcTraverse b ++ " (" ++ funcNewType b ++ " ops BaseOpMRoute) sns)" + ] | b <- [True, False]]) + )) where s :: Set a @@ -262,7 +267,7 @@ instancesFrom :: forall t. Data t => GenOverlappedOption -> GenClassOption -> [W instancesFrom genOverlapped genClass boxes w = do (specialProcessChildren, containedTypes) <- case find (== Plain (DataBox w)) boxes of - Just (Detailed _ containedTypes doChildren _) -> + Just (Detailed _ containedTypes doChildren) -> -- It's a special case, use the detailed info: do eachContained <- sequence [findTypesIn' c | DataBox c <- containedTypes] return (Just (containedTypes, doChildren), foldl Map.union Map.empty eachContained) @@ -328,47 +333,58 @@ instancesFrom genOverlapped genClass boxes w -- The function to define in the body, and also to use for processing the same -- type. - funcSameType :: String - funcSameType = case genClass of - GenClassPerType -> "transformMRoute" ++ wMunged - GenOneClass -> "transformMRoute" - GenSlowDelegate -> "transformMRoute'" + funcSameType :: Bool -> String + funcSameType monad = case genClass of + GenClassPerType -> base ++ wMunged + GenOneClass -> base + GenSlowDelegate -> base ++ "'" + where + base = if monad then "transformMRoute" else "transformARoute" -- The function to use for processing other types - funcNewType :: String - funcNewType = case genClass of - GenClassPerType -> "transformMRoute" - GenOneClass -> "transformMRoute" - GenSlowDelegate -> "transformMRoute'" + funcNewType :: Bool -> String + funcNewType monad = case genClass of + GenClassPerType -> base + GenOneClass -> base + GenSlowDelegate -> base ++ "'" + where + base = if monad then "transformMRoute" else "transformARoute" -- | 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). - baseInst :: Maybe ([DataBox], (String, String) -> [String]) -> [String] + baseInst :: Maybe ([DataBox], (Bool -> String, Bool -> String) -> [String]) -> [String] baseInst mdoChildren = concat [genInst context "BaseOpMRoute" "(f :-@ ops)" $ maybe - (if isAlgType wDType + (concat + [if isAlgType wDType -- An algebraic type: apply to each child if we're following. - then (concatMap constrCase wCtrs) + then (concatMap (constrCase b) wCtrs) -- A primitive (or non-represented) type: just return it. - else [funcSameType ++ " _ _ (v, _) = return v"]) + else [funcSameType b ++ " _ _ (v, _) = " ++ funcPlain b ++ " v"] + | b <- [True, False]]) (\(_,f) -> f (funcSameType, funcNewType)) mdoChildren - ,genInst [] "BaseOpMRoute" "BaseOpMRoute" [funcSameType ++ " _ _ (v, _) = return v"] + ,genInst [] "BaseOpMRoute" "BaseOpMRoute" + [funcSameType b ++ " _ _ (v, _) = " ++ funcPlain b ++ " v" | b <- [True, False]] ,if genOverlapped == GenWithoutOverlapped then [] else genInst [ contextSameType "r" "ops" ] "(a :-@ r)" "ops" - [funcSameType ++ " (_ :-@ rest) ops vr = " ++ funcSameType ++ " rest ops vr"] + [funcSameType b ++ " (_ :-@ rest) ops vr = " ++ funcSameType b ++ " rest ops vr" + | b <- [True, False]] ,if genClass == GenClassPerType then ["class PolyplateMRoute" ++ wMunged ++ " o o' where" - ," " ++ funcSameType ++ " :: o m outer -> o' m outer -> (" ++ wName + ," " ++ funcSameType True ++ " :: Monad m => o m outer -> o' m outer -> (" ++ wName ++ ", Route (" ++ wName ++ ") outer) -> m (" ++ wName ++ ")" + ," " ++ funcSameType False ++ " :: Applicative a => o a outer -> o' a outer -> (" ++ wName + ++ ", Route (" ++ wName ++ ") outer) -> a (" ++ wName ++ ")" ,"" ,"instance (" ++ contextSameType "o0" "o1" ++ ") =>" ," PolyplateMRoute (" ++ wName ++ ") o0 o1 where" - ," transformMRoute = " ++ funcSameType + ," transformMRoute = " ++ funcSameType True + ," transformARoute = " ++ funcSameType False ] else [] ] @@ -385,19 +401,17 @@ instancesFrom genOverlapped genClass boxes w -- | 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 - = [ funcSameType ++ " _ " ++ (if argNums == [] then "_" else "ops") ++ + constrCase :: Bool -> Constr -> [String] + constrCase b ctr + = [ funcSameType b ++ " _ " ++ (if argNums == [] then "_" else "ops") ++ " (" ++ ctrInput ++ " , " ++ (if argNums == [] then "_" else "rt") ++ ")" - , " = do" + , " = " ++ funcPlain b ++ " " ++ ctrName ] ++ - [ " r" ++ show i ++ " <- " ++ funcNewType ++ " ops BaseOpMRoute (a" ++ show i + [ " " ++ funcAp b ++ " (" ++ funcNewType b ++ " ops BaseOpMRoute (a" ++ show i ++ ", rt @-> makeRoute [" ++ show i ++ "] " ++ "(\\f (" ++ ctrMod ++ ") -> f b" ++ show i - ++ " >>= (\\b" ++ show i ++ " -> return (" ++ ctrMod ++ "))))" - | i <- argNums] ++ - [ " return (" ++ ctrResult ++ ")" - ] + ++ " >>= (\\b" ++ show i ++ " -> return (" ++ ctrMod ++ ")))))" + | i <- argNums] where argNums = [0 .. ((length $ ctrArgs ctr) - 1)] ctrS = show ctr @@ -405,8 +419,6 @@ instancesFrom genOverlapped genClass boxes w makeCtr vs = ctrName ++ concatMap (" " ++) vs ctrInput = makeCtr ["a" ++ show i | i <- argNums] ctrMod = makeCtr ["b" ++ show i | i <- argNums] - ctrResult = makeCtr ["r" ++ show i | i <- argNums] - -- | An instance that describes how to apply -- or not apply -- a -- transformation. @@ -424,19 +436,21 @@ instancesFrom genOverlapped genClass boxes w | wKey == cKey = (True ,[] - ,[funcSameType ++ " (f :-@ _) _ vr = f vr"]) + ,[funcSameType b ++ " (f :-@ _) _ vr = f vr" | b <- [True, False]]) -- This type might contain the type that the transformation acts -- upon | cKey `Set.member` containedKeys = (True ,[contextSameType "r" ("((" ++ cName ++ ") :-@ ops)")] - ,[funcSameType ++ " (f :-@ rest) ops vr = " ++ funcSameType ++ " rest (f :-@ ops) vr"]) + ,[funcSameType b ++ " (f :-@ rest) ops vr = " ++ funcSameType b ++ " rest (f :-@ ops) vr" + | b <- [True, False]]) -- This type can't contain the transformed type; just move on to the -- next transformation. | genOverlapped == GenWithoutOverlapped = (True ,[contextSameType "r" "ops"] - ,[funcSameType ++ " (_ :-@ rest) ops vr = " ++ funcSameType ++ " rest ops vr"]) + ,[funcSameType b ++ " (_ :-@ rest) ops vr = " ++ funcSameType b ++ " rest ops vr" + | b <- [True, False]]) -- This is covered by one big overlapping instance: | otherwise = (False,[],[]) diff --git a/pregen/GenNavAST.hs b/pregen/GenNavAST.hs index 50d2ba6..73461cc 100644 --- a/pregen/GenNavAST.hs +++ b/pregen/GenNavAST.hs @@ -63,6 +63,8 @@ main = do ,"-- | This module is auto-generated by Polyplate. DO NOT EDIT." ,"module " ++ moduleName ++ " () where" ,"" + ,"import Control.Applicative" + ,"import Control.Monad" ,"import Data.Generics.Polyplate" ,if isSpine then "" else "import Data.Generics.Polyplate.Route" ,"" @@ -71,6 +73,7 @@ main = do ,"import Data.Maybe" ,"import Data.Set (Set)" ,"import qualified Data.Set as Set" + ,"import qualified Data.Traversable as T" ,if isSpine then "import Data.Tree" else "" ,"" ,"import qualified AST"