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

Typed expressions in FlatCurry

parent 019e9cc6
......@@ -238,10 +238,8 @@ visitType (IL.TypeConstructor qid tys) = do
then head tys'
else TCons qn tys'
visitType (IL.TypeVariable idx) = return $ TVar $ abs idx
visitType (IL.TypeArrow ty1 ty2) = do
ty1' <- visitType ty1
ty2' <- visitType ty2
return $ FuncType ty1' ty2'
visitType (IL.TypeArrow ty1 ty2) = liftM2 FuncType
(visitType ty1) (visitType ty2)
--
visitFuncDecl :: IL.Decl -> FlatState FuncDecl
......@@ -319,6 +317,8 @@ visitExpression (IL.Letrec bds e) = inNewScope $ do
bds' <- mapM visitBinding bds
e' <- visitExpression e
return $ Let bds' e'
visitExpression (IL.Typed e ty) = liftM2 Typed (visitExpression e)
(visitType ty)
--
visitLiteral :: IL.Literal -> FlatState Literal
......
......@@ -141,6 +141,9 @@ Marlow's pretty printer for Haskell.
> [text "let" <+> ppBinding b <+> text "in",ppExpr 0 e]
> ppExpr p (Letrec bs e) = ppParen (p > 0) $ sep
> [text "letrec" <+> vcat (map ppBinding bs) <+> text "in", ppExpr 0 e]
> ppExpr p (Typed e ty) = ppParen (p > 0) $ sep
> [ppExpr 0 e, text "::", ppType 0 ty]
> ppInfixApp :: Int -> Expression -> QualIdent -> Expression -> Doc
> ppInfixApp p e1 op e2 = ppParen (p > 1) $ sep
......
......@@ -114,6 +114,8 @@ an unlimited range of integer constants in Curry programs.
> | Let Binding Expression
> -- |letrec binding
> | Letrec [Binding] Expression
> -- |typed expression
> | Typed Expression Type
> deriving (Eq, Show)
> data Eval
......
......@@ -182,16 +182,17 @@ TODO: The following import should be avoided if possible as it makes
=========================================================================
> xmlExpr :: [(Int,Ident)] -> Expression -> (Doc,[(Int,Ident)])
> xmlExpr d (Literal lit) = (xmlLiteral (xmlLit lit),d)
> xmlExpr d (Variable ident) = xmlExprVar d ident
> xmlExpr d (Literal lit) = (xmlLiteral (xmlLit lit),d)
> xmlExpr d (Variable ident) = xmlExprVar d ident
> xmlExpr d (Function ident arity) = (xmlSingleApp ident arity True,d)
> xmlExpr d (Constructor ident arity) = (xmlSingleApp ident arity False,d)
> xmlExpr d expr@(Apply _ _) = xmlApply d expr (xmlAppArgs expr)
> xmlExpr d (Case _ eval expr alt) = xmlCase d eval expr alt
> xmlExpr d (Case _ eval expr alt) = xmlCase d eval expr alt
> xmlExpr d (Or expr1 expr2) = xmlOr d expr1 expr2
> xmlExpr d (Exist ident expr) = xmlFree d ident expr
> xmlExpr d (Let binding expr) = xmlLet d binding expr
> xmlExpr d (Letrec lBinding expr) = xmlLetrec d lBinding expr
> xmlExpr d (Typed expr ty) = xmlTyped d expr ty
> xmlSingleApp :: QualIdent -> Int -> Bool -> Doc
> xmlSingleApp ident arity isFunction =
......@@ -326,6 +327,11 @@ TODO: The following import should be avoided if possible as it makes
> (b,d1) = xmlMapDicc d xmlBinding lB
> (e,d2) = xmlExpr d1 expr
> xmlTyped :: [(Int,Ident)] -> Expression -> Type -> (Doc,[(Int,Ident)])
> xmlTyped d expr ty =
> (text "<typed>" $$ nest level e1 $$ nest level (xmlType ty) $$ text "</typed>", d1)
> where (e1 ,d1) = xmlExpr d expr
=========================================================================
A U X I L I A R Y F U N C T I O N S
=========================================================================
......
......@@ -81,16 +81,17 @@ ccExpr (Case r ea e bs) = do
e' <- ccExpr e
bs' <- mapM ccAlt bs
ccCase r ea e' bs'
ccExpr (Or e1 e2) = liftM2 Or (ccExpr e1) (ccExpr e2)
ccExpr (Exist v e) = inNestedScope $ do
ccExpr (Or e1 e2) = liftM2 Or (ccExpr e1) (ccExpr e2)
ccExpr (Exist v e) = inNestedScope $ do
modifyScopeEnv $ insertIdent v
Exist v `liftM` ccExpr e
ccExpr (Let b e) = inNestedScope $ do
ccExpr (Let b e) = inNestedScope $ do
modifyScopeEnv $ insertBinding b
liftM2 (flip Let) (ccExpr e) (ccBinding b)
ccExpr (Letrec bs e) = inNestedScope $ do
ccExpr (Letrec bs e) = inNestedScope $ do
modifyScopeEnv $ flip (foldr insertBinding) bs
liftM2 (flip Letrec) (ccExpr e) (mapM ccBinding bs)
ccExpr (Typed e ty) = flip Typed ty `liftM` ccExpr e
ccAlt :: Alt -> CCM Alt
ccAlt (Alt p e) = inNestedScope $ do
......
......@@ -31,6 +31,7 @@ data structures, we can use only a qualified import for the
> import Curry.Base.Ident
> import Curry.Syntax
> import Base.CurryTypes (toType)
> import Base.Expr
> import Base.Messages (internalError)
> import Base.Types
......@@ -363,6 +364,8 @@ instance, if one of the alternatives contains an \texttt{@}-pattern.
> -- subject is referenced -> introduce binding for v as subject
> | v `elem` fv expr -> IL.Let (IL.Binding v e') expr
> | otherwise -> expr
> trExpr vs env (Typed e ty) = liftM2 IL.Typed (trExpr vs env e)
> (trType $ toType [] ty)
> trExpr _ _ _ = internalError "CurryToIL.trExpr"
> trAlt :: [Ident] -> RenameEnv -> Alt -> TransM Match
......
......@@ -425,7 +425,7 @@ type \texttt{Bool} of the guard because the guard's type defaults to
> | otherwise = return var
> dsExpr _ c@(Constructor _) = return c
> dsExpr p (Paren e) = dsExpr p e
> dsExpr p (Typed e _) = dsExpr p e
> dsExpr p (Typed e ty) = flip Typed ty `liftM` dsExpr p e
> dsExpr p (Tuple pos es) =
> apply (Constructor $ tupleConstr es) `liftM` mapM (dsExpr p) es
> where tupleConstr es1 = addRef pos $ if null es1 then qUnitId else qTupleId (length es1)
......
......@@ -224,7 +224,9 @@ in the type environment.
> abstractExpr pre lvs (Case r ct e alts) =
> liftM2 (Case r ct) (abstractExpr pre lvs e)
> (mapM (abstractAlt pre lvs) alts)
> abstractExpr _ _ _ = internalError "Lift.abstractExpr"
> abstractExpr pre lvs (Typed e ty) = flip Typed ty `liftM`
> abstractExpr pre lvs e
> abstractExpr _ _ _ = internalError "Lift.abstractExpr"
> abstractAlt :: String -> [Ident] -> Alt -> LiftM Alt
> abstractAlt pre lvs (Alt p t rhs) =
......@@ -275,6 +277,7 @@ to the top-level.
> liftExpr (Case r ct e alts) = (Case r ct e' alts', concat $ ds' : dss')
> where (e' ,ds' ) = liftExpr e
> (alts',dss') = unzip $ map liftAlt alts
> liftExpr (Typed e ty) = (Typed e' ty, ds) where (e', ds) = liftExpr e
> liftExpr _ = internalError "Lift.liftExpr"
> liftAlt :: Alt -> (Alt, [Decl])
......
......@@ -228,6 +228,7 @@ functions in later phases of the compiler.
> simplifyLet env (scc bv (qfv m) (foldr hoistDecls [] (concat dss'))) e
> simExpr env (Case r ct e alts) =
> liftM2 (Case r ct) (simExpr env e) (mapM (simplifyAlt env) alts)
> simExpr env (Typed e ty) = flip Typed ty `liftM` simExpr env e
> simExpr _ _ = error "Simplify.simExpr: no pattern match"
> simplifyAlt :: InlineEnv -> Alt -> SIM Alt
......
main = show ([] :: Bool)
\ No newline at end of file
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