Skip to content

Commit

Permalink
Separates IR types and transforms into different modules.
Browse files Browse the repository at this point in the history
  • Loading branch information
@tomahawkins
tomahawkins committed Apr 11, 2012
1 parent 484f798 commit e10b394
Showing 1 changed file with 119 additions and 83 deletions.
202 changes: 119 additions & 83 deletions Language/CIRC.hs
View file
Expand Up @@ -53,110 +53,132 @@ data TypeRefinement


-- | A transform is a module name, the constructor to be transformed, a list of new type definitions, -- | A transform is a module name, the constructor to be transformed, a list of new type definitions,
-- and the implementation (imports and code). -- and the implementation (imports and code).
data Transform = Transform ModuleName [Import] CtorName (ModuleName -> Code) [TypeRefinement] data Transform = Transform ModuleName [Import] [Import] CtorName (ModuleName -> Code) [TypeRefinement]


-- | An unparameterized type. -- | An unparameterized type.
t :: String -> Type t :: String -> Type
t n = T n [] t n = T n []


-- | Compiles a CIRC spec. -- | Compiles a CIRC spec.
circ :: Spec -> IO () circ :: Spec -> IO ()
circ (Spec initModuleName initImports rootTypeName types transforms) = do circ (Spec initModuleName initImports rootTypeName typeDefsUnsorted transforms) = do
maybeWriteFile (initModuleName ++ ".hs") $ codeModule' initModuleName types Nothing maybeWriteFile (initModuleName ++ ".hs") $ codeTypeModule initModuleName initImports typeDefs
foldM_ codeTransform (initModuleName, types) transforms maybeWriteFile (initModuleName ++ "Trans.hs") $ codeInitTransModule initModuleName rootTypeName
foldM_ codeTransform (initModuleName, typeDefs) transforms
where where
codeModule' = codeModule initModuleName initImports rootTypeName typeDefs = sortTypeDefs typeDefsUnsorted

codeTransform :: (Name, [TypeDef]) -> Transform -> IO (Name, [TypeDef]) codeTransform :: (Name, [TypeDef]) -> Transform -> IO (Name, [TypeDef])
codeTransform (prevName, prevTypes) (Transform currName localImports ctorName code typeMods) = do codeTransform (prevModuleName, prevTypeDefs) (Transform moduleName typeImports transImports ctorName transCode typeRefinements) = do
maybeWriteFile (currName ++ ".hs") $ codeModule' currName currTypes $ Just (prevName, localImports, prevTypes, ctorName, code prevName, [ (ctor, code prevName)| NewCtor _ (CtorDef ctor _) code <- typeMods ]) maybeWriteFile (moduleName ++ ".hs") $ codeTypeModule moduleName typeImports typeDefs
return (currName, currTypes) maybeWriteFile (moduleName ++ "Trans.hs") $ codeTransModule
initModuleName
rootTypeName
prevModuleName
prevTypeDefs
moduleName
transImports
typeDefs
ctorName
(transCode prevModuleName)
[ (ctorName, transCode prevModuleName) | NewCtor _ (CtorDef ctorName _) transCode <- typeRefinements ]
return (moduleName, typeDefs)
where where
filteredCtor = [ TypeDef name params [ CtorDef ctorName' args | CtorDef ctorName' args <- ctors, ctorName /= ctorName' ] | TypeDef name params ctors <- prevTypes ] filteredCtor = [ TypeDef name params [ CtorDef ctorName' args | CtorDef ctorName' args <- ctors, ctorName /= ctorName' ] | TypeDef name params ctors <- prevTypeDefs ]
currTypes = filterRelevantTypes rootTypeName $ nextTypes filteredCtor typeMods typeDefs = sortTypeDefs $ filterRelevantTypes rootTypeName $ nextTypes filteredCtor typeRefinements


maybeWriteFile :: FilePath -> String -> IO () -- | Write out a file if the file doesn't exist or is different. Doesn't bump the timestamp for Makefile-like build systems.
maybeWriteFile file contents = do maybeWriteFile :: FilePath -> String -> IO ()
a <- doesFileExist file maybeWriteFile file contents = do
if not a then writeFile file contents else do a <- doesFileExist file
f <- openFile file ReadMode if not a then writeFile file contents else do
contents' <- hGetContents f f <- openFile file ReadMode
if contents' == contents contents' <- hGetContents f
then do if contents' == contents
hClose f then do
return () hClose f
else do return ()
hClose f else do
writeFile file contents hClose f
writeFile file contents


-- | Sort a list of TypeDefs by type name.
sortTypeDefs :: [TypeDef] -> [TypeDef] sortTypeDefs :: [TypeDef] -> [TypeDef]
sortTypeDefs = sortBy (compare `on` \ (TypeDef n _ _) -> n) sortTypeDefs = sortBy (compare `on` \ (TypeDef n _ _) -> n)


codeModule :: ModuleName -> [String] -> TypeName -> ModuleName -> [TypeDef] -> Maybe (ModuleName, [Import], [TypeDef], CtorName, Code, [(CtorName, Code)]) -> String -- | Code the module that contains the IR datatype definitions.
codeModule initModuleName initImports rootTypeName moduleName unsortedTypes trans = unlines $ codeTypeModule :: ModuleName -> [Import] -> [TypeDef] -> String
codeTypeModule moduleName imports typeDefs = unlines $
[ printf "module %s" moduleName [ printf "module %s" moduleName
, " ( " ++ intercalate "\n , " [ name ++ " (..)"| TypeDef name _ _ <- currTypes ] , " ( " ++ intercalate "\n , " [ name ++ " (..)"| TypeDef name _ _ <- typeDefs ]
, " , transform"
, " , transform'"
, " ) where" , " ) where"
, "" , ""
, "import Language.CIRC.Runtime" ] ++ nub (["import Language.CIRC.Runtime"] ++ imports) ++ [""] ++ map codeTypeDef typeDefs
] ++ nub (case trans of { Nothing -> initImports; Just (m, i, _, _, _, _) -> ["import qualified " ++ initModuleName, "import qualified " ++ m] ++ i}) ++
[ ""
] ++ (map codeTypeDef currTypes) ++
case trans of
Nothing ->
[ printf "transform :: %s -> CIRC (%s, [%s])" rootTypeName rootTypeName rootTypeName
, "transform a = return (a, [a])"
, ""
, printf "transform' :: %s -> CIRC %s" rootTypeName rootTypeName
, "transform' = return"
, ""
]
Just (prevName, _, prevTypes, ctor, code, backwards) ->
[ printf "transform :: %s.%s -> CIRC (%s, [%s.%s])" initModuleName rootTypeName rootTypeName initModuleName rootTypeName
, printf "transform a = do"
, printf " (a, b) <- %s.transform a" prevName
, printf " a <- trans%s a" rootTypeName
, printf " c <- transform' a"
, printf " return (a, b ++ [c])"
, printf ""
, printf "transform' :: %s -> CIRC %s.%s" rootTypeName initModuleName rootTypeName
, printf "transform' a = trans%s' a >>= %s.transform'" rootTypeName prevName
, printf ""
, codeTypeTransforms prevName prevTypes currTypes (ctor, code) backwards
]
where
currTypes = sortTypeDefs unsortedTypes

codeTypeDef :: TypeDef -> String
codeTypeDef (TypeDef name params ctors) = "data " ++ name ++ " " ++ intercalate " " params ++ "\n = " ++
intercalate "\n | " [ name ++ replicate (m - length name) ' ' ++ " " ++ intercalate " " (map codeType args) | CtorDef name args <- ctors' ] ++ "\n"
where where
ctors' = sortBy (compare `on` \ (CtorDef n _) -> n) ctors codeTypeDef :: TypeDef -> String
m = maximum [ length n | CtorDef n _ <- ctors ] codeTypeDef (TypeDef name params ctors) = "data " ++ name ++ " " ++ intercalate " " params ++ "\n = " ++
intercalate "\n | " [ name ++ replicate (m - length name) ' ' ++ " " ++ intercalate " " (map codeType args) | CtorDef name args <- ctors' ] ++ "\n"
where
ctors' = sortBy (compare `on` \ (CtorDef n _) -> n) ctors
m = maximum [ length n | CtorDef n _ <- ctors ]

codeType :: Type -> String
codeType a = case a of
T name [] -> name
T name params -> "(" ++ name ++ intercalate " " (map codeType params) ++ ")"
TList a -> "[" ++ codeType a ++ "]"
TMaybe a -> "(Maybe " ++ codeType a ++ ")"
TTuple a -> "(" ++ intercalate ", " (map codeType a) ++ ")"


codeType :: Type -> String -- | Code the initial transform module.
codeType a = case a of codeInitTransModule :: ModuleName -> TypeName -> String
T name [] -> name codeInitTransModule moduleName rootTypeName = unlines
T name params -> "(" ++ name ++ intercalate " " (map codeType params) ++ ")" [ printf "module %sTrans" moduleName
TList a -> "[" ++ codeType a ++ "]" , printf " ( transform"
TMaybe a -> "(Maybe " ++ codeType a ++ ")" , printf " , transform'"
TTuple a -> "(" ++ intercalate ", " (map codeType a) ++ ")" , printf " ) where"
, printf ""
, printf "import Language.CIRC.Runtime (CIRC)"
, printf "import %s (%s)" moduleName rootTypeName
, printf ""
, printf "transform :: %s -> CIRC (%s, [%s])" rootTypeName rootTypeName rootTypeName
, printf "transform a = return (a, [a])"
, printf ""
, printf "transform' :: %s -> CIRC %s" rootTypeName rootTypeName
, printf "transform' = return"
, printf ""
]


-- | Computes the next type definitions given a list of type definitions and a list of type refinements. -- | Code the module that contains the IR transformations.
nextTypes :: [TypeDef] -> [TypeRefinement] -> [TypeDef] codeTransModule :: ModuleName -> TypeName -> ModuleName -> [TypeDef] -> ModuleName -> [Import] -> [TypeDef] -> CtorName -> Code -> [(CtorName, Code)] -> String
nextTypes old new = sortTypeDefs $ foldl nextType old new codeTransModule initModuleName rootTypeName prevModuleName prevTypeDefs moduleName imports typeDefs ctorName transCode backwardTransCode = unlines $
where [ printf "module %sTrans" moduleName
nextType :: [TypeDef] -> TypeRefinement -> [TypeDef] , " ( transform"
nextType types refinement = case refinement of , " , transform'"
NewType t -> t : types , " ) where"
NewCtor typeName ctorDef _ -> case match of , ""
[] -> error $ "Type not found: " ++ typeName ] ++ nub (
_ : _ : _ -> error $ "Redundent type name: " ++ typeName [ "import Language.CIRC.Runtime"
[TypeDef _ params ctors] -> TypeDef typeName params (ctorDef : ctors) : rest , "import qualified " ++ initModuleName
where , "import qualified " ++ prevModuleName
(match, rest) = partition (\ (TypeDef name _ _) -> name == typeName) types , "import qualified " ++ prevModuleName ++ "Trans"
, "import " ++ moduleName
] ++ imports) ++
[ printf "transform :: %s.%s -> CIRC (%s, [%s.%s])" initModuleName rootTypeName rootTypeName initModuleName rootTypeName
, printf "transform a = do"
, printf " (a, b) <- %sTrans.transform a" prevModuleName
, printf " a <- trans%s a" rootTypeName
, printf " c <- transform' a"
, printf " return (a, b ++ [c])"
, printf ""
, printf "transform' :: %s -> CIRC %s.%s" rootTypeName initModuleName rootTypeName
, printf "transform' a = trans%s' a >>= %sTrans.transform'" rootTypeName prevModuleName
, printf ""
, codeTypeTransforms prevModuleName prevTypeDefs typeDefs (ctorName, transCode) backwardTransCode
, printf ""
]


-- | Codes the type transform function.
codeTypeTransforms :: ModuleName -> [TypeDef] -> [TypeDef] -> (CtorName, Code) -> [(CtorName, Code)] -> String codeTypeTransforms :: ModuleName -> [TypeDef] -> [TypeDef] -> (CtorName, Code) -> [(CtorName, Code)] -> String
codeTypeTransforms prevName prevTypes currTypes forwardTrans backwardTrans = codeTypeTransforms prevName prevTypes currTypes forwardTrans backwardTrans =
concatMap (codeTypeTransform prevTypes [forwardTrans] (\ t -> "trans" ++ t) qualified id) [ t | t@(TypeDef n _ _) <- prevTypes, elem n $ map typeDefName currTypes ] ++ concatMap (codeTypeTransform prevTypes [forwardTrans] (\ t -> "trans" ++ t) qualified id) [ t | t@(TypeDef n _ _) <- prevTypes, elem n $ map typeDefName currTypes ] ++
Expand Down Expand Up @@ -208,6 +230,20 @@ primitiveTypes a = case a of
indent :: String -> String indent :: String -> String
indent = unlines . map (" " ++) . lines indent = unlines . map (" " ++) . lines


-- | Computes the next type definitions given a list of type definitions and a list of type refinements.
nextTypes :: [TypeDef] -> [TypeRefinement] -> [TypeDef]
nextTypes old new = foldl nextType old new
where
nextType :: [TypeDef] -> TypeRefinement -> [TypeDef]
nextType types refinement = case refinement of
NewType t -> t : types
NewCtor typeName ctorDef _ -> case match of
[] -> error $ "Type not found: " ++ typeName
_ : _ : _ -> error $ "Redundent type name: " ++ typeName
[TypeDef _ params ctors] -> TypeDef typeName params (ctorDef : ctors) : rest
where
(match, rest) = partition (\ (TypeDef name _ _) -> name == typeName) types

-- | Get rid of types that are not relevant to the root type. -- | Get rid of types that are not relevant to the root type.
filterRelevantTypes :: TypeName -> [TypeDef] -> [TypeDef] filterRelevantTypes :: TypeName -> [TypeDef] -> [TypeDef]
filterRelevantTypes rootTypeName types = [ t | t@(TypeDef n _ _) <- types, elem n required ] filterRelevantTypes rootTypeName types = [ t | t@(TypeDef n _ _) <- types, elem n required ]
Expand Down

0 comments on commit e10b394

Please sign in to comment.