Commit 60f13520 authored by Finn Teegen's avatar Finn Teegen
Browse files

Rename Annotated FlatCurry generator and option

parent 8585aac7
......@@ -146,7 +146,7 @@ library
, Generators.GenAbstractCurry
, Generators.GenFlatCurry
, Generators.GenTypedFlatCurry
, Generators.GenTypeAnnotatedFlatCurry
, Generators.GenAnnotatedFlatCurry
, Html.CurryHtml
, Html.SyntaxColoring
, IL
......
......@@ -197,8 +197,8 @@ data TargetType
| Comments -- ^ Source code comments
| Parsed -- ^ Parsed source code
| FlatCurry -- ^ FlatCurry
| AnnotatedFlatCurry -- ^ Annotated FlatCurry
| TypedFlatCurry -- ^ Typed FlatCurry
| TypeAnnotatedFlatCurry -- ^ Type-annotated FlatCurry
| AbstractCurry -- ^ AbstractCurry
| UntypedAbstractCurry -- ^ Untyped AbstractCurry
| Html -- ^ HTML documentation
......@@ -462,7 +462,7 @@ options =
"generate FlatCurry code"
, targetOption TypedFlatCurry "typed-flat"
"generate typed FlatCurry code"
, targetOption TypeAnnotatedFlatCurry "type-annotated-flat"
, targetOption AnnotatedFlatCurry "type-annotated-flat"
"generate type-annotated FlatCurry code"
, targetOption AbstractCurry "acy"
"generate typed AbstractCurry"
......
......@@ -29,7 +29,7 @@ module Curry.Files.Filenames
, curryExt, lcurryExt, icurryExt
-- ** FlatCurry files
, typedFlatExt, flatExt, flatIntExt
, annotatedFlatExt, typedFlatExt, flatExt, flatIntExt
-- ** AbstractCurry files
, acyExt, uacyExt
......@@ -38,7 +38,7 @@ module Curry.Files.Filenames
, sourceRepExt, sourceExts, moduleExts
-- * Functions for computing file names
, interfName, typedFlatName, typeAnnFlatName, flatName, flatIntName
, interfName, typedFlatName, annotatedFlatName, flatName, flatIntName
, acyName, uacyName, sourceRepName, tokensName, commentsName
, astName, shortASTName, htmlName
) where
......@@ -156,8 +156,8 @@ typedFlatExt :: String
typedFlatExt = ".tfcy"
-- |Filename extension for type-annotated flat-curry files
typeAnnFlatExt :: String
typeAnnFlatExt = ".tafcy"
annotatedFlatExt :: String
annotatedFlatExt = ".tafcy"
-- |Filename extension for flat-curry files
flatExt :: String
......@@ -208,8 +208,8 @@ typedFlatName :: FilePath -> FilePath
typedFlatName = replaceExtensionWith typedFlatExt
-- |Compute the filename of the typed flat curry file for a source file
typeAnnFlatName :: FilePath -> FilePath
typeAnnFlatName = replaceExtensionWith typeAnnFlatExt
annotatedFlatName :: FilePath -> FilePath
annotatedFlatName = replaceExtensionWith annotatedFlatExt
-- |Compute the filename of the flat curry file for a source file
flatName :: FilePath -> FilePath
......
......@@ -171,7 +171,7 @@ process opts idx m fn deps
, (Parsed , tgtDir . sourceRepName )
, (FlatCurry , tgtDir . flatName )
, (TypedFlatCurry , tgtDir . typedFlatName )
, (TypeAnnotatedFlatCurry, tgtDir . typeAnnFlatName)
, (AnnotatedFlatCurry , tgtDir . annotatedFlatName)
, (AbstractCurry , tgtDir . acyName )
, (UntypedAbstractCurry, tgtDir . uacyName )
, (AST , tgtDir . astName )
......
......@@ -20,18 +20,18 @@ import qualified Curry.FlatCurry.Annotated.Type as AFC (AProg)
import qualified Curry.FlatCurry.Typed.Type as TFC (TProg)
import qualified Curry.Syntax as CS (Module)
import qualified Generators.GenAbstractCurry as GAC (genAbstractCurry)
import qualified Generators.GenFlatCurry as GFC ( genFlatCurry
, genFlatInterface
)
import qualified Generators.GenTypeAnnotatedFlatCurry
as GTAFC (genTypeAnnotatedFlatCurry)
import qualified Generators.GenTypedFlatCurry as GTFC (genTypedFlatCurry)
import qualified Generators.GenAbstractCurry as GAC (genAbstractCurry)
import qualified Generators.GenFlatCurry as GFC ( genFlatCurry
, genFlatInterface
)
import qualified Generators.GenAnnotatedFlatCurry
as GAFC (genAnnotatedFlatCurry)
import qualified Generators.GenTypedFlatCurry as GTFC (genTypedFlatCurry)
import Base.Types (Type, PredType)
import Base.Types (Type, PredType)
import CompilerEnv (CompilerEnv (..))
import qualified IL (Module)
import CompilerEnv (CompilerEnv (..))
import qualified IL (Module)
-- |Generate typed AbstractCurry
genTypedAbstractCurry :: CompilerEnv -> CS.Module PredType -> AC.CurryProg
......@@ -46,9 +46,9 @@ genTypedFlatCurry :: AFC.AProg FC.TypeExpr -> TFC.TProg
genTypedFlatCurry = GTFC.genTypedFlatCurry
-- |Generate type-annotated FlatCurry
genTypeAnnotatedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module
-> AFC.AProg FC.TypeExpr
genTypeAnnotatedFlatCurry = GTAFC.genTypeAnnotatedFlatCurry
genAnnotatedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module
-> AFC.AProg FC.TypeExpr
genAnnotatedFlatCurry = GAFC.genAnnotatedFlatCurry
-- |Generate FlatCurry
genFlatCurry :: AFC.AProg FC.TypeExpr -> FC.Prog
......
......@@ -13,7 +13,7 @@
program term for a given module in the intermediate language.
-}
{-# LANGUAGE CPP #-}
module Generators.GenTypeAnnotatedFlatCurry (genTypeAnnotatedFlatCurry) where
module Generators.GenAnnotatedFlatCurry (genAnnotatedFlatCurry) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>), (<*>))
......@@ -29,31 +29,24 @@ import qualified Data.Map as Map (Map, empty, insert, lookup)
import qualified Data.Set as Set (Set, empty, insert, member)
import Curry.Base.Ident
import Curry.Base.SpanInfo
import Curry.FlatCurry.Annotated.Goodies (typeName)
import Curry.FlatCurry.Annotated.Type
import qualified Curry.Syntax as CS
import Base.CurryTypes (toType)
import qualified Base.Kinds as K
import Base.Messages (internalError)
import Base.NestEnv ( NestEnv, emptyEnv, bindNestEnv, lookupNestEnv
, nestEnv, unnestEnv )
import Base.TypeExpansion
import Base.Types
import CompilerEnv
import Env.OpPrec (mkPrec)
import Env.TypeConstructor (TCEnv, tcKind)
import Env.TypeConstructor (TCEnv)
import qualified IL
import Transformations (transType)
-- TODO: Translate from TypedFlatCurry
-- transforms intermediate language code (IL) to type-annotated FlatCurry code
genTypeAnnotatedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module
genAnnotatedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module
-> AProg TypeExpr
genTypeAnnotatedFlatCurry env mdl il = patchPrelude $ run env mdl (trModule il)
genAnnotatedFlatCurry env mdl il = patchPrelude $ run env mdl (trModule il)
-- -----------------------------------------------------------------------------
-- Addition of primitive types for lists and tuples to the Prelude
......@@ -108,7 +101,6 @@ data FlatEnv = FlatEnv
, tyExports :: Set.Set Ident -- exported types
, valExports :: Set.Set Ident -- exported values (functions + constructors)
, tcEnv :: TCEnv -- type constructor environment
, fixities :: [CS.IDecl] -- fixity declarations
, typeSynonyms :: [CS.Decl Type] -- type synonyms
, imports :: [ModuleIdent] -- module imports
-- state for mapping identifiers to indexes
......@@ -131,10 +123,6 @@ run env (CS.Module _ _ _ mid es is ds) act = S.evalState act env0
, imports = nub [ m | CS.ImportDecl _ m _ _ _ <- is ]
-- Environment to retrieve the type of identifiers
, tcEnv = tyConsEnv env
-- Fixity declarations
, fixities = [ CS.IInfixDecl (spanInfo2Pos p) fix (mkPrec mPrec) (qualifyWith mid o)
| CS.InfixDecl p fix mPrec os <- ds, o <- os
]
-- Type synonyms in the module
, typeSynonyms = [ d | d@CS.TypeDecl{} <- ds ]
, nextVar = 0
......@@ -158,13 +146,6 @@ buildValueExports _ _ = id
getModuleIdent :: FlatState ModuleIdent
getModuleIdent = S.gets modIdent
getFixities :: FlatState [CS.IDecl]
getFixities = S.gets fixities
-- The function 'typeSynonyms' returns the list of type synonyms.
getTypeSynonyms :: FlatState [CS.Decl Type]
getTypeSynonyms = S.gets typeSynonyms
-- Retrieve imports
getImports :: [ModuleIdent] -> FlatState [String]
getImports imps = (nub . map moduleName . (imps ++)) <$> S.gets imports
......@@ -199,16 +180,6 @@ getVarIndex i = S.gets varMap >>= \ varEnv -> case lookupNestEnv i varEnv of
[v] -> return v
_ -> internalError $ "GenTypeAnnotatedFlatCurry.getVarIndex: " ++ escName i
-- -----------------------------------------------------------------------------
-- Translation of an interface
-- -----------------------------------------------------------------------------
-- Translate an operator declaration
trIOpDecl :: CS.IDecl -> FlatState [OpDecl]
trIOpDecl (CS.IInfixDecl _ fix prec op)
= (\op' -> [Op op' (cvFixity fix) prec]) <$> trQualIdent op
trIOpDecl _ = return []
-- -----------------------------------------------------------------------------
-- Translation of a module
-- -----------------------------------------------------------------------------
......@@ -216,29 +187,9 @@ trIOpDecl _ = return []
trModule :: IL.Module -> FlatState (AProg TypeExpr)
trModule (IL.Module mid is ds) = do
is' <- getImports is
sns <- getTypeSynonyms >>= concatMapM trTypeSynonym
tds <- concatMapM trTypeDecl ds
fds <- concatMapM (return . map runNormalization <=< trAFuncDecl) ds
ops <- getFixities >>= concatMapM trIOpDecl
return $ AProg (moduleName mid) is' (sns ++ tds) fds ops
-- Translate a type synonym
trTypeSynonym :: CS.Decl a -> FlatState [TypeDecl]
trTypeSynonym (CS.TypeDecl _ t tvs ty) = do
m <- getModuleIdent
qid <- flip qualifyWith t <$> getModuleIdent
t' <- trQualIdent qid
vis <- getTypeVisibility qid
tEnv <- S.gets tcEnv
ty' <- trType (transType tEnv $
expandType m tEnv $
toType tvs ty)
let ks = map trInternalKind $ K.kindArgs $ tcKind m qid tEnv
return [TypeSyn t' vis (zip [0..] ks) ty']
where trInternalKind :: K.Kind -> Kind
trInternalKind (K.KindArrow k1 k2) = KArrow (trInternalKind k1) (trInternalKind k2)
trInternalKind _ = KStar
trTypeSynonym _ = return []
return $ AProg (moduleName mid) is' tds fds []
-- Translate a data declaration
-- For empty data declarations, an additional constructor is generated. This
......@@ -306,12 +257,6 @@ trKind IL.KindStar = KStar
trKind (IL.KindVariable _) = KStar
trKind (IL.KindArrow k1 k2) = KArrow (trKind k1) (trKind k2)
-- Convert a fixity
cvFixity :: CS.Infix -> Fixity
cvFixity CS.InfixL = InfixlOp
cvFixity CS.InfixR = InfixrOp
cvFixity CS.Infix = InfixOp
-- -----------------------------------------------------------------------------
-- Function declarations
-- -----------------------------------------------------------------------------
......@@ -328,7 +273,7 @@ trAFuncDecl (IL.ExternalDecl f a ty) = do
f' <- trQualIdent f
vis <- getVisibility f
ty' <- trType ty
r' <- trAExternal ty f
r' <- trAExternal ty f --TODO: get arity from type?
return [AFunc f' a vis ty' r']
trAFuncDecl _ = return []
......
......@@ -346,24 +346,24 @@ matchInterface ifn i = do
writeFlat :: Options -> CompilerEnv -> CS.Module Type -> IL.Module -> CYIO ()
writeFlat opts env mdl il = do
(_, tafc) <- dumpWith opts show (pPrint . genFlatCurry) DumpTypedFlatCurry (env, tafcyProg)
when tafcyTarget $ liftIO $ FC.writeFlatCurry (useSubDir tafcyName) tafc
(_, afcy) <- dumpWith opts show (pPrint . genFlatCurry) DumpTypedFlatCurry (env, afcyProg)
when afcyTarget $ liftIO $ FC.writeFlatCurry (useSubDir afcyName) afcy
when tfcyTarget $ liftIO $ FC.writeFlatCurry (useSubDir tfcyName) tfcyProg
when fcyTarget $ do
(_, fc) <- dumpWith opts show pPrint DumpFlatCurry (env, fcyProg)
liftIO $ FC.writeFlatCurry (useSubDir fcyName) fc
(_, fcy) <- dumpWith opts show pPrint DumpFlatCurry (env, fcyProg)
liftIO $ FC.writeFlatCurry (useSubDir fcyName) fcy
writeFlatIntf opts env fcyProg
where
tafcyName = typeAnnFlatName (filePath env)
tafcyProg = genTypeAnnotatedFlatCurry env mdl il
tafcyTarget = TypeAnnotatedFlatCurry `elem` optTargetTypes opts
tfcyName = typedFlatName (filePath env)
tfcyProg = genTypedFlatCurry tafcyProg
tfcyTarget = TypedFlatCurry `elem` optTargetTypes opts
fcyName = flatName (filePath env)
fcyProg = genFlatCurry tafcyProg
fcyTarget = FlatCurry `elem` optTargetTypes opts
useSubDir = addOutDirModule (optUseOutDir opts) (optOutDir opts) (moduleIdent env)
afcyName = annotatedFlatName (filePath env)
afcyProg = genAnnotatedFlatCurry env mdl il
afcyTarget = AnnotatedFlatCurry `elem` optTargetTypes opts
tfcyName = typedFlatName (filePath env)
tfcyProg = genTypedFlatCurry afcyProg
tfcyTarget = TypedFlatCurry `elem` optTargetTypes opts
fcyName = flatName (filePath env)
fcyProg = genFlatCurry afcyProg
fcyTarget = FlatCurry `elem` optTargetTypes opts
useSubDir = addOutDirModule (optUseOutDir opts) (optOutDir opts) (moduleIdent env)
writeFlatIntf :: Options -> CompilerEnv -> FC.Prog -> CYIO ()
writeFlatIntf opts env prog
......
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