diff --git a/Makefile.am b/Makefile.am index 8fbd701..0f1123f 100644 --- a/Makefile.am +++ b/Makefile.am @@ -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) diff --git a/polyplate/Data/Generics/Polyplate/GenInstances.hs b/polyplate/Data/Generics/Polyplate/GenInstances.hs new file mode 100644 index 0000000..7ee6548 --- /dev/null +++ b/polyplate/Data/Generics/Polyplate/GenInstances.hs @@ -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 . +-} + +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)) diff --git a/pregen/GenNavAST.hs b/pregen/GenNavAST.hs index a162471..76f489c 100644 --- a/pregen/GenNavAST.hs +++ b/pregen/GenNavAST.hs @@ -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" +