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

Allow as patterns to be used inside functional patterns

parent d5607a0a
......@@ -963,7 +963,7 @@ to \texttt{(apply (id id) 10)}.
> checkFPTerm p (ParenPattern t) = checkFPTerm p t
> checkFPTerm p (TuplePattern _ ts) = mapM_ (checkFPTerm p) ts
> checkFPTerm p (ListPattern _ ts) = mapM_ (checkFPTerm p) ts
> checkFPTerm p t@(AsPattern _ _) = report $ errUnsupportedFPTerm "As" p t
> checkFPTerm p (AsPattern _ t) = checkFPTerm p t
> checkFPTerm p t@(LazyPattern _ _) = report $ errUnsupportedFPTerm "Lazy" p t
> checkFPTerm p t@(RecordPattern _ _) = report $ errUnsupportedFPTerm "Record" p t
> checkFPTerm _ (FunctionPattern _ _) = ok -- dot not check again
......
......@@ -67,7 +67,7 @@ all names must be properly qualified before calling this module.}
> module Transformations.Desugar (desugar) where
> import Control.Arrow (second)
> import Control.Arrow (first, second)
> import Control.Monad (liftM, liftM2, mplus)
> import qualified Control.Monad.State as S (State, runState, gets, modify)
> import Data.List ((\\), nub, tails)
......@@ -75,7 +75,7 @@ all names must be properly qualified before calling this module.}
> import qualified Data.Set as Set (Set, empty, member, insert)
> import Curry.Base.Ident
> import Curry.Base.Position
> import Curry.Base.Position hiding (first)
> import Curry.Syntax
> import Base.Expr
......@@ -619,22 +619,40 @@ Function Patterns
> | null free = ([] , cs)
> | otherwise = ([FreeDecl p free], cs)
> where
> cs = map (uncurry (=:<=)) bs
> mkLB (t, v) = let (t', es) = fp2Expr t
> in (t' =:<= mkVar v) : es
> cs = concatMap mkLB bs
> free = nub $ filter (not . isAnonId) $ bv (map fst bs) \\ vs
> t =:<= i = apply prelFPEq [fp2Expr t, mkVar i]
> fp2Expr :: Pattern -> Expression
> fp2Expr (LiteralPattern l) = Literal l
> fp2Expr (NegativePattern _ l) = Literal (negateLiteral l)
> fp2Expr (VariablePattern v) = mkVar v
> fp2Expr (ConstructorPattern c ts) = apply (Constructor c) (map fp2Expr ts)
> fp2Expr (InfixPattern t1 op t2) = InfixApply (fp2Expr t1) (InfixOp op) (fp2Expr t2)
> fp2Expr (ParenPattern t) = Paren (fp2Expr t)
> fp2Expr (TuplePattern r ts) = Tuple r (map fp2Expr ts)
> fp2Expr (ListPattern rs ts) = List rs (map fp2Expr ts)
> fp2Expr (FunctionPattern f ts) = apply (Variable f) (map fp2Expr ts)
> fp2Expr (InfixFuncPattern t1 op t2) = InfixApply (fp2Expr t1) (InfixOp op) (fp2Expr t2)
> fp2Expr t = internalError $
> fp2Expr :: Pattern -> (Expression, [Expression])
> fp2Expr (LiteralPattern l) = (Literal l, [])
> fp2Expr (NegativePattern _ l) = (Literal (negateLiteral l), [])
> fp2Expr (VariablePattern v) = (mkVar v, [])
> fp2Expr (ConstructorPattern c ts) =
> let (ts', ess) = unzip $ map fp2Expr ts
> in (apply (Constructor c) ts', concat ess)
> fp2Expr (InfixPattern t1 op t2) =
> let (t1', es1) = fp2Expr t1
> (t2', es2) = fp2Expr t2
> in (InfixApply t1' (InfixOp op) t2', es1 ++ es2)
> fp2Expr (ParenPattern t) = first Paren (fp2Expr t)
> fp2Expr (TuplePattern r ts) =
> let (ts', ess) = unzip $ map fp2Expr ts
> in (Tuple r ts', concat ess)
> fp2Expr (ListPattern rs ts) =
> let (ts', ess) = unzip $ map fp2Expr ts
> in (List rs ts', concat ess)
> fp2Expr (FunctionPattern f ts) =
> let (ts', ess) = unzip $ map fp2Expr ts
> in (apply (Variable f) ts', concat ess)
> fp2Expr (InfixFuncPattern t1 op t2) =
> let (t1', es1) = fp2Expr t1
> (t2', es2) = fp2Expr t2
> in (InfixApply t1' (InfixOp op) t2', es1 ++ es2)
> fp2Expr (AsPattern v t) =
> let (t', es) = fp2Expr t
> in (mkVar v, (t' =:<= mkVar v):es)
> fp2Expr t = internalError $
> "Desugar.fp2Expr: Unexpected constructor term: " ++ show t
Desugaring of Records
......@@ -821,6 +839,9 @@ Prelude entities
> prelCond :: Expression
> prelCond = Variable $ preludeIdent "cond"
> (=:<=) :: Expression -> Expression -> Expression
> e1 =:<= e2 = apply prelFPEq [e1, e2]
> prelFPEq :: Expression
> prelFPEq = Variable $ preludeIdent "=:<="
......
f (v@[] ++ v@(x:xs)) = x:xs ++ 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