Commit a3b68d83 authored by Kai-Oliver Prott's avatar Kai-Oliver Prott

Merge branch 'master' into SpanInfo

parents be6795a3 c5719bed
......@@ -108,6 +108,7 @@ Library
, Generators.GenAbstractCurry
, Generators.GenFlatCurry
, Generators.GenTypedFlatCurry
, Generators.GenTypeAnnotatedFlatCurry
, Html.CurryHtml
, Html.SyntaxColoring
, IL
......
......@@ -50,7 +50,7 @@ ok = return ()
-- The extension check iterates over all given pragmas in the module and
-- gathers all extensions mentioned in a language pragma. An error is reported
-- if an extension is unkown.
-- if an extension is unknown.
checkModule :: Module a -> EXCM ()
checkModule (Module _ ps _ _ _ _) = mapM_ checkPragma ps
......
......@@ -77,9 +77,9 @@ import Env.Value (ValueEnv, ValueInfo (..))
syntaxCheck :: [KnownExtension] -> TCEnv -> ValueEnv -> Module ()
-> ((Module (), [KnownExtension]), [Message])
syntaxCheck exts tcEnv vEnv mdl@(Module _ _ m _ _ ds) =
case findMultiples $ concatMap constrs tds of
[] -> case findMultiples (ls ++ fs ++ cs) of
syntaxCheck exts tcEnv vEnv mdl@(Module _ m _ _ ds) =
case findMultiples cons of
[] -> case findMultiples (ls ++ fs ++ cons ++ cs) of
[] -> runSC (checkModule mdl) state
iss -> ((mdl, exts), map (errMultipleDeclarations m) iss)
css -> ((mdl, exts), map errMultipleDataConstructor css)
......@@ -87,6 +87,7 @@ syntaxCheck exts tcEnv vEnv mdl@(Module _ _ m _ _ ds) =
tds = filter isTypeDecl ds
vds = filter isValueDecl ds
cds = filter isClassDecl ds
cons = concatMap constrs tds
ls = nub $ concatMap recLabels tds
fs = nub $ concatMap vars vds
cs = concatMap (concatMap methods) [ds' | ClassDecl _ _ _ _ ds' <- cds]
......@@ -574,13 +575,8 @@ checkEquationsLhs p [Equation p' lhs rhs] = do
lhs' <- checkEqLhs p' lhs
case lhs' of
Left l -> return $ funDecl' l
Right r -> patDecl' r >>= checkDeclLhs
Right r -> checkDeclLhs (PatternDecl p' r rhs)
where funDecl' (f, lhs') = FunctionDecl p () f [Equation p' lhs' rhs]
patDecl' t = do
k <- getScopeId
when (k == globalScopeId) $ report
$ errToplevelPattern (spanInfo2Pos p)
return $ PatternDecl p' t rhs
checkEquationsLhs _ _ = internalError "SyntaxCheck.checkEquationsLhs"
checkEqLhs :: SpanInfo -> Lhs () -> SCM (Either (Ident, Lhs ()) (Pattern ()))
......
......@@ -5,9 +5,10 @@
2007 Sebastian Fischer
2011 - 2016 Björn Peemöller
2016 - 2017 Finn Teegen
2018 Kai-Oliver Prott
License : BSD-3-clause
Maintainer : bjp@informatik.uni-kiel.de
Maintainer : fte@informatik.uni-kiel.de
Stability : experimental
Portability : portable
......@@ -179,9 +180,10 @@ data TargetType
| Parsed -- ^ Parsed source code
| FlatCurry -- ^ FlatCurry
| TypedFlatCurry -- ^ Typed FlatCurry
| AbstractCurry -- ^ AbstractCurry
| UntypedAbstractCurry -- ^ Untyped AbstractCurry
| Html -- ^ HTML documentation
| TypeAnnotatedFlatCurry -- ^ Type-annotated FlatCurry
| AbstractCurry -- ^ AbstractCurry
| UntypedAbstractCurry -- ^ Untyped AbstractCurry
| Html -- ^ HTML documentation
| AST -- ^ Abstract-Syntax-Tree after checks
| ShortAST -- ^ Abstract-Syntax-Tree with shortened decls
deriving (Eq, Show)
......@@ -424,25 +426,27 @@ options =
addFlag WarnOverlapping (wnWarnFlags opts) }))
"do not print warnings for overlapping rules"
-- target types
, targetOption Tokens "tokens"
, targetOption Tokens "tokens"
"generate token stream"
, targetOption Comments "comments"
, targetOption Comments "comments"
"generate comments stream"
, targetOption Parsed "parse-only"
, targetOption Parsed "parse-only"
"generate source representation"
, targetOption FlatCurry "flat"
, targetOption FlatCurry "flat"
"generate FlatCurry code"
, targetOption TypedFlatCurry "typed-flat"
, targetOption TypedFlatCurry "typed-flat"
"generate typed FlatCurry code"
, targetOption AbstractCurry "acy"
, targetOption TypeAnnotatedFlatCurry "type-annotated-flat"
"generate type-annotated FlatCurry code"
, targetOption AbstractCurry "acy"
"generate typed AbstractCurry"
, targetOption UntypedAbstractCurry "uacy"
, targetOption UntypedAbstractCurry "uacy"
"generate untyped AbstractCurry"
, targetOption Html "html"
, targetOption Html "html"
"generate html documentation"
, targetOption AST "ast"
, targetOption AST "ast"
"generate abstract syntax tree"
, targetOption ShortAST "short-ast"
, targetOption ShortAST "short-ast"
"generate shortened abstract syntax tree for documentation"
, Option "F" []
(NoArg (onPrepOpts $ \ opts -> opts { ppPreprocess = True }))
......
......@@ -4,9 +4,10 @@
Copyright : (c) 2005 Martin Engelke
2007 Sebastian Fischer
2011 - 2015 Björn Peemöller
2018 Kai-Oliver Prott
License : BSD-3-clause
Maintainer : bjp@informatik.uni-kiel.de
Maintainer : fte@informatik.uni-kiel.de
Stability : experimental
Portability : portable
......@@ -171,6 +172,7 @@ process opts idx m fn deps
, (Parsed , tgtDir . sourceRepName )
, (FlatCurry , tgtDir . flatName )
, (TypedFlatCurry , tgtDir . typedFlatName )
, (TypeAnnotatedFlatCurry, tgtDir . typeAnnFlatName)
, (AbstractCurry , tgtDir . acyName )
, (UntypedAbstractCurry, tgtDir . uacyName )
, (AST , tgtDir . astName )
......
......@@ -3,9 +3,10 @@
Description : Code generators
Copyright : (c) 2011 Björn Peemöller
2017 Finn Teegen
2018 Kai-Oliver Prott
License : BSD-3-clause
Maintainer : bjp@informatik.uni-kiel.de
Maintainer : fte@informatik.uni-kiel.de
Stability : experimental
Portability : portable
......@@ -13,16 +14,19 @@
-}
module Generators where
import qualified Curry.AbstractCurry as AC (CurryProg)
import qualified Curry.FlatCurry.Type as FC (Prog)
import qualified Curry.FlatCurry.Annotated.Type as AFC (AProg, TypeExpr)
import qualified Curry.Syntax as CS (Module)
import qualified Curry.AbstractCurry as AC (CurryProg)
import qualified Curry.FlatCurry.Type as FC (Prog, TypeExpr)
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.GenTypedFlatCurry as GTFC (genTypedFlatCurry)
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 Base.Types (Type, PredType)
......@@ -39,11 +43,16 @@ genUntypedAbstractCurry = GAC.genAbstractCurry True
-- |Generate typed FlatCurry
genTypedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module
-> AFC.AProg AFC.TypeExpr
-> TFC.TProg
genTypedFlatCurry = GTFC.genTypedFlatCurry
-- |Generate type-annotated FlatCurry
genTypeAnnotatedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module
-> AFC.AProg FC.TypeExpr
genTypeAnnotatedFlatCurry = GTAFC.genTypeAnnotatedFlatCurry
-- |Generate FlatCurry
genFlatCurry :: AFC.AProg a -> FC.Prog
genFlatCurry :: TFC.TProg -> FC.Prog
genFlatCurry = GFC.genFlatCurry
-- |Generate a FlatCurry interface
......
......@@ -15,39 +15,39 @@ module Generators.GenFlatCurry (genFlatCurry, genFlatInterface) where
import Curry.FlatCurry.Goodies
import Curry.FlatCurry.Type
import Curry.FlatCurry.Annotated.Goodies
import Curry.FlatCurry.Annotated.Type
import Curry.FlatCurry.Typed.Goodies
import Curry.FlatCurry.Typed.Type
-- transforms annotated FlatCurry code to FlatCurry code
genFlatCurry :: AProg a -> Prog
genFlatCurry = trAProg
genFlatCurry :: TProg -> Prog
genFlatCurry = trTProg
(\name imps types funcs ops ->
Prog name imps types (map genFlatFuncDecl funcs) ops)
genFlatFuncDecl :: AFuncDecl a -> FuncDecl
genFlatFuncDecl = trAFunc
genFlatFuncDecl :: TFuncDecl -> FuncDecl
genFlatFuncDecl = trTFunc
(\name arity vis ty rule -> Func name arity vis ty $ genFlatRule rule)
genFlatRule :: ARule a -> Rule
genFlatRule = trARule
(\_ args e -> Rule (map fst args) $ genFlatExpr e)
genFlatRule :: TRule -> Rule
genFlatRule = trTRule
(\args e -> Rule (map fst args) $ genFlatExpr e)
(const External)
genFlatExpr :: AExpr a -> Expr
genFlatExpr = trAExpr
genFlatExpr :: TExpr -> Expr
genFlatExpr = trTExpr
(const Var)
(const Lit)
(\_ ct name args -> Comb ct (fst name) args)
(\_ bs e -> Let (map (\(v, e') -> (fst v, e')) bs) e)
(\_ vs e -> Free (map fst vs) e)
(\_ e1 e2 -> Or e1 e2)
(\_ ct e bs -> Case ct e bs)
(\_ ct name args -> Comb ct name args)
(\bs e -> Let (map (\(v, e') -> (fst v, e')) bs) e)
(\vs e -> Free (map fst vs) e)
Or
Case
(\pat e -> Branch (genFlatPattern pat) e)
(\_ e ty -> Typed e ty)
Typed
genFlatPattern :: APattern a -> Pattern
genFlatPattern = trAPattern
(\_ name args -> Pattern (fst name) $ map fst args)
genFlatPattern :: TPattern -> Pattern
genFlatPattern = trTPattern
(\_ name args -> Pattern name $ map fst args)
(const LPattern)
-- transforms a FlatCurry module to a FlatCurry interface
......
This diff is collapsed.
......@@ -2,9 +2,10 @@
Module : $Header$
Description : Generation of typed FlatCurry program terms
Copyright : (c) 2017 Finn Teegen
2018 Kai-Oliver Prott
License : BSD-3-clause
Maintainer : bjp@informatik.uni-kiel.de
Maintainer : fte@informatik.uni-kiel.de
Stability : experimental
Portability : portable
......@@ -29,9 +30,8 @@ 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 Curry.FlatCurry.Annotated.Typing
import Curry.FlatCurry.Typed.Goodies (typeName)
import Curry.FlatCurry.Typed.Type
import qualified Curry.Syntax as CS
import Base.CurryTypes (toType)
......@@ -46,21 +46,21 @@ import Env.OpPrec (mkPrec)
import Env.TypeConstructor (TCEnv)
import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)
import qualified IL as IL
import qualified IL
import Transformations (transType)
-- transforms intermediate language code (IL) to typed FlatCurry code
genTypedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module
-> AProg TypeExpr
-> TProg
genTypedFlatCurry env mdl il = patchPrelude $ run env mdl (trModule il)
-- -----------------------------------------------------------------------------
-- Addition of primitive types for lists and tuples to the Prelude
-- -----------------------------------------------------------------------------
patchPrelude :: AProg a -> AProg a
patchPrelude p@(AProg n _ ts fs os)
| n == prelude = AProg n [] ts' fs os
patchPrelude :: TProg -> TProg
patchPrelude p@(TProg n _ ts fs os)
| n == prelude = TProg n [] ts' fs os
| otherwise = p
where ts' = sortBy (compare `on` typeName) pts
pts = primTypes ++ ts
......@@ -223,14 +223,14 @@ trIOpDecl _ = return []
-- Translation of a module
-- -----------------------------------------------------------------------------
trModule :: IL.Module -> FlatState (AProg TypeExpr)
trModule :: IL.Module -> FlatState TProg
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
fds <- concatMapM (return . map runNormalization <=< trTFuncDecl) ds
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
trTypeSynonym :: CS.Decl a -> FlatState [TypeDecl]
......@@ -292,64 +292,60 @@ cvFixity CS.Infix = InfixOp
-- -----------------------------------------------------------------------------
-- Translate a function declaration
trAFuncDecl :: IL.Decl -> FlatState [AFuncDecl TypeExpr]
trAFuncDecl (IL.FunctionDecl f vs _ e) = do
trTFuncDecl :: IL.Decl -> FlatState [TFuncDecl]
trTFuncDecl (IL.FunctionDecl f vs _ e) = do
f' <- trQualIdent f
a <- getArity f
vis <- getVisibility f
ty' <- trType ty
r' <- trARule ty vs e
return [AFunc f' a vis ty' r']
r' <- trTRule vs e
return [TFunc f' a vis ty' r']
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
a <- getArity f
vis <- getVisibility f
ty' <- trType ty
r' <- trAExternal ty f
return [AFunc f' a vis ty' r']
trAFuncDecl _ = return []
r' <- trTExternal ty f
return [TFunc f' a vis ty' r']
trTFuncDecl _ = return []
-- Translate a function rule.
-- Resets variable index so that for every rule variables start with index 1
trARule :: IL.Type -> [(IL.Type, Ident)] -> IL.Expression
-> FlatState (ARule TypeExpr)
trARule ty vs e = withFreshEnv $ ARule <$> trType ty
<*> mapM (uncurry newVar) vs
<*> trAExpr e
trTRule :: [(IL.Type, Ident)] -> IL.Expression
-> FlatState TRule
trTRule vs e = withFreshEnv $ TRule <$> mapM (uncurry newVar) vs
<*> trTExpr e
trAExternal :: IL.Type -> QualIdent -> FlatState (ARule TypeExpr)
trAExternal ty f = flip AExternal (qualName f) <$> trType ty
trTExternal :: IL.Type -> QualIdent -> FlatState TRule
trTExternal ty f = flip TExternal (qualName f) <$> trType ty
-- Translate an expression
trAExpr :: IL.Expression -> FlatState (AExpr TypeExpr)
trAExpr (IL.Literal ty l) = ALit <$> trType ty <*> trLiteral l
trAExpr (IL.Variable ty v) = AVar <$> trType ty <*> getVarIndex v
trAExpr (IL.Function ty f _) = genCall Fun ty f []
trAExpr (IL.Constructor ty c _) = genCall Con ty c []
trAExpr (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.Expression -> FlatState TExpr
trTExpr (IL.Literal ty l) = TLit <$> trType ty <*> trLiteral l
trTExpr (IL.Variable ty v) = TVarE <$> trType ty <*> getVarIndex v
trTExpr (IL.Function ty f _) = genCall Fun ty f []
trTExpr (IL.Constructor ty c _) = genCall Con ty c []
trTExpr (IL.Apply e1 e2) = trApply e1 e2
trTExpr (IL.Case t e bs) = TCase (cvEval t) <$> trTExpr e
<*> mapM (inNestedEnv . trAlt) bs
trAExpr (IL.Or e1 e2) = AOr <$> trType (IL.typeOf e1) <*> trAExpr e1 <*> trAExpr e2
trAExpr (IL.Exist v ty e) = inNestedEnv $ do
trTExpr (IL.Or e1 e2) = TOr <$> trTExpr e1 <*> trTExpr e2
trTExpr (IL.Exist v ty e) = inNestedEnv $ do
v' <- newVar ty v
e' <- trAExpr e
ty' <- trType (IL.typeOf e)
return $ case e' of AFree ty'' vs e'' -> AFree ty'' (v' : vs) e''
_ -> AFree ty' (v' : []) e'
trAExpr (IL.Let (IL.Binding v b) e) = inNestedEnv $ do
e' <- trTExpr e
return $ case e' of TFree vs e'' -> TFree (v' : vs) e''
_ -> TFree (v' : []) e'
trTExpr (IL.Let (IL.Binding v b) e) = inNestedEnv $ do
v' <- newVar (IL.typeOf b) v
b' <- trAExpr b
e' <- trAExpr e
ty' <- trType $ IL.typeOf e
return $ case e' of ALet ty'' bs e'' -> ALet ty'' ((v', b'):bs) e''
_ -> ALet ty' ((v', b'):[]) e'
trAExpr (IL.Letrec bs e) = inNestedEnv $ do
b' <- trTExpr b
e' <- trTExpr e
return $ case e' of TLet bs e'' -> TLet ((v', b'):bs) e''
_ -> TLet ((v', b'):[]) e'
trTExpr (IL.Letrec bs e) = inNestedEnv $ do
let (vs, es) = unzip [ ((IL.typeOf b, v), b) | IL.Binding v b <- bs]
ALet <$> trType (IL.typeOf e)
<*> (zip <$> mapM (uncurry newVar) vs <*> mapM trAExpr es)
<*> trAExpr e
trAExpr (IL.Typed e _) = ATyped <$> ty' <*> trAExpr e <*> ty'
TLet <$> (zip <$> mapM (uncurry newVar) vs <*> mapM trTExpr es)
<*> trTExpr e
trTExpr (IL.Typed e _) = TTyped <$> trTExpr e <*> ty'
where ty' = trType $ IL.typeOf e
-- Translate a literal
......@@ -359,7 +355,7 @@ trLiteral (IL.Int i) = return $ Intc i
trLiteral (IL.Float f) = return $ Floatc f
-- 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]
where
genFlatApplic e es = case e of
......@@ -367,19 +363,18 @@ trApply e1 e2 = genFlatApplic e1 [e2]
IL.Function ty f _ -> genCall Fun ty f es
IL.Constructor ty c _ -> genCall Con ty c es
_ -> do
expr <- trAExpr e
expr <- trTExpr e
genApply expr es
-- Translate an alternative
trAlt :: IL.Alt -> FlatState (ABranchExpr TypeExpr)
trAlt (IL.Alt p e) = ABranch <$> trPat p <*> trAExpr e
trAlt :: IL.Alt -> FlatState TBranchExpr
trAlt (IL.Alt p e) = TBranch <$> trPat p <*> trTExpr e
-- Translate a pattern
trPat :: IL.ConstrTerm -> FlatState (APattern TypeExpr)
trPat (IL.LiteralPattern ty l) = ALPattern <$> trType ty <*> trLiteral l
trPat (IL.ConstructorPattern ty c vs) = do
qty <- trType $ foldr IL.TypeArrow ty $ map fst vs
APattern <$> trType ty <*> ((\q -> (q, qty)) <$> trQualIdent c) <*> mapM (uncurry newVar) vs
trPat :: IL.ConstrTerm -> FlatState TPattern
trPat (IL.LiteralPattern ty l) = TLPattern <$> trType ty <*> trLiteral l
trPat (IL.ConstructorPattern ty c vs) =
TPattern <$> trType ty <*> trQualIdent c <*> mapM (uncurry newVar) vs
trPat (IL.VariablePattern _ _) = internalError "GenTypedFlatCurry.trPat"
-- Convert a case type
......@@ -391,16 +386,16 @@ data Call = Fun | Con
-- Generate a function or constructor call
genCall :: Call -> IL.Type -> QualIdent -> [IL.Expression]
-> FlatState (AExpr TypeExpr)
-> FlatState TExpr
genCall call ty f es = do
f' <- trQualIdent f
arity <- getArity f
case compare supplied arity of
LT -> genAComb ty f' es (part call (arity - supplied))
EQ -> genAComb ty f' es (full call)
LT -> genTComb ty f' es (part call (arity - supplied))
EQ -> genTComb ty f' es (full call)
GT -> do
let (es1, es2) = splitAt arity es
funccall <- genAComb ty f' es1 (full call)
funccall <- genTComb ty f' es1 (full call)
genApply funccall es2
where
supplied = length es
......@@ -409,21 +404,23 @@ genCall call ty f es = do
part Fun = FuncPartCall
part Con = ConsPartCall
genAComb :: IL.Type -> QName -> [IL.Expression] -> CombType -> FlatState (AExpr TypeExpr)
genAComb ty qid es ct = do
genTComb :: IL.Type -> QName -> [IL.Expression] -> CombType -> FlatState TExpr
genTComb ty qid es ct = do
ty' <- trType ty
let ty'' = defunc ty' (length es)
AComb ty'' ct (qid, ty') <$> mapM trAExpr es
TComb ty'' ct qid <$> mapM trTExpr es
where
defunc t 0 = t
defunc (FuncType _ t2) n = defunc t2 (n - 1)
defunc _ _ = internalError "GenTypedFlatCurry.genAComb.defunc"
defunc _ _ = internalError "GenTypedFlatCurry.genTComb.defunc"
genApply :: AExpr TypeExpr -> [IL.Expression] -> FlatState (AExpr TypeExpr)
genApply :: TExpr -> [IL.Expression] -> FlatState TExpr
genApply e es = do
ap <- trQualIdent $ qApplyId
es' <- mapM trAExpr 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'
ap <- trQualIdent qApplyId
es' <- mapM trTExpr es
return $ foldl (\e1 e2 -> let FuncType _ ty2 = typeOf e1
in TComb ty2 FuncCall ap [e1, e2])
e es'
-- -----------------------------------------------------------------------------
-- Normalization
......@@ -454,43 +451,42 @@ instance Normalize TypeExpr where
ForallType <$> mapM normalize is <*> normalize ty
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
normalize (AFunc f a v ty r) = AFunc f a v <$> normalize ty <*> normalize r
instance Normalize TFuncDecl where
normalize (TFunc f a v ty r) = TFunc f a v <$> normalize ty <*> normalize r
instance Normalize a => Normalize (ARule a) where
normalize (ARule ty vs e) = ARule <$> normalize ty
<*> mapM normalize vs
instance Normalize TRule where
normalize (TRule vs e) = TRule <$> mapM normalize vs
<*> normalize e
normalize (AExternal ty s) = flip AExternal s <$> normalize ty
instance Normalize a => Normalize (AExpr a) where
normalize (AVar ty v) = flip AVar v <$> normalize ty
normalize (ALit ty l) = flip ALit l <$> normalize ty
normalize (AComb ty ct f es) = flip AComb ct <$> normalize ty
<*> normalize f
<*> mapM normalize es
normalize (ALet ty ds e) = ALet <$> normalize ty
<*> mapM normalizeBinding ds
normalize (TExternal ty s) = flip TExternal s <$> normalize ty
instance Normalize TExpr where
normalize (TVarE ty v) = flip TVarE v <$> normalize ty
normalize (TLit ty l) = flip TLit l <$> normalize ty
normalize (TComb ty ct f es) = flip TComb ct <$> normalize ty
<*> pure f
<*> mapM normalize es
normalize (TLet ds e) = TLet <$> mapM normalizeBinding ds
<*> normalize e
where normalizeBinding (v, b) = (,) <$> normalize v <*> normalize b
normalize (AOr ty a b) = AOr <$> normalize ty <*> normalize a
normalize (TOr a b) = TOr <$> normalize a
<*> normalize b
normalize (ACase ty ct e bs) = flip ACase ct <$> normalize ty <*> normalize e
<*> mapM normalize bs
normalize (AFree ty vs e) = AFree <$> normalize ty <*> mapM normalize vs
normalize (TCase ct e bs) = TCase ct <$> normalize e
<*> mapM normalize bs
normalize (TFree vs e) = TFree <$> mapM normalize vs
<*> normalize e
normalize (ATyped ty e ty') = ATyped <$> normalize ty <*> normalize e
normalize (TTyped e ty') = TTyped <$> normalize e
<*> normalize ty'
instance Normalize a => Normalize (ABranchExpr a) where
normalize (ABranch p e) = ABranch <$> normalize p <*> normalize e
instance Normalize TBranchExpr where
normalize (TBranch p e) = TBranch <$> normalize p <*> normalize e
instance Normalize a => Normalize (APattern a) where
normalize (APattern ty c vs) = APattern <$> normalize ty <*> normalize c
instance Normalize TPattern where
normalize (TPattern ty c vs) = TPattern <$> normalize ty
<*> pure c
<*> mapM normalize vs
normalize (ALPattern ty l) = flip ALPattern l <$> normalize ty
normalize (TLPattern ty l) = flip TLPattern l <$> normalize ty
-- -----------------------------------------------------------------------------
-- Helper functions
......
......@@ -7,9 +7,10 @@
2011 - 2015 Björn Peemöller
2016 Jan Tikovsky