From 53527adc2a9e4efb9984773674b9b0590b25b9c9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Peem=C3=B6ller?= Date: Tue, 8 Mar 2016 16:05:12 +0100 Subject: [PATCH] Simplified + corrected desugaring w.r.t functional + non-linear patterns --- src/Modules.hs | 13 ++--- src/Transformations.hs | 8 ++-- src/Transformations/Desugar.hs | 87 +++++++++++++++------------------- test/NonLinearLHS.curry | 2 + 4 files changed, 50 insertions(+), 60 deletions(-) diff --git a/src/Modules.hs b/src/Modules.hs index 6c2e7e5e..c23f329a 100644 --- a/src/Modules.hs +++ b/src/Modules.hs @@ -220,14 +220,11 @@ checkModule opts mdl = do transModule :: Options -> CompEnv CS.Module -> IO (CompEnv IL.Module) transModule opts mdl = do - desugared <- dumpCS DumpDesugared $ desugar False 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 - ilCaseComp <- dumpIL DumpCaseCompleted $ completeCase il + desugared <- dumpCS DumpDesugared $ desugar mdl + simplified <- dumpCS DumpSimplified $ simplify desugared + lifted <- dumpCS DumpLifted $ lift simplified + il <- dumpIL DumpTranslated $ ilTrans lifted + ilCaseComp <- dumpIL DumpCaseCompleted $ completeCase il return ilCaseComp where dumpCS = dumpWith opts CS.showModule CS.ppModule diff --git a/src/Transformations.hs b/src/Transformations.hs index 797570fb..82e82efe 100644 --- a/src/Transformations.hs +++ b/src/Transformations.hs @@ -33,10 +33,10 @@ 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) - (tyConsEnv env) mdl +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. simplify :: CompEnv Module -> CompEnv Module diff --git a/src/Transformations/Desugar.hs b/src/Transformations/Desugar.hs index 823e5695..80f6c634 100644 --- a/src/Transformations/Desugar.hs +++ b/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' + ( cs1, ts1) <- dsNonLinearity ts + (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 -- --------------------------------------------------------------------------- diff --git a/test/NonLinearLHS.curry b/test/NonLinearLHS.curry index 12dc16ea..b3f7d9fe 100644 --- a/test/NonLinearLHS.curry +++ b/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 -- GitLab