Commit 79782290 authored by Kai-Oliver Prott's avatar Kai-Oliver Prott Committed by Finn Teegen
Browse files

Change TypedFlatCurry while keeping the old one as TypeAnnotatedFlat...

parent 242037ad
...@@ -108,6 +108,7 @@ Library ...@@ -108,6 +108,7 @@ Library
, Generators.GenAbstractCurry , Generators.GenAbstractCurry
, Generators.GenFlatCurry , Generators.GenFlatCurry
, Generators.GenTypedFlatCurry , Generators.GenTypedFlatCurry
, Generators.GenTypeAnnotatedFlatCurry
, Html.CurryHtml , Html.CurryHtml
, Html.SyntaxColoring , Html.SyntaxColoring
, IL , IL
......
...@@ -174,13 +174,14 @@ verbosities = [ ( VerbQuiet , "0", "quiet" ) ...@@ -174,13 +174,14 @@ verbosities = [ ( VerbQuiet , "0", "quiet" )
-- |Type of the target file -- |Type of the target file
data TargetType data TargetType
= Tokens -- ^ Source code tokens = Tokens -- ^ Source code tokens
| Parsed -- ^ Parsed source code | Parsed -- ^ Parsed source code
| FlatCurry -- ^ FlatCurry | FlatCurry -- ^ FlatCurry
| TypedFlatCurry -- ^ Typed FlatCurry | TypedFlatCurry -- ^ Typed FlatCurry
| AbstractCurry -- ^ AbstractCurry | TypeAnnotatedFlatCurry -- ^ Type-annotated FlatCurry
| UntypedAbstractCurry -- ^ Untyped AbstractCurry | AbstractCurry -- ^ AbstractCurry
| Html -- ^ HTML documentation | UntypedAbstractCurry -- ^ Untyped AbstractCurry
| Html -- ^ HTML documentation
deriving (Eq, Show) deriving (Eq, Show)
-- |Warnings flags -- |Warnings flags
...@@ -421,19 +422,21 @@ options = ...@@ -421,19 +422,21 @@ options =
addFlag WarnOverlapping (wnWarnFlags opts) })) addFlag WarnOverlapping (wnWarnFlags opts) }))
"do not print warnings for overlapping rules" "do not print warnings for overlapping rules"
-- target types -- target types
, targetOption Tokens "tokens" , targetOption Tokens "tokens"
"generate token stream" "generate token stream"
, targetOption Parsed "parse-only" , targetOption Parsed "parse-only"
"generate source representation" "generate source representation"
, targetOption FlatCurry "flat" , targetOption FlatCurry "flat"
"generate FlatCurry code" "generate FlatCurry code"
, targetOption TypedFlatCurry "typed-flat" , targetOption TypedFlatCurry "typed-flat"
"generate typed FlatCurry code" "generate typed FlatCurry code"
, targetOption AbstractCurry "acy" , targetOption TypeAnnotatedFlatCurry "typed-flat"
"generate type-annotated FlatCurry code"
, targetOption AbstractCurry "acy"
"generate typed AbstractCurry" "generate typed AbstractCurry"
, targetOption UntypedAbstractCurry "uacy" , targetOption UntypedAbstractCurry "uacy"
"generate untyped AbstractCurry" "generate untyped AbstractCurry"
, targetOption Html "html" , targetOption Html "html"
"generate html documentation" "generate html documentation"
, Option "F" [] , Option "F" []
(NoArg (onPrepOpts $ \ opts -> opts { ppPreprocess = True })) (NoArg (onPrepOpts $ \ opts -> opts { ppPreprocess = True }))
......
...@@ -165,13 +165,14 @@ process opts idx m fn deps ...@@ -165,13 +165,14 @@ process opts idx m fn deps
destFiles = [ gen fn | (t, gen) <- nameGens, t `elem` optTargetTypes opts] destFiles = [ gen fn | (t, gen) <- nameGens, t `elem` optTargetTypes opts]
nameGens = nameGens =
[ (Tokens , tgtDir . tokensName ) [ (Tokens , tgtDir . tokensName )
, (Parsed , tgtDir . sourceRepName) , (Parsed , tgtDir . sourceRepName )
, (FlatCurry , tgtDir . flatName ) , (FlatCurry , tgtDir . flatName )
, (TypedFlatCurry , tgtDir . typedFlatName) , (TypedFlatCurry , tgtDir . typedFlatName )
, (AbstractCurry , tgtDir . acyName ) , (TypeAnnotatedFlatCurry, tgtDir . typeAnnFlatName)
, (UntypedAbstractCurry, tgtDir . uacyName ) , (AbstractCurry , tgtDir . acyName )
, (Html , const (fromMaybe "." (optHtmlDir opts) </> htmlName m)) , (UntypedAbstractCurry , tgtDir . uacyName )
, (Html , const (fromMaybe "." (optHtmlDir opts) </> htmlName m))
] ]
-- |Create a status message like -- |Create a status message like
......
...@@ -13,16 +13,19 @@ ...@@ -13,16 +13,19 @@
-} -}
module Generators where module Generators where
import qualified Curry.AbstractCurry as AC (CurryProg) import qualified Curry.AbstractCurry as AC (CurryProg)
import qualified Curry.FlatCurry.Type as FC (Prog) import qualified Curry.FlatCurry.Type as FC (Prog, TypeExpr)
import qualified Curry.FlatCurry.Annotated.Type as AFC (AProg, TypeExpr) import qualified Curry.FlatCurry.Annotated.Type as AFC (AProg)
import qualified Curry.Syntax as CS (Module) 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 import qualified Generators.GenAbstractCurry as GAC (genAbstractCurry)
, genFlatInterface import qualified Generators.GenFlatCurry as GFC ( genFlatCurry
) , genFlatInterface
import qualified Generators.GenTypedFlatCurry as GTFC (genTypedFlatCurry) )
import qualified Generators.GenTypeAnnotatedFlatCurry
as GTAFC (genTypeAnnotatedFlatCurry)
import qualified Generators.GenTypedFlatCurry as GTFC (genTypedFlatCurry)
import Base.Types (Type, PredType) import Base.Types (Type, PredType)
...@@ -39,11 +42,16 @@ genUntypedAbstractCurry = GAC.genAbstractCurry True ...@@ -39,11 +42,16 @@ genUntypedAbstractCurry = GAC.genAbstractCurry True
-- |Generate typed FlatCurry -- |Generate typed FlatCurry
genTypedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module genTypedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module
-> AFC.AProg AFC.TypeExpr -> TFC.TProg
genTypedFlatCurry = GTFC.genTypedFlatCurry genTypedFlatCurry = GTFC.genTypedFlatCurry
-- |Generate type-annotated FlatCurry
genTypeAnnotatedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module
-> AFC.AProg FC.TypeExpr
genTypeAnnotatedFlatCurry = GTAFC.genTypeAnnotatedFlatCurry
-- |Generate FlatCurry -- |Generate FlatCurry
genFlatCurry :: AFC.AProg a -> FC.Prog genFlatCurry :: TFC.TProg -> FC.Prog
genFlatCurry = GFC.genFlatCurry genFlatCurry = GFC.genFlatCurry
-- |Generate a FlatCurry interface -- |Generate a FlatCurry interface
......
...@@ -15,39 +15,39 @@ module Generators.GenFlatCurry (genFlatCurry, genFlatInterface) where ...@@ -15,39 +15,39 @@ module Generators.GenFlatCurry (genFlatCurry, genFlatInterface) where
import Curry.FlatCurry.Goodies import Curry.FlatCurry.Goodies
import Curry.FlatCurry.Type import Curry.FlatCurry.Type
import Curry.FlatCurry.Annotated.Goodies import Curry.FlatCurry.Typed.Goodies
import Curry.FlatCurry.Annotated.Type import Curry.FlatCurry.Typed.Type
-- transforms annotated FlatCurry code to FlatCurry code -- transforms annotated FlatCurry code to FlatCurry code
genFlatCurry :: AProg a -> Prog genFlatCurry :: TProg -> Prog
genFlatCurry = trAProg genFlatCurry = trTProg
(\name imps types funcs ops -> (\name imps types funcs ops ->
Prog name imps types (map genFlatFuncDecl funcs) ops) Prog name imps types (map genFlatFuncDecl funcs) ops)
genFlatFuncDecl :: AFuncDecl a -> FuncDecl genFlatFuncDecl :: TFuncDecl -> FuncDecl
genFlatFuncDecl = trAFunc genFlatFuncDecl = trTFunc
(\name arity vis ty rule -> Func name arity vis ty $ genFlatRule rule) (\name arity vis ty rule -> Func name arity vis ty $ genFlatRule rule)
genFlatRule :: ARule a -> Rule genFlatRule :: TRule -> Rule
genFlatRule = trARule genFlatRule = trTRule
(\_ args e -> Rule (map fst args) $ genFlatExpr e) (\args e -> Rule (map fst args) $ genFlatExpr e)
(const External) (const External)
genFlatExpr :: AExpr a -> Expr genFlatExpr :: TExpr -> Expr
genFlatExpr = trAExpr genFlatExpr = trTExpr
(const Var) (const Var)
(const Lit) (const Lit)
(\_ ct name args -> Comb ct (fst name) args) (\ct name args -> Comb ct (fst name) args)
(\_ bs e -> Let (map (\(v, e') -> (fst v, e')) bs) e) (\bs e -> Let (map (\(v, e') -> (fst v, e')) bs) e)
(\_ vs e -> Free (map fst vs) e) (\vs e -> Free (map fst vs) e)
(\_ e1 e2 -> Or e1 e2) Or
(\_ ct e bs -> Case ct e bs) Case
(\pat e -> Branch (genFlatPattern pat) e) (\pat e -> Branch (genFlatPattern pat) e)
(\_ e ty -> Typed e ty) Typed
genFlatPattern :: APattern a -> Pattern genFlatPattern :: TPattern -> Pattern
genFlatPattern = trAPattern genFlatPattern = trTPattern
(\_ name args -> Pattern (fst name) $ map fst args) (\name args -> Pattern (fst name) $ map fst args)
(const LPattern) (const LPattern)
-- transforms a FlatCurry module to a FlatCurry interface -- transforms a FlatCurry module to a FlatCurry interface
......
This diff is collapsed.
...@@ -28,9 +28,8 @@ import qualified Data.Map as Map (Map, empty, insert, lookup) ...@@ -28,9 +28,8 @@ import qualified Data.Map as Map (Map, empty, insert, lookup)
import qualified Data.Set as Set (Set, empty, insert, member) import qualified Data.Set as Set (Set, empty, insert, member)
import Curry.Base.Ident import Curry.Base.Ident
import Curry.FlatCurry.Annotated.Goodies (typeName) import Curry.FlatCurry.Typed.Goodies (typeName)
import Curry.FlatCurry.Annotated.Type import Curry.FlatCurry.Typed.Type
import Curry.FlatCurry.Annotated.Typing
import qualified Curry.Syntax as CS import qualified Curry.Syntax as CS
import Base.CurryTypes (toType) import Base.CurryTypes (toType)
...@@ -45,21 +44,21 @@ import Env.OpPrec (mkPrec) ...@@ -45,21 +44,21 @@ import Env.OpPrec (mkPrec)
import Env.TypeConstructor (TCEnv) import Env.TypeConstructor (TCEnv)
import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue) import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)
import qualified IL as IL import qualified IL
import Transformations (transType) import Transformations (transType)
-- transforms intermediate language code (IL) to typed FlatCurry code -- transforms intermediate language code (IL) to typed FlatCurry code
genTypedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module genTypedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module
-> AProg TypeExpr -> TProg
genTypedFlatCurry env mdl il = patchPrelude $ run env mdl (trModule il) genTypedFlatCurry env mdl il = patchPrelude $ run env mdl (trModule il)
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- Addition of primitive types for lists and tuples to the Prelude -- Addition of primitive types for lists and tuples to the Prelude
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
patchPrelude :: AProg a -> AProg a patchPrelude :: TProg -> TProg
patchPrelude p@(AProg n _ ts fs os) patchPrelude p@(TProg n _ ts fs os)
| n == prelude = AProg n [] ts' fs os | n == prelude = TProg n [] ts' fs os
| otherwise = p | otherwise = p
where ts' = sortBy (compare `on` typeName) pts where ts' = sortBy (compare `on` typeName) pts
pts = primTypes ++ ts pts = primTypes ++ ts
...@@ -222,14 +221,14 @@ trIOpDecl _ = return [] ...@@ -222,14 +221,14 @@ trIOpDecl _ = return []
-- Translation of a module -- Translation of a module
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
trModule :: IL.Module -> FlatState (AProg TypeExpr) trModule :: IL.Module -> FlatState TProg
trModule (IL.Module mid is ds) = do trModule (IL.Module mid is ds) = do
is' <- getImports is is' <- getImports is
sns <- getTypeSynonyms >>= concatMapM trTypeSynonym sns <- getTypeSynonyms >>= concatMapM trTypeSynonym
tds <- concatMapM trTypeDecl ds tds <- concatMapM trTypeDecl ds
fds <- concatMapM (return . map runNormalization <=< trAFuncDecl) ds fds <- concatMapM (return . map runNormalization <=< trTFuncDecl) ds
ops <- getFixities >>= concatMapM trIOpDecl ops <- getFixities >>= concatMapM trIOpDecl
return $ AProg (moduleName mid) is' (sns ++ tds) fds ops return $ TProg (moduleName mid) is' (sns ++ tds) fds ops
-- Translate a type synonym -- Translate a type synonym
trTypeSynonym :: CS.Decl a -> FlatState [TypeDecl] trTypeSynonym :: CS.Decl a -> FlatState [TypeDecl]
...@@ -291,64 +290,60 @@ cvFixity CS.Infix = InfixOp ...@@ -291,64 +290,60 @@ cvFixity CS.Infix = InfixOp
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- Translate a function declaration -- Translate a function declaration
trAFuncDecl :: IL.Decl -> FlatState [AFuncDecl TypeExpr] trTFuncDecl :: IL.Decl -> FlatState [TFuncDecl]
trAFuncDecl (IL.FunctionDecl f vs _ e) = do trTFuncDecl (IL.FunctionDecl f vs _ e) = do
f' <- trQualIdent f f' <- trQualIdent f
a <- getArity f a <- getArity f
vis <- getVisibility f vis <- getVisibility f
ty' <- trType ty ty' <- trType ty
r' <- trARule ty vs e r' <- trTRule vs e
return [AFunc f' a vis ty' r'] return [TFunc f' a vis ty' r']
where ty = foldr IL.TypeArrow (IL.typeOf e) $ map fst vs where ty = foldr IL.TypeArrow (IL.typeOf e) $ map fst vs
trAFuncDecl (IL.ExternalDecl f ty) = do trTFuncDecl (IL.ExternalDecl f ty) = do
f' <- trQualIdent f f' <- trQualIdent f
a <- getArity f a <- getArity f
vis <- getVisibility f vis <- getVisibility f
ty' <- trType ty ty' <- trType ty
r' <- trAExternal ty f r' <- trTExternal ty f
return [AFunc f' a vis ty' r'] return [TFunc f' a vis ty' r']
trAFuncDecl _ = return [] trTFuncDecl _ = return []
-- Translate a function rule. -- Translate a function rule.
-- Resets variable index so that for every rule variables start with index 1 -- Resets variable index so that for every rule variables start with index 1
trARule :: IL.Type -> [(IL.Type, Ident)] -> IL.Expression trTRule :: [(IL.Type, Ident)] -> IL.Expression
-> FlatState (ARule TypeExpr) -> FlatState TRule
trARule ty vs e = withFreshEnv $ ARule <$> trType ty trTRule vs e = withFreshEnv $ TRule <$> mapM (uncurry newVar) vs
<*> mapM (uncurry newVar) vs <*> trTExpr e
<*> trAExpr e
trAExternal :: IL.Type -> QualIdent -> FlatState (ARule TypeExpr) trTExternal :: IL.Type -> QualIdent -> FlatState TRule
trAExternal ty f = flip AExternal (qualName f) <$> trType ty trTExternal ty f = flip TExternal (qualName f) <$> trType ty
-- Translate an expression -- Translate an expression
trAExpr :: IL.Expression -> FlatState (AExpr TypeExpr) trTExpr :: IL.Expression -> FlatState TExpr
trAExpr (IL.Literal ty l) = ALit <$> trType ty <*> trLiteral l trTExpr (IL.Literal ty l) = TLit <$> trType ty <*> trLiteral l
trAExpr (IL.Variable ty v) = AVar <$> trType ty <*> getVarIndex v trTExpr (IL.Variable ty v) = TVarE <$> trType ty <*> getVarIndex v
trAExpr (IL.Function ty f _) = genCall Fun ty f [] trTExpr (IL.Function ty f _) = genCall Fun ty f []
trAExpr (IL.Constructor ty c _) = genCall Con ty c [] trTExpr (IL.Constructor ty c _) = genCall Con ty c []
trAExpr (IL.Apply e1 e2) = trApply e1 e2 trTExpr (IL.Apply e1 e2) = trApply e1 e2
trAExpr c@(IL.Case t e bs) = flip ACase (cvEval t) <$> trType (IL.typeOf c) <*> trAExpr e trTExpr (IL.Case t e bs) = TCase (cvEval t) <$> trTExpr e
<*> mapM (inNestedEnv . trAlt) bs <*> mapM (inNestedEnv . trAlt) bs
trAExpr (IL.Or e1 e2) = AOr <$> trType (IL.typeOf e1) <*> trAExpr e1 <*> trAExpr e2 trTExpr (IL.Or e1 e2) = TOr <$> trTExpr e1 <*> trTExpr e2
trAExpr (IL.Exist v ty e) = inNestedEnv $ do trTExpr (IL.Exist v ty e) = inNestedEnv $ do
v' <- newVar ty v v' <- newVar ty v
e' <- trAExpr e e' <- trTExpr e
ty' <- trType (IL.typeOf e) return $ case e' of TFree vs e'' -> TFree (v' : vs) e''
return $ case e' of AFree ty'' vs e'' -> AFree ty'' (v' : vs) e'' _ -> TFree (v' : []) e'
_ -> AFree ty' (v' : []) e' trTExpr (IL.Let (IL.Binding v b) e) = inNestedEnv $ do
trAExpr (IL.Let (IL.Binding v b) e) = inNestedEnv $ do
v' <- newVar (IL.typeOf b) v v' <- newVar (IL.typeOf b) v
b' <- trAExpr b b' <- trTExpr b
e' <- trAExpr e e' <- trTExpr e
ty' <- trType $ IL.typeOf e return $ case e' of TLet bs e'' -> TLet ((v', b'):bs) e''
return $ case e' of ALet ty'' bs e'' -> ALet ty'' ((v', b'):bs) e'' _ -> TLet ((v', b'):[]) e'
_ -> ALet ty' ((v', b'):[]) e' trTExpr (IL.Letrec bs e) = inNestedEnv $ do
trAExpr (IL.Letrec bs e) = inNestedEnv $ do
let (vs, es) = unzip [ ((IL.typeOf b, v), b) | IL.Binding v b <- bs] let (vs, es) = unzip [ ((IL.typeOf b, v), b) | IL.Binding v b <- bs]
ALet <$> trType (IL.typeOf e) TLet <$> (zip <$> mapM (uncurry newVar) vs <*> mapM trTExpr es)
<*> (zip <$> mapM (uncurry newVar) vs <*> mapM trAExpr es) <*> trTExpr e
<*> trAExpr e trTExpr (IL.Typed e _) = TTyped <$> trTExpr e <*> ty'
trAExpr (IL.Typed e _) = ATyped <$> ty' <*> trAExpr e <*> ty'
where ty' = trType $ IL.typeOf e where ty' = trType $ IL.typeOf e
-- Translate a literal -- Translate a literal
...@@ -358,7 +353,7 @@ trLiteral (IL.Int i) = return $ Intc i ...@@ -358,7 +353,7 @@ trLiteral (IL.Int i) = return $ Intc i
trLiteral (IL.Float f) = return $ Floatc f trLiteral (IL.Float f) = return $ Floatc f
-- Translate a higher-order application -- Translate a higher-order application
trApply :: IL.Expression -> IL.Expression -> FlatState (AExpr TypeExpr) trApply :: IL.Expression -> IL.Expression -> FlatState TExpr
trApply e1 e2 = genFlatApplic e1 [e2] trApply e1 e2 = genFlatApplic e1 [e2]
where where
genFlatApplic e es = case e of genFlatApplic e es = case e of
...@@ -366,19 +361,19 @@ trApply e1 e2 = genFlatApplic e1 [e2] ...@@ -366,19 +361,19 @@ trApply e1 e2 = genFlatApplic e1 [e2]
IL.Function ty f _ -> genCall Fun ty f es IL.Function ty f _ -> genCall Fun ty f es
IL.Constructor ty c _ -> genCall Con ty c es IL.Constructor ty c _ -> genCall Con ty c es
_ -> do _ -> do
expr <- trAExpr e expr <- trTExpr e
genApply expr es genApply expr es
-- Translate an alternative -- Translate an alternative
trAlt :: IL.Alt -> FlatState (ABranchExpr TypeExpr) trAlt :: IL.Alt -> FlatState TBranchExpr
trAlt (IL.Alt p e) = ABranch <$> trPat p <*> trAExpr e trAlt (IL.Alt p e) = TBranch <$> trPat p <*> trTExpr e
-- Translate a pattern -- Translate a pattern
trPat :: IL.ConstrTerm -> FlatState (APattern TypeExpr) trPat :: IL.ConstrTerm -> FlatState TPattern
trPat (IL.LiteralPattern ty l) = ALPattern <$> trType ty <*> trLiteral l trPat (IL.LiteralPattern ty l) = TLPattern <$> trType ty <*> trLiteral l
trPat (IL.ConstructorPattern ty c vs) = do trPat (IL.ConstructorPattern ty c vs) = do
qty <- trType $ foldr IL.TypeArrow ty $ map fst vs qty <- trType $ foldr (IL.TypeArrow . fst) ty vs
APattern <$> trType ty <*> ((\q -> (q, qty)) <$> trQualIdent c) <*> mapM (uncurry newVar) vs TPattern <$> ((\q -> (q, qty)) <$> trQualIdent c) <*> mapM (uncurry newVar) vs
trPat (IL.VariablePattern _ _) = internalError "GenTypedFlatCurry.trPat" trPat (IL.VariablePattern _ _) = internalError "GenTypedFlatCurry.trPat"
-- Convert a case type -- Convert a case type
...@@ -390,16 +385,16 @@ data Call = Fun | Con ...@@ -390,16 +385,16 @@ data Call = Fun | Con
-- Generate a function or constructor call -- Generate a function or constructor call
genCall :: Call -> IL.Type -> QualIdent -> [IL.Expression] genCall :: Call -> IL.Type -> QualIdent -> [IL.Expression]
-> FlatState (AExpr TypeExpr) -> FlatState TExpr
genCall call ty f es = do genCall call ty f es = do
f' <- trQualIdent f f' <- trQualIdent f
arity <- getArity f arity <- getArity f
case compare supplied arity of case compare supplied arity of
LT -> genAComb ty f' es (part call (arity - supplied)) LT -> genTComb ty f' es (part call (arity - supplied))
EQ -> genAComb ty f' es (full call) EQ -> genTComb ty f' es (full call)
GT -> do GT -> do
let (es1, es2) = splitAt arity es let (es1, es2) = splitAt arity es
funccall <- genAComb ty f' es1 (full call) funccall <- genTComb ty f' es1 (full call)
genApply funccall es2 genApply funccall es2
where where
supplied = length es supplied = length es
...@@ -408,21 +403,19 @@ genCall call ty f es = do ...@@ -408,21 +403,19 @@ genCall call ty f es = do
part Fun = FuncPartCall part Fun = FuncPartCall
part Con = ConsPartCall part Con = ConsPartCall
genAComb :: IL.Type -> QName -> [IL.Expression] -> CombType -> FlatState (AExpr TypeExpr) genTComb :: IL.Type -> QName -> [IL.Expression] -> CombType -> FlatState TExpr
genAComb ty qid es ct = do genTComb ty qid es ct = do
ty' <- trType ty ty' <- trType ty
let ty'' = defunc ty' (length es) TComb ct (qid, ty') <$> mapM trTExpr es
AComb ty'' ct (qid, ty') <$> mapM trAExpr es
where
defunc t 0 = t
defunc (FuncType _ t2) n = defunc t2 (n - 1)
defunc _ _ = internalError "GenTypedFlatCurry.genAComb.defunc"
genApply :: AExpr TypeExpr -> [IL.Expression] -> FlatState (AExpr TypeExpr) genApply :: TExpr -> [IL.Expression] -> FlatState TExpr
genApply e es = do genApply e es = do
ap <- trQualIdent $ qApplyId ap <- trQualIdent $ qApplyId
es' <- mapM trAExpr es es' <- mapM trTExpr es
return $ foldl (\e1 e2 -> let FuncType ty1 ty2 = typeOf e1 in AComb ty2 FuncCall (ap, FuncType (FuncType ty1 ty2) (FuncType ty1 ty2)) [e1, e2]) e es' return $ foldl (\e1 e2 -> let FuncType ty1 ty2 = typeOf e1
in TComb FuncCall (ap, FuncType (FuncType ty1 ty2)
(FuncType ty1 ty2)) [e1, e2])
e es'
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- Normalization -- Normalization
...@@ -453,43 +446,40 @@ instance Normalize TypeExpr where ...@@ -453,43 +446,40 @@ instance Normalize TypeExpr where
ForallType <$> mapM normalize is <*> normalize ty ForallType <$> mapM normalize is <*> normalize ty
instance Normalize b => Normalize (a, b) where instance Normalize b => Normalize (a, b) where
normalize (x, y) = ((,) x) <$> normalize y normalize (x, y) = (,) x <$> normalize y
instance Normalize a => Normalize (AFuncDecl a) where instance Normalize TFuncDecl where
normalize (AFunc f a v ty r) = AFunc f a v <$> normalize ty <*> normalize r normalize (TFunc f a v ty r) = TFunc f a v <$> normalize ty <*> normalize r
instance Normalize a => Normalize (ARule a) where instance Normalize TRule where
normalize (ARule ty vs e) = ARule <$> normalize ty normalize (TRule vs e) = TRule <$> mapM normalize vs
<*> mapM normalize vs
<*> normalize e <*> normalize e
normalize (AExternal ty s) = flip AExternal s <$> normalize ty normalize (TExternal ty s) = flip TExternal s <$> normalize ty
instance Normalize a => Normalize (AExpr a) where instance Normalize TExpr where
normalize (AVar ty v) = flip AVar v <$> normalize ty normalize (TVarE ty v) = flip TVarE v <$> normalize ty
normalize (ALit ty l) = flip ALit l <$> normalize ty normalize (TLit ty l) = flip TLit l <$> normalize ty
normalize (AComb ty ct f es) = flip AComb ct <$> normalize ty normalize (TComb ct f es) = TComb ct <$> normalize f
<*> normalize f <*> mapM normalize es
<*> mapM normalize es normalize (TLet ds e) = TLet <$> mapM normalizeBinding ds
normalize (ALet ty ds e) = ALet <$> normalize ty
<*> mapM normalizeBinding ds
<*> normalize e