Commit 143a07a3 authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

Refactoring of FlatCurry generation, fixes #607

parent 1af263e7
......@@ -95,7 +95,6 @@ Library
, Imports
, Interfaces
, Modules
, ModuleSummary
, TokenStream
, Transformations
, Transformations.CaseCompletion
......
......@@ -12,16 +12,15 @@
-}
module Generators where
import qualified Curry.AbstractCurry as AC (CurryProg)
import qualified Curry.ExtendedFlat.Type as EF (Prog)
import qualified Curry.Syntax as CS (Module)
import qualified Curry.AbstractCurry as AC (CurryProg)
import qualified Curry.ExtendedFlat.Type as EF (Prog)
import qualified Curry.Syntax as CS (Module, Interface)
import qualified Generators.GenAbstractCurry as GAC
import qualified Generators.GenFlatCurry as GFC
import qualified Generators.GenAbstractCurry as GAC (genAbstractCurry)
import qualified Generators.GenFlatCurry as GFC (genFlatCurry, genFlatInterface)
import CompilerEnv
import IL (Module)
import ModuleSummary
import CompilerEnv (CompilerEnv (..))
import qualified IL (Module)
-- |Generate typed AbstractCurry
genTypedAbstractCurry :: CompilerEnv -> CS.Module -> AC.CurryProg
......@@ -32,11 +31,9 @@ genUntypedAbstractCurry :: CompilerEnv -> CS.Module -> AC.CurryProg
genUntypedAbstractCurry = GAC.genAbstractCurry True
-- |Generate FlatCurry
genFlatCurry :: ModuleSummary -> CompilerEnv -> IL.Module -> EF.Prog
genFlatCurry ms env = GFC.genFlatCurry ms
(interfaceEnv env) (valueEnv env) (tyConsEnv env)
genFlatCurry :: CompilerEnv -> CS.Interface -> CS.Module -> IL.Module -> EF.Prog
genFlatCurry = GFC.genFlatCurry
-- |Generate a FlatCurry interface
genFlatInterface :: ModuleSummary -> CompilerEnv -> IL.Module -> EF.Prog
genFlatInterface ms env = GFC.genFlatInterface ms
(interfaceEnv env) (valueEnv env) (tyConsEnv env)
genFlatInterface :: CompilerEnv -> CS.Interface -> CS.Module -> IL.Module -> EF.Prog
genFlatInterface = GFC.genFlatInterface
This diff is collapsed.
{- |
Module : $Header$
Description : Summarized information of a module
Copyright : (c) 2005, Martin Engelke (men@informatik.uni-kiel.de)
2015, Jan Tikovsky
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
Stability : experimental
Portability : portable
Generates a record containing extracted and prepared data from a
'Curry.Syntax.Module'.
-}
module ModuleSummary (ModuleSummary (..), summarizeModule) where
import Data.Maybe (fromMaybe)
import Curry.Base.Ident
import Curry.Syntax
import Base.Messages (internalError)
import Base.Types
import Env.OpPrec (mkPrec)
import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC)
-- |A record containing data for a module 'm'
data ModuleSummary = ModuleSummary
{ moduleId :: ModuleIdent -- ^The name of 'm'
, interface :: [IDecl] -- ^all exported declarations in 'm'
-- (including exported imports)
, exports :: [Export] -- ^The export list extracted from 'm'
, imports :: [IImportDecl] -- ^imports
, infixDecls :: [IDecl] -- ^Interfaces of all infix declarations in 'm'
, typeSynonyms :: [IDecl] -- ^Interfaces of all type synonyms in 'm'
} deriving Show
-- |Return a 'ModuleSummary' for a module, its corresponding
-- table of type constructors and its interface
summarizeModule :: TCEnv -> Interface -> Module -> ModuleSummary
summarizeModule tcEnv (Interface iid _ idecls) (Module _ mid mExp imps decls)
| iid == mid = ModuleSummary
{ moduleId = mid
, interface = idecls
, exports = maybe [] (\ (Exporting _ exps) -> exps) mExp
, imports = genImports imps
, infixDecls = genInfixDecls mid decls
, typeSynonyms = genTypeSyns tcEnv mid decls
}
| otherwise = internalError $
"Interface " ++ show iid ++ " does not match module " ++ show mid
-- |Generate interface import declarations
genImports :: [ImportDecl] -> [IImportDecl]
genImports = map snd . foldr addImport []
where
addImport (ImportDecl pos mid _ _ _) imps = case lookup mid imps of
Nothing -> (mid, IImportDecl pos mid) : imps
Just _ -> imps
-- |Generate interface infix declarations in the module
genInfixDecls :: ModuleIdent -> [Decl] -> [IDecl]
genInfixDecls mident decls = concatMap genInfixDecl decls
where
genInfixDecl :: Decl -> [IDecl]
genInfixDecl (InfixDecl pos spec mPrec idents)
= map (IInfixDecl pos spec (mkPrec mPrec) . qualifyWith mident) idents
genInfixDecl _ = []
-- ---------------------------------------------------------------------------
-- |Generate interface declarations for all type synonyms in the module.
genTypeSyns :: TCEnv -> ModuleIdent -> [Decl] -> [IDecl]
genTypeSyns tcEnv mident decls
= concatMap (genTypeSynDecl mident tcEnv) $ filter isTypeSyn decls
isTypeSyn :: Decl -> Bool
isTypeSyn (TypeDecl _ _ _ _) = True
isTypeSyn _ = False
--
genTypeSynDecl :: ModuleIdent -> TCEnv -> Decl -> [IDecl]
genTypeSynDecl mid tcEnv (TypeDecl p i vs ty)
= [ITypeDecl p (qualifyWith mid i) vs (modifyTypeExpr tcEnv ty)]
genTypeSynDecl _ _ _ = []
--
modifyTypeExpr :: TCEnv -> TypeExpr -> TypeExpr
modifyTypeExpr tcEnv (ConstructorType q tys) = case qualLookupTC q tcEnv of
[AliasType _ ar ty] -> modifyTypeExpr tcEnv
(genTypeSynDeref (zip [0 .. ar - 1] tys) ty)
_ -> ConstructorType (fromMaybe q (lookupTCId q tcEnv))
(map (modifyTypeExpr tcEnv) tys)
modifyTypeExpr _ v@(VariableType _) = v
modifyTypeExpr tcEnv (ArrowType ty1 ty2)
= ArrowType (modifyTypeExpr tcEnv ty1) (modifyTypeExpr tcEnv ty2)
modifyTypeExpr tcEnv (TupleType tys)
| null tys = ConstructorType qUnitId []
| otherwise = ConstructorType (qTupleId $ length tys)
(map (modifyTypeExpr tcEnv) tys)
modifyTypeExpr tcEnv (ListType ty)
= ConstructorType (qualify listId) [modifyTypeExpr tcEnv ty]
modifyTypeExpr tcEnv (ParenType ty) = modifyTypeExpr tcEnv ty
--
genTypeSynDeref :: [(Int, TypeExpr)] -> Type -> TypeExpr
genTypeSynDeref its (TypeVariable i) = case lookup i its of
Nothing -> internalError "ModuleSummary.genTypeSynDeref: unkown type var index"
Just te -> te
genTypeSynDeref its (TypeConstructor qid tys)
= ConstructorType qid $ map (genTypeSynDeref its) tys
genTypeSynDeref its (TypeArrow ty1 ty2)
= ArrowType (genTypeSynDeref its ty1) (genTypeSynDeref its ty2)
genTypeSynDeref _ (TypeConstrained _ _) = internalError
"ModuleSummary.genTypeSynDeref: illegal constrained type occured"
genTypeSynDeref _ (TypeSkolem _) = internalError
"ModuleSummary.genTypeSynDeref: illegal skolem type occured"
--
lookupTCId :: QualIdent -> TCEnv -> Maybe QualIdent
lookupTCId qident tcEnv = case qualLookupTC qident tcEnv of
[DataType qid _ _] -> Just qid
[RenamingType qid _ _] -> Just qid
[AliasType qid _ _] -> Just qid
_ -> Nothing
......@@ -59,7 +59,6 @@ import Generators
import Html.CurryHtml (source2html)
import Imports
import Interfaces (loadInterfaces)
import ModuleSummary
import TokenStream (showTokenStream)
import Transformations
......@@ -93,9 +92,7 @@ compileModule opts m fn = do
writeInterface opts (fst mdl') intf
when withFlat $ do
(env2, il) <- transModule opts qmdl
-- generate target code
let modSum = summarizeModule (tyConsEnv env2) intf (snd qmdl)
writeFlat opts env2 modSum il
writeFlat opts env2 intf (snd qmdl) il
where
withFlat = any (`elem` optTargetTypes opts) [FlatCurry, ExtendedFlatCurry]
......@@ -305,18 +302,18 @@ matchInterface ifn i = do
Left _ -> hClose hdl >> return False
Right i' -> return (i `intfEquiv` fixInterface i')
writeFlat :: Options -> CompilerEnv -> ModuleSummary -> IL.Module -> CYIO ()
writeFlat opts env modSum il = do
writeFlat :: Options -> CompilerEnv -> CS.Interface -> CS.Module -> IL.Module -> CYIO ()
writeFlat opts env intf mdl il = do
when (extTarget || fcyTarget) $ do
writeFlatCurry opts env modSum il
writeFlatIntf opts env modSum il
writeFlatCurry opts env intf mdl il
writeFlatIntf opts env intf mdl il
where
extTarget = ExtendedFlatCurry `elem` optTargetTypes opts
fcyTarget = FlatCurry `elem` optTargetTypes opts
-- |Export an 'IL.Module' into a FlatCurry file
writeFlatCurry :: Options -> CompilerEnv -> ModuleSummary -> IL.Module -> CYIO ()
writeFlatCurry opts env modSum il = do
writeFlatCurry :: Options -> CompilerEnv -> CS.Interface -> CS.Module -> IL.Module -> CYIO ()
writeFlatCurry opts env intf mdl il = do
(_, fc) <- dumpWith opts show EF.ppProg DumpFlatCurry (env, prog)
when extTarget $ liftIO
$ EF.writeExtendedFlat (useSubDir $ extFlatName (filePath env)) fc
......@@ -326,23 +323,23 @@ writeFlatCurry opts env modSum il = do
extTarget = ExtendedFlatCurry `elem` optTargetTypes opts
fcyTarget = FlatCurry `elem` optTargetTypes opts
useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)
prog = genFlatCurry modSum env il
prog = genFlatCurry env intf mdl il
writeFlatIntf :: Options -> CompilerEnv -> ModuleSummary -> IL.Module -> CYIO ()
writeFlatIntf opts env modSum il
writeFlatIntf :: Options -> CompilerEnv -> CS.Interface -> CS.Module -> IL.Module -> CYIO ()
writeFlatIntf opts env intf mdl il
| not (optInterface opts) = return ()
| optForce opts = outputInterface
| otherwise = do
mfint <- liftIO $ EF.readFlatInterface targetFile
let oldInterface = fromMaybe emptyIntf mfint
when (mfint == mfint) $ return () -- necessary to close file -- TODO
unless (oldInterface `eqInterface` intf) $ outputInterface
unless (oldInterface `eqInterface` fint) $ outputInterface
where
targetFile = flatIntName (filePath env)
emptyIntf = EF.Prog "" [] [] [] []
intf = genFlatInterface modSum env il
fint = genFlatInterface env intf mdl il
useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)
outputInterface = liftIO $ EF.writeFlatCurry (useSubDir targetFile) intf
outputInterface = liftIO $ EF.writeFlatCurry (useSubDir targetFile) fint
writeAbstractCurry :: Options -> CompEnv CS.Module -> CYIO ()
writeAbstractCurry opts (env, mdl) = do
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment