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

First compilable (but semantically wrong) version with fcase expressions

parent 86315ff5
......@@ -108,7 +108,7 @@ instance QualExpr Expression where
qfv m (Let ds e) = filterBv ds $ qfv m ds ++ qfv m e
qfv m (Do sts e) = foldr (qfvStmt m) (qfv m e) sts
qfv m (IfThenElse _ e1 e2 e3) = qfv m e1 ++ qfv m e2 ++ qfv m e3
qfv m (Case _ e alts) = qfv m e ++ qfv m alts
qfv m (Case _ _ e alts) = qfv m e ++ qfv m alts
qfv m (RecordConstr fs) = qfv m fs
qfv m (RecordSelection e _) = qfv m e
qfv m (RecordUpdate fs e) = qfv m e ++ qfv m fs
......
......@@ -238,7 +238,7 @@ environment.}
> ty3 <- exprType tyEnv e3
> unify ty2 ty3
> return ty3
> exprType tyEnv (Case _ _ alts) = freshTypeVar >>= flip altType alts
> exprType tyEnv (Case _ _ _ alts) = freshTypeVar >>= flip altType alts
> where altType ty [] = return ty
> altType ty (Alt _ _ rhs:alts1) =
> rhsType tyEnv rhs >>= unify ty >> altType ty alts1
......
......@@ -215,8 +215,8 @@ declaration groups.
> liftM2 Do (mapM checkStmt sts) (checkExpr e)
> checkExpr (IfThenElse r e1 e2 e3) =
> liftM3 (IfThenElse r) (checkExpr e1) (checkExpr e2) (checkExpr e3)
> checkExpr (Case r e alts) =
> liftM2 (Case r) (checkExpr e) (mapM checkAlt alts)
> checkExpr (Case r ct e alts) =
> liftM2 (Case r ct) (checkExpr e) (mapM checkAlt alts)
> checkExpr (RecordConstr fs) =
> RecordConstr `liftM` mapM checkFieldExpr fs
> checkExpr (RecordSelection e l) =
......
......@@ -225,8 +225,8 @@ interface.
> liftM2 Do (mapM checkStmt sts) (checkExpr e)
> checkExpr (IfThenElse r e1 e2 e3) =
> liftM3 (IfThenElse r) (checkExpr e1) (checkExpr e2) (checkExpr e3)
> checkExpr (Case r e alts) =
> liftM2 (Case r) (checkExpr e) (mapM checkAlt alts)
> checkExpr (Case r ct e alts) =
> liftM2 (Case r ct) (checkExpr e) (mapM checkAlt alts)
> checkExpr (RecordConstr fs) =
> RecordConstr `liftM` mapM checkFieldExpr fs
> checkExpr (RecordSelection e l) =
......
......@@ -713,8 +713,8 @@ checkParen
> liftM2 Do (mapM (checkStatement p) sts) (checkExpr p e)
> checkExpr p (IfThenElse r e1 e2 e3) =
> liftM3 (IfThenElse r) (checkExpr p e1) (checkExpr p e2) (checkExpr p e3)
> checkExpr p (Case r e alts) =
> liftM2 (Case r) (checkExpr p e) (mapM checkAlt alts)
> checkExpr p (Case r ct e alts) =
> liftM2 (Case r ct) (checkExpr p e) (mapM checkAlt alts)
> checkExpr p rec@(RecordConstr fs) = do
> checkRecordExtension p
> env <- getRenameEnv
......
......@@ -915,8 +915,7 @@ because of possibly multiple occurrences of variables.
> unify p "expression" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e3)
> ty2 ty3
> return ty3
> tcExpr p (Case _ e alts) =
> do
> tcExpr p (Case _ _ e alts) = do
> tyEnv0 <- getValueEnv
> ty <- tcExpr p e
> alpha <- freshTypeVar
......@@ -930,8 +929,7 @@ because of possibly multiple occurrences of variables.
> ty1 >>
> tcRhs tyEnv0 rhs >>=
> unify p1 "case branch" doc ty2
> tcExpr _ (RecordConstr fs) =
> do
> tcExpr _ (RecordConstr fs) = do
> fts <- mapM (tcFieldExpr equals) fs
> --when (1 == length fs)
> -- (error (show fs ++ "\n" ++ show fts))
......@@ -962,14 +960,14 @@ because of possibly multiple occurrences of variables.
> return ty
> tcQual :: Position -> Statement -> TCM ()
> tcQual p (StmtExpr _ e) = do
> tcQual p (StmtExpr _ e) =
> tcExpr p e >>= unify p "guard" (ppExpr 0 e) boolType
> tcQual p q@(StmtBind _ t e) = do
> ty1 <- tcConstrTerm p t
> ty2 <- tcExpr p e
> unify p "generator" (ppStmt q $-$ text "Term:" <+> ppExpr 0 e)
> (listType ty1) ty2
> tcQual _ (StmtDecl ds) = tcDecls ds
> tcQual _ (StmtDecl ds) = tcDecls ds
> tcStmt ::Position -> Statement -> TCM ()
> tcStmt p (StmtExpr _ e) = do
......
......@@ -344,7 +344,7 @@ checkExpression (Do stmts expr) = withScope $ do
reportUnusedVars
checkExpression (IfThenElse _ expr1 expr2 expr3)
= mapM_ checkExpression [expr1, expr2, expr3]
checkExpression (Case _ expr alts) = do
checkExpression (Case _ _ expr alts) = do
checkExpression expr
mapM_ checkAlt alts
checkCaseAlternatives alts
......
......@@ -522,7 +522,7 @@ genExpr pos env (Do stmts expr)
genExpr pos env (IfThenElse _ expr1 expr2 expr3)
= genExpr pos env (Apply (Apply (Apply (Variable qIfThenElseId)
expr1) expr2) expr3)
genExpr pos env (Case _ expr alts)
genExpr pos env (Case _ _ expr alts)
= let (env1, expr') = genExpr pos env expr
(env2, alts') = mapAccumL genBranchExpr env1 alts
in (env2, CCase expr' alts')
......
......@@ -634,7 +634,7 @@ expression2codes (Do statements expression) =
concatMap statement2codes statements ++ expression2codes expression
expression2codes (IfThenElse _ expression1 expression2 expression3) =
expression2codes expression1 ++ expression2codes expression2 ++ expression2codes expression3
expression2codes (Case _ expression alts) =
expression2codes (Case _ _ expression alts) =
expression2codes expression ++ concatMap alt2codes alts
expression2codes _ = internalError "SyntaxColoring.expression2codes: no pattern match"
......@@ -729,6 +729,7 @@ token2string (Token KW_data _) = "data"
token2string (Token KW_do _) = "do"
token2string (Token KW_else _) = "else"
token2string (Token KW_external _) = "external"
token2string (Token KW_fcase _) = "fcase"
token2string (Token KW_free _) = "free"
token2string (Token KW_if _) = "if"
token2string (Token KW_import _) = "import"
......
......@@ -106,7 +106,7 @@ an unlimited range of integer constants in Curry programs.
> | Apply Expression Expression
> -- |case expressions
> | Case SrcRef Eval Expression [Alt]
> -- |non-determinisismic or
> -- |non-deterministic or
> | Or Expression Expression
> -- |exist binding (introduction of a free variable)
> | Exist Ident Expression
......@@ -127,26 +127,22 @@ an unlimited range of integer constants in Curry programs.
> data Binding = Binding Ident Expression
> deriving (Eq, Show)
% instance for Expr
> instance Expr Expression where
> fv (Variable v) = [v]
> fv (Apply e1 e2) = fv e1 ++ fv e2
> fv (Case _ _ e alts) = fv e ++ fv alts
> fv (Case _ _ e alts) = fv e ++ fv alts
> fv (Or e1 e2) = fv e1 ++ fv e2
> fv (Exist v e) = filter (/= v) (fv e)
> fv (Let (Binding v e1) e2) = fv e1 ++ filter (/= v) (fv e2)
> fv (Letrec bds e) = filter (`notElem` vs) (fv es ++ fv e)
> where (vs, es) = unzip [(v, e') | Binding v e' <- bds]
> fv _ = []
> fv _ = []
> instance Expr Alt where
> fv (Alt (ConstructorPattern _ vs) e) = filter (`notElem` vs) (fv e)
> fv (Alt (VariablePattern v) e) = filter (v /=) (fv e)
> fv (Alt _ e) = fv e
% instance for SrcRefOf
> instance SrcRefOf ConstrTerm where
> srcRefOf (LiteralPattern l) = srcRefOf l
> srcRefOf (ConstructorPattern i _) = srcRefOf i
......
......@@ -79,7 +79,7 @@ ccExpr c@(Constructor _ _) = return c
ccExpr (Apply e1 e2) = liftM2 Apply (ccExpr e1) (ccExpr e2)
ccExpr (Case r ea e bs) = do
e' <- ccExpr e
bs' <- removeRedundantAlts `liftM` mapM ccAlt bs
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
......@@ -101,11 +101,25 @@ ccBinding :: Binding -> CCM Binding
ccBinding (Binding v e) = Binding v `liftM` ccExpr e
-- ---------------------------------------------------------------------------
-- Functions for completing case alternatives
-- ---------------------------------------------------------------------------
ccCase :: SrcRef -> Eval -> Expression -> [Alt] -> CCM Expression
ccCase _ _ _ []
= internalError "CaseCompletion.ccCase: empty alternative list"
-- pattern matching causes flexible case expressions
ccCase r Flex e alts = return $ Case r Flex e alts
ccCase r Rigid e alts
| isConstrAlt a = completeConsAlts r Rigid e as
| isLitAlt a = completeLitAlts r Rigid e as
| isVarAlt a = completeVarAlts e as
| otherwise
= internalError "CaseCompletion.ccExpr: illegal alternative list"
where as@(a:_) = alts -- removeRedundantAlts alts
-- The function 'removeRedundantAlts' removes case branches which are
-- either unreachable or multiply declared.
-- Note: unlike the PAKCS frontend, MCC does not support warnings. So
-- there will be no messages if alternatives have been removed.
removeRedundantAlts :: [Alt] -> [Alt]
removeRedundantAlts = removeMultipleAlts . removeIdleAlts
......@@ -137,28 +151,12 @@ removeIdleAlts = fst . splitAfter isVarAlt
-- used in the first alternative. All multiple alternatives will be
-- removed except for the first occurrence.
removeMultipleAlts :: [Alt] -> [Alt]
removeMultipleAlts = nubBy eqAlt
where eqAlt (Alt p1 _) (Alt p2 _) = case (p1, p2) of
(LiteralPattern l1, LiteralPattern l2) -> l1 == l2
(ConstructorPattern c1 _, ConstructorPattern c2 _) -> c1 == c2
(VariablePattern _, VariablePattern _) -> True
_ -> False
-- ---------------------------------------------------------------------------
-- Functions for completing case alternatives
-- ---------------------------------------------------------------------------
ccCase :: SrcRef -> Eval -> Expression -> [Alt] -> CCM Expression
ccCase _ _ _ []
= internalError "CaseCompletion.ccCase: empty alternative list"
-- pattern matching causes flexible case expressions
ccCase r Flex e as = return $ Case r Flex e as
ccCase r Rigid e as@(a:_)
| isConstrAlt a = completeConsAlts r Rigid e as
| isLitAlt a = completeLitAlts r Rigid e as
| isVarAlt a = completeVarAlts e as
| otherwise
= internalError "CaseCompletion.ccExpr: illegal alternative list"
removeMultipleAlts = nubBy eqAlt where
eqAlt (Alt p1 _) (Alt p2 _) = case (p1, p2) of
(LiteralPattern l1, LiteralPattern l2) -> l1 == l2
(ConstructorPattern c1 _, ConstructorPattern c2 _) -> c1 == c2
(VariablePattern _, VariablePattern _) -> True
_ -> False
-- Completes a case alternative list which branches via constructor patterns
-- by adding alternatives of the form
......@@ -247,6 +245,7 @@ completeVarAlts ce (Alt p ae : _) = case p of
-- ---------------------------------------------------------------------------
-- Some functions for testing case alternatives
-- ---------------------------------------------------------------------------
isVarAlt :: Alt -> Bool
isVarAlt (Alt (VariablePattern _) _) = True
......
......@@ -347,7 +347,7 @@ instance, if one of the alternatives contains an \texttt{@}-pattern.
> trBinding (PatternDecl _ (VariablePattern v) rhs)
> = IL.Binding v `liftM` trRhs vs env' rhs
> trBinding p = error $ "unexpected binding: " ++ show p
> trExpr (v:vs) env (Case r e alts) = do
> trExpr (v:vs) env (Case r _ e alts) = do
> -- the ident v is used for the case expression subject, as this could
> -- be referenced in the case alternatives by a variable pattern
> e' <- trExpr vs env e
......
......@@ -407,8 +407,9 @@ type \texttt{Bool} of the guard because the guard's type defaults to
> e1' <- dsExpr p e1
> e2' <- dsExpr p e2
> e3' <- dsExpr p e3
> return (Case r e1' [caseAlt p truePattern e2',caseAlt p falsePattern e3'])
> dsExpr p (Case r e alts)
> return (Case r Rigid e1'
> [caseAlt p truePattern e2', caseAlt p falsePattern e3'])
> dsExpr p (Case r ct e alts)
> | null alts = return prelFailed
> | otherwise = do
> m <- getModuleIdent
......@@ -417,11 +418,11 @@ type \texttt{Bool} of the guard because the guard's type defaults to
> alts' <- mapM dsAltLhs alts
> tyEnv <- getValueEnv
> alts'' <- mapM dsAltRhs
> (map (expandAlt tyEnv v) (init (tails alts')))
> (map (expandAlt tyEnv v ct) (init (tails alts')))
> return (mkCase m v e' alts'')
> where mkCase m1 v e1 alts1
> | v `elem` qfv m1 alts1 = Let [varDecl p v e1] (Case r (mkVar v) alts1)
> | otherwise = Case r e1 alts1
> | v `elem` qfv m1 alts1 = Let [varDecl p v e1] (Case r ct (mkVar v) alts1)
> | otherwise = Case r ct e1 alts1
> dsExpr p (RecordConstr fs)
> | null fs = internalError "Desugar.dsExpr: empty record construction"
> | otherwise = do
......@@ -465,10 +466,10 @@ are compatible with the matched pattern when the guards fail.
> dsAltRhs :: Alt -> DsM Alt
> dsAltRhs (Alt p t rhs) = Alt p t `liftM` dsRhs p rhs
> expandAlt :: ValueEnv -> Ident -> [Alt] -> Alt
> expandAlt _ _ [] = error "Desugar.expandAlt: empty list"
> expandAlt tyEnv v (Alt p t rhs : alts) = caseAlt p t (expandRhs tyEnv e0 rhs)
> where e0 = Case (srcRefOf p) (mkVar v)
> expandAlt :: ValueEnv -> Ident -> CaseType -> [Alt] -> Alt
> expandAlt _ _ _ [] = error "Desugar.expandAlt: empty list"
> expandAlt tyEnv v ct (Alt p t rhs : alts) = caseAlt p t (expandRhs tyEnv e0 rhs)
> where e0 = Case (srcRefOf p) ct (mkVar v)
> (filter (isCompatible t . altPattern) alts)
> altPattern (Alt _ t1 _) = t1
......@@ -697,28 +698,27 @@ instead of \texttt{(++)} and \texttt{map} in place of
\begin{verbatim}
> dsQual :: Position -> Statement -> Expression -> DsM Expression
> dsQual p (StmtExpr pos b) e =
> dsExpr p (IfThenElse pos b e (List [pos] []))
> dsQual p (StmtDecl ds) e = dsExpr p (Let ds e)
> dsQual p (StmtBind refBind t l) e
> dsQual p (StmtExpr r b) e =
> dsExpr p (IfThenElse r b e (List [r] []))
> dsQual p (StmtDecl ds) e = dsExpr p (Let ds e)
> dsQual p (StmtBind r t l) e
> | isVarPattern t = dsExpr p (qualExpr t e l)
> | otherwise = do
> v <- addRefId refBind `liftM` freshMonoTypeVar "_#var" t
> l' <- addRefId refBind `liftM` freshMonoTypeVar "_#var" e
> dsExpr p (apply (prelFoldr refBind)
> [foldFunct v l' e,List [refBind] [],l])
> v <- addRefId r `liftM` freshMonoTypeVar "_#var" t
> l' <- addRefId r `liftM` freshMonoTypeVar "_#var" e
> dsExpr p (apply (prelFoldr r) [foldFunct v l' e, List [r] [], l])
> where
> qualExpr v (ListCompr _ e1 []) l1
> = apply (prelMap refBind) [Lambda refBind [v] e1,l1]
> = apply (prelMap r) [Lambda r [v] e1,l1]
> qualExpr v e1 l1
> = apply (prelConcatMap refBind) [Lambda refBind [v] e1,l1]
> foldFunct v l1 e1 = Lambda refBind (map VariablePattern [v,l1])
> (Case refBind (mkVar v)
> = apply (prelConcatMap r) [Lambda r [v] e1,l1]
> foldFunct v l1 e1 = Lambda r (map VariablePattern [v,l1])
> (Case r Flex (mkVar v)
> [ caseAlt {-refBind-} p t (append e1 (mkVar l1))
> , caseAlt {-refBind-} p (VariablePattern v) (mkVar l1)])
>
> append (ListCompr _ e1 []) l1 = apply (Constructor $ addRef refBind $ qConsId) [e1,l1]
> append e1 l1 = apply (prelAppend refBind) [e1,l1]
> append (ListCompr _ e1 []) l1 = apply (Constructor $ addRef r $ qConsId) [e1,l1]
> append e1 l1 = apply (prelAppend r) [e1,l1]
\end{verbatim}
Generation of fresh names
......
......@@ -209,21 +209,21 @@ in the type environment.
> abstractFunDecl _ _ _ _ = error "Lift.abstractFunDecl: no pattern match"
> abstractExpr :: String -> [Ident] -> Expression -> LiftM Expression
> abstractExpr _ _ l@(Literal _) = return l
> abstractExpr pre lvs var@(Variable v)
> abstractExpr _ _ l@(Literal _) = return l
> abstractExpr pre lvs var@(Variable v)
> | isQualified v = return var
> | otherwise = do
> env <- getAbstractEnv
> case Map.lookup (unqualify v) env of
> Nothing -> return var
> Just v' -> abstractExpr pre lvs v'
> abstractExpr _ _ c@(Constructor _) = return c
> abstractExpr pre lvs (Apply e1 e2) =
> abstractExpr _ _ c@(Constructor _) = return c
> abstractExpr pre lvs (Apply e1 e2) =
> liftM2 Apply (abstractExpr pre lvs e1) (abstractExpr pre lvs e2)
> abstractExpr pre lvs (Let ds e) = abstractDeclGroup pre lvs ds e
> abstractExpr pre lvs (Case r e alts) =
> liftM2 (Case r) (abstractExpr pre lvs e)
> (mapM (abstractAlt pre lvs) alts)
> abstractExpr pre lvs (Let ds e) = abstractDeclGroup pre lvs ds e
> 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"
> abstractAlt :: String -> [Ident] -> Alt -> LiftM Alt
......@@ -262,17 +262,17 @@ to the top-level.
> (vds', dss') = unzip $ map liftVarDecl vds
> liftExpr :: Expression -> (Expression, [Decl])
> liftExpr l@(Literal _) = (l, [])
> liftExpr v@(Variable _) = (v, [])
> liftExpr c@(Constructor _) = (c, [])
> liftExpr (Apply e1 e2) = (Apply e1' e2', ds' ++ ds'')
> liftExpr l@(Literal _) = (l, [])
> liftExpr v@(Variable _) = (v, [])
> liftExpr c@(Constructor _) = (c, [])
> liftExpr (Apply e1 e2) = (Apply e1' e2', ds' ++ ds'')
> where (e1', ds' ) = liftExpr e1
> (e2', ds'') = liftExpr e2
> liftExpr (Let ds e) = (mkLet ds' e', ds'' ++ ds''')
> liftExpr (Let ds e) = (mkLet ds' e', ds'' ++ ds''')
> where (ds', ds'' ) = liftDeclGroup ds
> (e' , ds''') = liftExpr e
> mkLet ds1 e1 = if null ds1 then e1 else Let ds1 e1
> liftExpr (Case r e alts) = (Case r e' alts', concat $ ds' : dss')
> 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 _ = internalError "Lift.liftExpr"
......
......@@ -151,7 +151,7 @@ qExpr (Let ds e) = liftM2 Let (mapM qDecl ds) (qExpr e)
qExpr (Do sts e) = liftM2 Do (mapM qStmt sts) (qExpr e)
qExpr (IfThenElse r e1 e2 e3) = liftM3 (IfThenElse r) (qExpr e1)
(qExpr e2) (qExpr e3)
qExpr (Case r e alts) = liftM2 (Case r) (qExpr e) (mapM qAlt alts)
qExpr (Case r ct e as) = liftM2 (Case r ct) (qExpr e) (mapM qAlt as)
qExpr (RecordConstr fs) = RecordConstr `liftM` mapM qFieldExpr fs
qExpr (RecordSelection e l) = flip RecordSelection l `liftM` qExpr e
qExpr (RecordUpdate fs e) = liftM2 RecordUpdate (mapM qFieldExpr fs)
......
......@@ -215,8 +215,8 @@ functions in later phases of the compiler.
> (Map.lookup (unqualify x) env)
> simExpr _ c@(Constructor _) = return c
> simExpr env (Apply (Let ds e1) e2) = simExpr env (Let ds (Apply e1 e2))
> simExpr env (Apply (Case r e1 alts) e2)
> = simExpr env (Case r e1 (map (applyToAlt e2) alts))
> simExpr env (Apply (Case r ct e1 alts) e2)
> = simExpr env (Case r ct e1 (map (applyToAlt e2) alts))
> where applyToAlt e (Alt p t rhs) = Alt p t (applyRhs rhs e)
> applyRhs (SimpleRhs p e1' _) e2' = SimpleRhs p (Apply e1' e2') []
> applyRhs (GuardedRhs _ _) _ = error "Simplify.simExpr.applyRhs: Guarded rhs"
......@@ -226,8 +226,8 @@ functions in later phases of the compiler.
> tyEnv <- getValueEnv
> dss' <- mapM (sharePatternRhs tyEnv) ds
> simplifyLet env (scc bv (qfv m) (foldr hoistDecls [] (concat dss'))) e
> simExpr env (Case r e alts) =
> liftM2 (Case r) (simExpr env e) (mapM (simplifyAlt env) alts)
> simExpr env (Case r ct e alts) =
> liftM2 (Case r ct) (simExpr env e) (mapM (simplifyAlt env) alts)
> simExpr _ _ = error "Simplify.simExpr: no pattern match"
> simplifyAlt :: InlineEnv -> Alt -> SIM Alt
......
notCase x = case x of
True -> False
True -> False
False -> True
v -> v
notP True = False
notP True = False
notP False = True
notP v = v
notFCase x = fcase x of
True -> False
True -> False
False -> True
v -> v
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