Simplified + corrected desugaring w.r.t functional + non-linear patterns

src/Modules.hs

@@ -220,13 +220,10 @@ checkModule opts mdl = do
 
 transModule :: Options -> CompEnv CS.Module -> IO (CompEnv IL.Module)
 transModule opts mdl = do
-  desugared   <- dumpCS DumpDesugared     $ desugar False mdl
+  desugared   <- dumpCS DumpDesugared     $ desugar      mdl
   simplified  <- dumpCS DumpSimplified    $ simplify     desugared
   lifted      <- dumpCS DumpLifted        $ lift         simplified
-  desugared2  <- dumpCS DumpDesugared     $ desugar True  lifted
-  simplified2 <- dumpCS DumpSimplified    $ simplify      desugared2
-  lifted2     <- dumpCS DumpLifted        $ lift          simplified2
-  il          <- dumpIL DumpTranslated    $ ilTrans       lifted2
+  il          <- dumpIL DumpTranslated    $ ilTrans      lifted
   ilCaseComp  <- dumpIL DumpCaseCompleted $ completeCase il
   return ilCaseComp
   where

src/Transformations.hs

@@ -33,9 +33,9 @@ qual (env, mdl) = (qualifyEnv env, mdl')
   where mdl' = Q.qual (moduleIdent env) (tyConsEnv env) (valueEnv env) mdl
 
 -- |Remove any syntactic sugar, changes the value environment.
-desugar :: Bool -> CompEnv Module -> CompEnv Module
-desugar dsfp (env, mdl) = (env { valueEnv = tyEnv' }, mdl')
-  where (mdl', tyEnv') = DS.desugar dsfp (extensions env) (valueEnv env)
+desugar :: CompEnv Module -> CompEnv Module
+desugar (env, mdl) = (env { valueEnv = tyEnv' }, mdl')
+  where (mdl', tyEnv') = DS.desugar (extensions env) (valueEnv env)
                                     (tyConsEnv env) mdl
 
 -- |Simplify the source code, changes the value environment.

src/Transformations/Desugar.hs

@@ -97,12 +97,11 @@ import Env.Value (ValueEnv, ValueInfo (..), bindFun, lookupValue
 -- out separately. Actually, the transformation is slightly more general than
 -- necessary as it allows value declarations at the top-level of a module.
 
-desugar :: Bool -> [KnownExtension] -> ValueEnv -> TCEnv -> Module
-        -> (Module, ValueEnv)
-desugar dsFunPats xs tyEnv tcEnv (Module ps m es is ds)
+desugar :: [KnownExtension] -> ValueEnv -> TCEnv -> Module -> (Module, ValueEnv)
+desugar xs tyEnv tcEnv (Module ps m es is ds)
   = (Module ps m es is ds', valueEnv s')
   where (ds', s') = S.runState (desugarModuleDecls ds)
-                               (DesugarState m xs tcEnv tyEnv 1 dsFunPats)
+                               (DesugarState m xs tcEnv tyEnv 1)
 
 -- ---------------------------------------------------------------------------
 -- Desugaring monad and accessor functions
@@ -121,7 +120,6 @@ data DesugarState = DesugarState
   , tyConsEnv   :: TCEnv            -- read-only
   , valueEnv    :: ValueEnv         -- will be extended
   , nextId      :: Integer          -- counter
-  , desugarFP   :: Bool             -- flat if to desugar functional patterns
   }
 
 type DsM a = S.State DesugarState a
@@ -141,9 +139,6 @@ getValueEnv = S.gets valueEnv
 modifyValueEnv :: (ValueEnv -> ValueEnv) -> DsM ()
 modifyValueEnv f = S.modify $ \ s -> s { valueEnv = f $ valueEnv s }
 
-desugarFunPats :: DsM Bool
-desugarFunPats = S.gets desugarFP
-
 getNextId :: DsM Integer
 getNextId = do
   nid <- S.gets nextId
@@ -299,20 +294,19 @@ dsDeclRhs _ = error "Desugar.dsDeclRhs: no pattern match"
 -- Desugaring of an equation
 dsEquation :: Equation -> DsM Equation
 dsEquation (Equation p lhs rhs) = do
-  funpats        <- desugarFunPats
-  (ds1, cs, ts1) <- if funpats then do
   (     cs1, ts1) <- dsNonLinearity         ts
-                                  (ds2, cs2, ts2) <- dsFunctionalPatterns p ts1
-                                  return (ds2, cs2 ++ cs1, ts2)
-                                else return ([], [], ts)
-  (ds2    , ts2) <- mapAccumM (dsPat p) [] ts1
-  rhs'           <- dsRhs p (addConstraints cs) $ addDecls (ds1 ++ ds2) $ rhs
-  return $ Equation p (FunLhs f ts2) rhs'
+  (ds1, cs2, ts2) <- dsFunctionalPatterns p ts1
+  (ds2,      ts3) <- mapAccumM (dsPat p) [] ts2
+  rhs'            <- dsRhs p (constrain cs2 . constrain cs1)
+                             (addDecls (ds1 ++ ds2) rhs)
+  return $ Equation p (FunLhs f ts3) rhs'
   where (f, ts) = flatLhs lhs
 
-addConstraints :: [Expression] -> Expression -> Expression
-addConstraints cs e | null cs   = e
-                    | otherwise = apply prelCond [foldr1 (&>) cs, e]
+-- Constrain an expression by a list of constraints.
+-- @constrain []  e  ==  e@
+-- @constrain c_n e  ==  (c_1 & ... & c_n) &> e@
+constrain :: [Expression] -> Expression -> Expression
+constrain cs e = if null cs then e else foldr1 (&) cs &> e
 
 -- -----------------------------------------------------------------------------
 -- Desugaring of right-hand sides
@@ -339,7 +333,7 @@ expandGuards e0 es = do
   return $ if boolGuards tyEnv es then foldr mkIfThenElse e0 es else mkCond es
   where
   mkIfThenElse (CondExpr p g e) = IfThenElse (srcRefOf p) g e
-  mkCond [CondExpr _ g e] = apply prelCond [g, e]
+  mkCond [CondExpr _ g e] = g &> e
   mkCond _                = error "Desugar.expandGuards.mkCond: non-unary list"
 
 boolGuards :: ValueEnv -> [CondExpr] -> Bool
@@ -895,6 +889,15 @@ negateLiteral _            = internalError "Desugar.negateLiteral"
 -- Prelude entities
 -- ---------------------------------------------------------------------------
 
+prel :: String -> SrcRef -> Expression
+prel s r = Variable $ addRef r $ preludeIdent s
+
+prelude :: String -> Expression
+prelude = Variable . preludeIdent
+
+preludeIdent :: String -> QualIdent
+preludeIdent = qualifyWith preludeMIdent . mkIdent
+
 prelBind :: SrcRef -> Expression
 prelBind = prel ">>="
 
@@ -902,28 +905,28 @@ prelBind_ :: SrcRef -> Expression
 prelBind_ = prel ">>"
 
 prelFlip :: Expression
-prelFlip = Variable $ preludeIdent "flip"
+prelFlip = prelude "flip"
 
 prelEnumFrom :: Expression
-prelEnumFrom = Variable $ preludeIdent "enumFrom"
+prelEnumFrom = prelude "enumFrom"
 
 prelEnumFromTo :: Expression
-prelEnumFromTo = Variable $ preludeIdent "enumFromTo"
+prelEnumFromTo = prelude "enumFromTo"
 
 prelEnumFromThen :: Expression
-prelEnumFromThen = Variable $ preludeIdent "enumFromThen"
+prelEnumFromThen = prelude "enumFromThen"
 
 prelEnumFromThenTo :: Expression
-prelEnumFromThenTo = Variable $ preludeIdent "enumFromThenTo"
+prelEnumFromThenTo = prelude "enumFromThenTo"
 
 prelFailed :: Expression
-prelFailed = Variable $ preludeIdent "failed"
+prelFailed = prelude "failed"
 
 prelUnknown :: Expression
-prelUnknown = Variable $ preludeIdent "unknown"
+prelUnknown = prelude "unknown"
 
 prelMap :: SrcRef -> Expression
-prelMap r = Variable $ addRef r $ preludeIdent "map"
+prelMap = prel "map"
 
 prelFoldr :: SrcRef -> Expression
 prelFoldr = prel "foldr"
@@ -935,31 +938,22 @@ prelConcatMap :: SrcRef -> Expression
 prelConcatMap = prel "concatMap"
 
 prelNegate :: Expression
-prelNegate = Variable $ preludeIdent "negate"
+prelNegate = prelude "negate"
 
 prelNegateFloat :: Expression
-prelNegateFloat = Variable $ preludeIdent "negateFloat"
-
-prelCond :: Expression
-prelCond = Variable $ preludeIdent "cond"
+prelNegateFloat = prelude "negateFloat"
 
 (=:<=) :: Expression -> Expression -> Expression
-e1 =:<= e2 = apply prelFPEq [e1, e2]
-
-prelFPEq :: Expression
-prelFPEq = Variable $ preludeIdent "=:<="
+e1 =:<= e2 = apply (prelude "=:<=") [e1, e2]
 
 (=:=) :: Expression -> Expression -> Expression
-e1 =:= e2 = apply prelSEq [e1, e2]
-
-prelSEq :: Expression
-prelSEq = Variable $ preludeIdent "=:="
+e1 =:= e2 = apply (prelude "=:=") [e1, e2]
 
 (&>) :: Expression -> Expression -> Expression
-e1 &> e2 = apply prelCond [e1, e2]
+e1 &> e2 = apply (prelude "cond") [e1, e2]
 
-prel :: String -> SrcRef -> Expression
-prel s r = Variable $ addRef r $ preludeIdent s
+(&) :: Expression -> Expression -> Expression
+e1 & e2 = apply (prelude "&") [e1, e2]
 
 truePat :: Pattern
 truePat = ConstructorPattern qTrueId []
@@ -967,9 +961,6 @@ truePat = ConstructorPattern qTrueId []
 falsePat :: Pattern
 falsePat = ConstructorPattern qFalseId []
 
-preludeIdent :: String -> QualIdent
-preludeIdent = qualifyWith preludeMIdent . mkIdent
-
 -- ---------------------------------------------------------------------------
 -- Auxiliary definitions
 -- ---------------------------------------------------------------------------

test/NonLinearLHS.curry

@@ -15,3 +15,5 @@ leftB a b (_ ++ [a,b] ++ _) = success
 f x (_ ++ [x]) [x] | not x = x
 
 test [x] (x ++ x) (x ++ x) x | null x = x
+
+test2 [x] (id x) ~True | null x = x