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

Added routes to Polyplate, making the main class PolyplateMRoute and thus PolyplateM is a derivative of this with the old functionality

Browse Source 
Also changed the generation of the instances to generate PolyplateMRoute instances instead of PolyplateM
This commit is contained in:
Neil Brown 2008-12-14 22:47:24 +00:00
parent b94091a08c
commit 8ea930541f
3 changed files with 97 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -27,7 +27,7 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
-- Instances of the PolyplateM type-class /can/ be written manually but it's not
-- advised. Instead, you should use functions in the "GenPolyplate" module to automatically
-- generate source files with the appropriate instances.
module Data.Generics.Polyplate (PolyplateM(..), Polyplate(..),
module Data.Generics.Polyplate (PolyplateMRoute(..), PolyplateM(..), Polyplate(..),
PolyplateSpine(..), FullSpine(..), transformSpine, transformSpineFull, trimTree,
makeRecurseM, RecurseM, makeRecurse, Recurse,
makeDescendM, DescendM, makeDescend, Descend,
@ -38,10 +38,11 @@ module Data.Generics.Polyplate (PolyplateM(..), Polyplate(..),
ExtOpQ, extOpQ, OneOpQ, TwoOpQ) where
import Control.Monad.Identity
import Data.Maybe
import Data.Tree
import Data.Generics.Polyplate.Route
-- | The main Polyplate type-class.
--
-- The first parameter is the larger\/outer type on which you want to operate.
@ -77,8 +78,20 @@ import Data.Tree
--
-- Generally you will not use this function or type-class directly, but will instead
-- use the helper functions lower down in this module.
class Monad m => PolyplateM t o o' m where
transformM :: o -> o' -> t -> m t -- TODO add routes
class Monad m => PolyplateMRoute t o o' m outer where
transformMRoute :: o -> o' -> (t, Route t outer) -> m t
class (Monad m) => PolyplateM t o o' m where
transformM :: o -> o' -> t -> m t
instance forall t ro o ro' o' m. (Monad m
, PolyplateMRoute t o o' m ()
, ConvertOpsToIgnoreRoute ro o
, ConvertOpsToIgnoreRoute ro' o') => PolyplateM t ro ro' m where
transformM o o' t = transformMRoute (convertOpsToIgnoreRoute o)
(convertOpsToIgnoreRoute o')
(t, error "transformM" :: Route t ())
-- List of use cases for the Polyplate type-class, to try to decide best on its
-- necessary functions:
@ -123,32 +136,12 @@ transformSpineFull def o o' x
fromJust' (Just x) = x
fromJust' _ = error "transformSpineFull: internal error"
class ConvertSpineOpsToFull a o o' | a o -> o' where
convertSpineOpsToFull :: a -> o -> o'
instance ConvertSpineOpsToFull a () (FullSpine a) where
convertSpineOpsToFull def _ = FullSpine def
instance ConvertSpineOpsToFull b r r' => ConvertSpineOpsToFull b (a, r) (a, r') where
convertSpineOpsToFull def (f, r) = (f, convertSpineOpsToFull def r)
trimTree :: Tree (Maybe a) -> Maybe (Tree (Maybe a))
trimTree tr | isNothing (rootLabel tr) && null trimmedChildren = Nothing
| otherwise = Just (Node (rootLabel tr) trimmedChildren)
where
trimmedChildren = mapMaybe trimTree (subForest tr)
-- | A helper class to convert non-monadic transformations into monadic ones in
-- the Identity monad.
class ConvertOpsToIdentity o o' | o -> o' where
convertOpsToIdentity :: o -> o'
instance ConvertOpsToIdentity () () where
convertOpsToIdentity = id
instance ConvertOpsToIdentity r r' => ConvertOpsToIdentity (a -> a, r) (a -> Identity a, r') where
convertOpsToIdentity (f, r) = (return . f, convertOpsToIdentity r)
-- | A non-monadic equivalent of PolyplateM. All ops sets are of the form:
--
-- > (a -> a, (b -> b, ()))
@ -260,3 +253,41 @@ type TwoOp s t = ExtOp (ExtOp BaseOp s) t
type TwoOpQ a s t = ExtOpQ a (ExtOpQ a BaseOp s) t
-- {{{ Various type-level programming ops conversions:
-- | A helper class to convert non-monadic transformations into monadic ones in
-- the Identity monad.
class ConvertOpsToIdentity o o' | o -> o' where
convertOpsToIdentity :: o -> o'
instance ConvertOpsToIdentity () () where
convertOpsToIdentity = id
instance ConvertOpsToIdentity r r' => ConvertOpsToIdentity (a -> a, r) (a -> Identity a, r') where
convertOpsToIdentity (f, r) = (return . f, convertOpsToIdentity r)
-- | A helper class to convert operation lists to have FullSpine at their base
-- rather than BaseOp
class ConvertSpineOpsToFull a o o' | a o -> o' where
convertSpineOpsToFull :: a -> o -> o'
instance ConvertSpineOpsToFull a () (FullSpine a) where
convertSpineOpsToFull def _ = FullSpine def
instance ConvertSpineOpsToFull b r r' => ConvertSpineOpsToFull b (a, r) (a, r') where
convertSpineOpsToFull def (f, r) = (f, convertSpineOpsToFull def 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 :: o -> o'
instance ConvertOpsToIgnoreRoute () () where
convertOpsToIgnoreRoute = id
instance ConvertOpsToIgnoreRoute r r' =>
ConvertOpsToIgnoreRoute (t -> m t, r) ((t, Route t ()) -> m t, r') where
convertOpsToIgnoreRoute (f, r) = (f . fst, convertOpsToIgnoreRoute r)
-- }}}

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

@ -102,10 +102,9 @@ genMapInstance k v
modify (Map.insert tk (show $ typeOf m,
Detailed (DataBox m) [DataBox (k, v), DataBox k, DataBox v]
(\(funcSameType, funcNewType) ->
[funcSameType ++ " () ops v = do"
," keys <- mapM (" ++ funcNewType ++ " ops () . fst) (Map.toList v)"
," vals <- mapM (" ++ funcNewType ++ " ops () . snd) (Map.toList v)"
," return (Map.fromList (zip keys vals))"
[funcSameType ++ " () ops (v, r) = let mns = zip (Map.toList v) (map ((r @->) . routeDataMap) [0..]) in"
," do m <- mapM (" ++ funcNewType ++ " ops ()) mns"
," return (Map.fromList m)"
])
(\(funcSameType, funcNewType) ->
[funcSameType ++ " () ops q v = Node q (map ("
@ -127,9 +126,9 @@ genSetInstance x
modify (Map.insert tk (show $ typeOf s,
Detailed (DataBox s) [DataBox x]
(\(funcSameType, funcNewType) ->
[funcSameType ++ " () ops v = do"
," vals <- mapM (" ++ funcNewType ++ " ops ()) (Set.toList v)"
," return (Set.fromList vals)"
[funcSameType ++ " () ops (v, r) = let sns = zip (Set.toList v) (map ((r @->) . routeDataSet) [0..]) in"
," do s <- mapM (" ++ funcNewType ++ " ops ()) sns"
," return (Set.fromList s)"
])
(\(funcSameType, funcNewType) ->
[funcSameType ++ " () ops q v = Node q (map ("
@ -287,33 +286,33 @@ instancesFrom genOverlapped genClass boxes w
-- sets. The class name will be the same as genInst.
contextSameType :: String -> String -> String
contextSameType ops0 ops1 = case genClass of
GenOneClass -> "PolyplateM (" ++ wName ++ ") " ++ ops0 ++ " " ++ ops1 ++ " m"
GenClassPerType -> "PolyplateM" ++ wMunged ++" " ++ ops0 ++ " " ++ ops1 ++ " m"
GenSlowDelegate -> "PolyplateM' m " ++ ops0 ++ " " ++ ops1 ++ " (" ++ wName ++ ")"
GenOneClass -> "PolyplateMRoute (" ++ wName ++ ") " ++ ops0 ++ " " ++ ops1 ++ " m outer"
GenClassPerType -> "PolyplateMRoute" ++ wMunged ++" " ++ ops0 ++ " " ++ ops1 ++ " m outer"
GenSlowDelegate -> "PolyplateMRoute' m " ++ ops0 ++ " " ++ ops1 ++ " (" ++ wName ++ ") outer"
-- 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 = case genClass of
GenOneClass -> "PolyplateM (" ++ cName ++ ") " ++ ops0 ++ " " ++ ops1 ++ " m"
GenClassPerType -> "PolyplateM (" ++ cName ++ ") " ++ ops0 ++ " " ++ ops1 ++ " m"
GenSlowDelegate -> "PolyplateM' m " ++ ops0 ++ " " ++ ops1 ++ " (" ++ cName ++ ")"
GenOneClass -> "PolyplateMRoute (" ++ cName ++ ") " ++ ops0 ++ " " ++ ops1 ++ " m outer"
GenClassPerType -> "PolyplateMRoute (" ++ cName ++ ") " ++ ops0 ++ " " ++ ops1 ++ " m outer"
GenSlowDelegate -> "PolyplateMRoute' m " ++ ops0 ++ " " ++ ops1 ++ " (" ++ cName ++ ") outer"
-- The function to define in the body, and also to use for processing the same
-- type.
funcSameType :: String
funcSameType = case genClass of
GenClassPerType -> "transformM" ++ wMunged
GenOneClass -> "transformM"
GenSlowDelegate -> "transformM'"
GenClassPerType -> "transformMRoute" ++ wMunged
GenOneClass -> "transformMRoute"
GenSlowDelegate -> "transformMRoute'"
-- The function to use for processing other types
funcNewType :: String
funcNewType = case genClass of
GenClassPerType -> "transformM"
GenOneClass -> "transformM"
GenSlowDelegate -> "transformM'"
GenClassPerType -> "transformMRoute"
GenOneClass -> "transformMRoute"
GenSlowDelegate -> "transformMRoute'"
-- | 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
@ -327,21 +326,22 @@ instancesFrom genOverlapped genClass boxes w
-- An algebraic type: apply to each child if we're following.
then (concatMap constrCase wCtrs)
-- A primitive (or non-represented) type: just return it.
else [funcSameType ++ " () _ v = return v"])
else [funcSameType ++ " () _ (v,_) = return v"])
(\(_,f) -> f (funcSameType, funcNewType)) mdoChildren
,genInst [] "()" "()" [funcSameType ++ " () () v = return v"]
,genInst [] "()" "()" [funcSameType ++ " () () (v,_) = return v"]
,if genOverlapped == GenWithoutOverlapped then [] else
genInst
[ contextSameType "r" "ops" ]
"(a -> m a, r)" "ops"
[funcSameType ++ " (_, rest) ops v = " ++ funcSameType ++ " rest ops v"]
"((a, Route a outer) -> m a, r)" "ops"
[funcSameType ++ " (_, rest) ops vr = " ++ funcSameType ++ " rest ops vr"]
,if genClass == GenClassPerType
then ["class Monad m => PolyplateM" ++ wMunged ++ " o o' m where"
," " ++ funcSameType ++ " :: o -> o' -> (" ++ wName ++ ") -> m (" ++ wName ++ ")"
then ["class Monad m => PolyplateMRoute" ++ wMunged ++ " o o' m outer where"
," " ++ funcSameType ++ " :: o -> o' -> (" ++ wName
++ ", Route (" ++ wName ++ ") outer) -> m (" ++ wName ++ ")"
,""
,"instance (Monad m, " ++ contextSameType "o0" "o1" ++ ") =>"
," PolyplateM (" ++ wName ++ ") o0 o1 m where"
," transformM = " ++ funcSameType
," PolyplateMRoute (" ++ wName ++ ") o0 o1 m outer where"
," transformMRoute = " ++ funcSameType
]
else []
]
@ -361,10 +361,13 @@ instancesFrom genOverlapped genClass boxes w
constrCase :: Constr -> [String]
constrCase ctr
= [ funcSameType ++ " () " ++ (if argNums == [] then "_" else "ops") ++
" (" ++ ctrInput ++ ")"
" (" ++ ctrInput ++ ", " ++ (if argNums == [] then "_" else "rt") ++ ")"
, " = do"
] ++
[ " r" ++ show i ++ " <- " ++ funcNewType ++ " ops () a" ++ show i
[ " r" ++ show i ++ " <- " ++ funcNewType ++ " ops () (a" ++ show i
++ ", rt @-> makeRoute [" ++ show i ++ "] "
++ "(\\f (" ++ ctrMod ++ ") -> f b" ++ show i
++ " >>= (\\b" ++ show i ++ " -> return (" ++ ctrMod ++ "))))"
| i <- argNums] ++
[ " return (" ++ ctrResult ++ ")"
]
@ -374,6 +377,7 @@ instancesFrom genOverlapped genClass boxes w
ctrName = modPrefix ++ ctrS
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]
@ -383,7 +387,7 @@ instancesFrom genOverlapped genClass boxes w
otherInst wKey containedKeys c cKey
= if not shouldGen then [] else
genInst context
("((" ++ cName ++ ") -> m (" ++ cName ++ "), r)")
("((" ++ cName ++ ", Route (" ++ cName ++ ") outer) -> m (" ++ cName ++ "), r)")
"ops"
impl
where
@ -393,19 +397,19 @@ instancesFrom genOverlapped genClass boxes w
| wKey == cKey
= (True
,[]
,[funcSameType ++ " (f, _) _ v = f v"])
,[funcSameType ++ " (f, _) _ vr = f vr"])
-- This type might contain the type that the transformation acts
-- upon
| cKey `Set.member` containedKeys
= (True
,[contextSameType "r" ("((" ++ cName ++ ") -> m (" ++ cName ++ "), ops)")]
,[funcSameType ++ " (f, rest) ops v = " ++ funcSameType ++ " rest (f, ops) v"])
,[contextSameType "r" ("((" ++ cName ++ ", Route (" ++ cName ++ ") outer) -> m (" ++ cName ++ "), ops)")]
,[funcSameType ++ " (f, rest) ops vr = " ++ funcSameType ++ " rest (f, ops) vr"])
-- This type can't contain the transformed type; just move on to the
-- next transformation.
| genOverlapped == GenWithoutOverlapped
= (True
,[contextSameType "r" "ops"]
,[funcSameType ++ " (_, rest) ops v = " ++ funcSameType ++ " rest ops v"])
,[funcSameType ++ " (_, rest) ops vr = " ++ funcSameType ++ " rest ops vr"])
-- This is covered by one big overlapping instance:
| otherwise = (False,[],[])

7
pregen/GenNavAST.hs
View File

@ -176,18 +176,19 @@ main = do
| otherwise
= (reverse . takeWhile (/= '/') . drop 3 . reverse) $ moduleFileName
header useTree moduleName =
["{-# OPTIONS_GHC -Werror -fwarn-overlapping-patterns -fwarn-unused-matches -fwarn-unused-binds -fwarn-incomplete-patterns #-}"
header isSpine moduleName =
["{-# OPTIONS_GHC -Werror -fwarn-overlapping-patterns -fwarn-unused-matches -fwarn-unused-binds #-}"
,"-- | This module is auto-generated by Polyplate. DO NOT EDIT."
,"module " ++ moduleName ++ " where"
,""
,"import Data.Generics.Polyplate"
,if isSpine then "" else "import Data.Generics.Polyplate.Route"
,""
,"import Data.Map (Map)"
,"import qualified Data.Map as Map"
,"import Data.Set (Set)"
,"import qualified Data.Set as Set"
,if useTree then "import Data.Tree" else ""
,if isSpine then "import Data.Tree" else ""
,""
,"import qualified AST"
,"import qualified CompState"