Added support for typed FlatCurry expressions

src/Generators/GenFlatCurry.hs

@@ -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

src/IL/Pretty.lhs

@@ -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

src/IL/Type.lhs

@@ -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

src/IL/XML.lhs

@@ -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
 =========================================================================

src/Transformations/CaseCompletion.hs

@@ -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

src/Transformations/CurryToIL.lhs

@@ -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

src/Transformations/Desugar.lhs

@@ -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)

src/Transformations/Lift.lhs

@@ -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])

src/Transformations/Simplify.lhs

@@ -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

test/Typed.curry

+main = show ([] :: Bool)
\ No newline at end of file