suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Added an Applicative-based function to PolyplateM and PolyplateMRoute, which seems to work

Browse Source
This commit is contained in:
Neil Brown 2009-05-06 13:02:51 +00:00
parent 44eabe4baa
commit bc917e1442
3 changed files with 85 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
polyplate/Data/Generics/Polyplate.hs
View File

@ -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

120
polyplate/Data/Generics/Polyplate/GenInstances.hs
View File

@ -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,[],[])

3
pregen/GenNavAST.hs
View File

@ -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"