Added the first version of GenInstances (taken from my latest improvements) and switched GenNavAST to use it, but it needs tidying up and to take account of the options it is given
This commit is contained in:
Neil Brown
parent
01fff6e617
commit
c9100fb467
|
|
@ -228,6 +228,7 @@ tocktest_SOURCES += transformations/SimplifyTypesTest.hs
|
|||
|
||||
pregen_sources = data/AST.hs
|
||||
pregen_sources += pregen/PregenUtils.hs
|
||||
pregen_sources += polyplate/Data/Generics/Polyplate/GenInstances.hs
|
||||
|
||||
GenNavAST_SOURCES = pregen/GenNavAST.hs $(pregen_sources)
|
||||
GenOrdAST_SOURCES = pregen/GenOrdAST.hs $(pregen_sources)
|
||||
|
|
|
|||
308
polyplate/Data/Generics/Polyplate/GenInstances.hs
Normal file
308
polyplate/Data/Generics/Polyplate/GenInstances.hs
Normal file
|
|
@ -0,0 +1,308 @@
|
|||
{-
|
||||
Tock: a compiler for parallel languages
|
||||
Copyright (C) 2008 University of Kent
|
||||
|
||||
This program is free software; you can redistribute it and/or modify it
|
||||
under the terms of the GNU General Public License as published by the
|
||||
Free Software Foundation, either version 2 of the License, or (at your
|
||||
option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but
|
||||
WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License along
|
||||
with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
-}
|
||||
|
||||
module Data.Generics.Polyplate.GenInstances
|
||||
(GenOverlappedOption(..), GenClassOption(..),
|
||||
genHeader, GenInstance, genInstance, genInstances,
|
||||
writeInstances, writeInstancesTo) where
|
||||
|
||||
import Control.Monad.State
|
||||
import Data.Char
|
||||
import Data.Generics
|
||||
import Data.List
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
data GenOverlappedOption = GenWithOverlapped | GenWithoutOverlapped
|
||||
|
||||
data GenClassOption = GenClassPerType | GenOneClass | GenSlowDelegate
|
||||
|
||||
genHeader :: String -> String -> [String]
|
||||
genHeader firstLine moduleName
|
||||
= [firstLine
|
||||
,"-- | Instances for Polyplate."
|
||||
,"-- This library was automatically generated by Data.Generics.Polyplate.GenInstances"
|
||||
,"-- and should NOT be edited directly."
|
||||
,"module " ++ moduleName ++ " where"]
|
||||
|
||||
newtype GenInstance = GenInstance (TypeMapM ())
|
||||
|
||||
-- | A type that can contain any 'Data' item.
|
||||
data DataBox = forall t. Data t => DataBox t
|
||||
|
||||
type TypeMap = Map Int (String, DataBox)
|
||||
type TypeMapM = StateT TypeMap IO
|
||||
|
||||
typeKey :: Typeable t => t -> IO Int
|
||||
typeKey x = typeRepKey $ typeOf x
|
||||
|
||||
findTypesIn' :: Data t => t -> IO TypeMap
|
||||
findTypesIn' x = execStateT (findTypesIn x) Map.empty
|
||||
|
||||
-- | Given a starting value, find all the types that could possibly be inside
|
||||
-- it.
|
||||
findTypesIn :: Data t => t -> TypeMapM ()
|
||||
findTypesIn start = doType start
|
||||
where
|
||||
doType :: Data t => t -> TypeMapM ()
|
||||
doType x
|
||||
= do map <- get
|
||||
key <- liftIO $ typeRepKey rep
|
||||
when (not $ key `Map.member` map) $
|
||||
do modify $ Map.insert key (reps, DataBox x)
|
||||
when (isAlgType dtype) $
|
||||
mapM_ doConstr $ dataTypeConstrs dtype
|
||||
where
|
||||
rep = typeOf x
|
||||
reps = show rep
|
||||
dtype = dataTypeOf x
|
||||
|
||||
doConstr :: Constr -> TypeMapM ()
|
||||
doConstr ctr
|
||||
= sequence_ [doType x' | DataBox x' <- args]
|
||||
where
|
||||
args = gmapQ DataBox (asTypeOf (fromConstr ctr) x)
|
||||
|
||||
-- | Reduce a 'TypeMap' to only the types in a particular module.
|
||||
filterModule :: String -> TypeMap -> TypeMap
|
||||
filterModule prefix = Map.filter (((prefix ++ ".") `isPrefixOf`) . fst)
|
||||
|
||||
-- | Reduce a 'TypeMap' to a list of 'DataBox'es, sorted by name.
|
||||
justBoxes :: TypeMap -> [DataBox]
|
||||
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))
|
||||
|
|
@ -24,6 +24,9 @@ import Data.Generics
|
|||
import Data.List
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Data.Generics.Polyplate.GenInstances
|
||||
|
||||
import qualified AST
|
||||
import PregenUtils
|
||||
import Utils
|
||||
|
||||
|
|
@ -74,7 +77,7 @@ instancesFrom w
|
|||
-- left to apply.
|
||||
baseInst :: [String]
|
||||
baseInst
|
||||
= [ "instance (" ++ joinWith ", " context ++ ") =>"
|
||||
= [ "instance (" ++ concat (intersperse ", " context) ++ ") =>"
|
||||
, " Polyplate m () o0 (" ++ wName ++ ") where"
|
||||
] ++
|
||||
(if isAlgType wDType
|
||||
|
|
@ -116,7 +119,7 @@ instancesFrom w
|
|||
ctrName = modPrefix ++ ctrS
|
||||
makeCtr vs
|
||||
= if isTuple
|
||||
then "(" ++ joinWith ", " vs ++ ")"
|
||||
then "(" ++ (concat $ intersperse ", " vs) ++ ")"
|
||||
else ctrName ++ concatMap (" " ++) vs
|
||||
ctrInput = makeCtr ["a" ++ show i | i <- argNums]
|
||||
ctrResult = makeCtr ["r" ++ show i | i <- argNums]
|
||||
|
|
@ -150,6 +153,9 @@ instancesFrom w
|
|||
= " transformM (_, rest) ops b v = transformM rest ops b v"
|
||||
|
||||
main :: IO ()
|
||||
main = putStr $ unlines $ header ++
|
||||
concat [instancesFrom w
|
||||
| DataBox w <- justBoxes $ astTypeMap]
|
||||
main
|
||||
= writeInstances GenWithoutOverlapped GenOneClass
|
||||
[genInstance (undefined :: AST.AST)]
|
||||
"{-# OPTIONS_GHC -Werror -fwarn-overlapping-patterns -fwarn-unused-matches -fwarn-unused-binds -fwarn-incomplete-patterns #-}"
|
||||
"NavAST"
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user