Merge branch 'master' into new-abstract-curry

Conflicts:
	src/Generators/GenAbstractCurry.hs

TODO

-Completed
-=========
-- Anonymous free variables implemented
-- hierarchically structured modules
-- Records: There is no way to explicitly import a record with its fields:
-    import CompilerOpts                -- okay, works
-    import CompilerOpts (Options)      -- okay, but no field labels imported
-    import CompilerOpts (Options (..)) -- fails: Options is not a data type
-- Checked correctness of created FlatCurry files by comparison with the old
-  frontend
-
-Still to do
-===========
-- Module pragmas
-- type classes
-- option to disable nondeterminism by overlapping
-- option/check for case mode
-- FFI for C (Haskell?)
-- Extend error messages of the type checker (and maybe others, too)
-  with the origin of the inferred types in case of a type conflict

src/Generators/GenAbstractCurry.hs

@@ -249,7 +249,7 @@ trPat (ListPattern         _ ps) = trPat $
         (ConstructorPattern qNilId [])
         ps
 trPat (NegativePattern      _ l) = trPat $ LiteralPattern $ negateLiteral l
-trPat (AsPattern            v p) = flip CPAs <$> trPat p <*> genVarIndex v
+trPat (AsPattern            v p) = CPAs <$> getVarIndex v<*> trPat p
 trPat (LazyPattern          _ p) = CPLazy <$> trPat p
 trPat (FunctionPattern     f ps) = CPFuncComb <$> trQual f <*> mapM trPat ps
 trPat (InfixFuncPattern p1 f p2) = trPat (FunctionPattern f [p1, p2])

src/Modules.hs

@@ -215,13 +215,13 @@ checkModule opts mdl = do
 
 transModule :: Options -> CompEnv CS.Module -> IO (CompEnv IL.Module)
 transModule opts mdl = do
-  desugared   <- dumpCS DumpDesugared     $ desugar True  mdl
+  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       lifted
+  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
   return ilCaseComp
   where
@@ -233,10 +233,9 @@ transModule opts mdl = do
 -- ---------------------------------------------------------------------------
 
 writeOutput :: Options -> FilePath -> CompEnv CS.Module -> IO ()
-writeOutput opts fn (env, modul) = do
+writeOutput opts fn mdl@(_, modul) = do
   writeParsed opts fn modul
-  let (env1, qlfd) = qual opts (env, modul)
-  doDump (optDebugOpts opts) (DumpQualified, env1, show $ CS.ppModule qlfd)
+  (env1, qlfd) <- dumpWith opts CS.ppModule DumpQualified $ qual opts mdl
   writeAbstractCurry opts fn env1 qlfd
   when withFlat $ do
     (env2, il) <- transModule opts (env1, qlfd)

src/Transformations/Desugar.hs

 {- |
-    Module      :  $Header$
-    Description :  Desugaring Curry Expressions
-    Copyright   :  (c) 2001 - 2004 Wolfgang Lux
-                                   Martin Engelke
-                       2011 - 2015 Björn Peemöller
-    License     :  OtherLicense
-
-    Maintainer  :  bjp@informatik.uni-kiel.de
-    Stability   :  experimental
-    Portability :  portable
-
-   The desugaring pass removes all syntactic sugar from the module. In
-   particular, the output of the desugarer will have the following
-   properties.
-
-     * All function definitions are eta-expanded.
-       Note: Since this version is used as a frontend for PAKCS, the
-       eta-expansion had been disabled.
-
-     * No guarded right hand sides occur in equations, pattern
-       declarations, and case alternatives. In addition, the declaration
-       lists of the right hand sides are empty; local declarations are
-       transformed into let expressions.
-
-     * Patterns in equations and case alternatives are composed only of
-         - literals,
-         - variables,
-         - constructor applications, and
-         - as patterns.
-
-     * Expressions are composed only of
-         - literals,
-         - variables,
-         - constructors,
-         - (binary) applications,
-         - let expressions, and
-         - case expressions.
-
-     * Applications 'N x' in patterns and expressions, where 'N' is a
-       newtype constructor, are replaced by a 'x'. Note that neither the
-       newtype declaration itself nor partial applications of newtype
-       constructors are changed (It were possible to replace partial
-       applications of newtype constructor by 'prelude.id'.
-       However, our solution yields a more accurate output when the result
-       of a computation includes partial applications.).
-
-     * Functional patterns are replaced by variables and are integrated
-       in a guarded right hand side using the (=:<=) operator
-
-     * Records, which currently must be declared using the keyword
-       'type', are transformed into data types with one constructor.
-       Record construction and pattern matching are represented using the
-       record constructor. Selection and update are represented using selector
-       and update functions which are generated for each record declaration.
-       The record constructor must be entered into the type environment as well
-       as the selector functions and the update functions.
-
-   As we are going to insert references to real prelude entities,
-   all names must be properly qualified before calling this module.
+  Module      :  $Header$
+  Description :  Desugaring Curry Expressions
+  Copyright   :  (c) 2001 - 2004 Wolfgang Lux
+                                 Martin Engelke
+                     2011 - 2015 Björn Peemöller
+  License     :  OtherLicense
+
+  Maintainer  :  bjp@informatik.uni-kiel.de
+  Stability   :  experimental
+  Portability :  portable
+
+  The desugaring pass removes all syntactic sugar from the module. In
+  particular, the output of the desugarer will have the following
+  properties.
+
+  * No guarded right hand sides occur in equations, pattern
+    declarations, and case alternatives. In addition, the declaration
+    lists of the right hand sides are empty; local declarations are
+    transformed into let expressions.
+
+  * Patterns in equations and case alternatives are composed only of
+    - literals,
+    - variables,
+    - constructor applications, and
+    - as patterns.
+
+  * Expressions are composed only of
+    - literals,
+    - variables,
+    - constructors,
+    - (binary) applications,
+    - let expressions, and
+    - case expressions.
+
+  * Applications 'N x' in patterns and expressions, where 'N' is a
+    newtype constructor, are replaced by a 'x'. Note that neither the
+    newtype declaration itself nor partial applications of newtype
+    constructors are changed.
+    It were possible to replace partial applications of newtype constructor
+    by 'Prelude.id'.
+    However, our solution yields a more accurate output when the result
+    of a computation includes partial applications.
+
+  * Functional patterns are replaced by variables and are integrated
+    in a guarded right hand side using the (=:<=) operator
+
+  * Records, which currently must be declared using the keyword 'type',
+    are transformed into data types with one constructor.
+    Record construction and pattern matching are represented using the
+    record constructor. Selection and update are represented using selector
+    and update functions which are generated for each record declaration.
+    The record constructor must be entered into the type environment as well
+    as the selector functions and the update functions.
+
+  As we are going to insert references to real prelude entities,
+  all names must be properly qualified before calling this module.
 -}
 {-# LANGUAGE CPP #-}
 module Transformations.Desugar (desugar) where
@@ -145,10 +142,22 @@ getTypeOf t = do
 freshIdent :: String -> Int -> TypeScheme -> DsM Ident
 freshIdent prefix arity ty = do
   m <- getModuleIdent
-  x <- mkName prefix <$> getNextId
+  x <- freeIdent
   modifyValueEnv $ bindFun m x arity ty
   return x
-  where mkName pre n = mkIdent $ pre ++ show n
+  where
+  mkName pre n = mkIdent $ pre ++ show n
+  -- TODO: This loop is only necessary because a combination of desugaring,
+  -- simplification and a repeated desugaring, as currently needed for
+  -- non-linear and functional patterns, may reintroduce identifiers removed
+  -- during desugaring. The better solution would be to move the translation
+  -- of non-linear and functional pattern into a separate module.
+  freeIdent = do
+    x <- mkName prefix <$> getNextId
+    tyEnv <- getValueEnv
+    case lookupValue x tyEnv of
+      [] -> return x
+      _  -> freeIdent
 
 freshMonoTypeVar :: Typeable t => String -> t -> DsM Ident
 freshMonoTypeVar prefix t = getTypeOf t >>= \ ty ->
@@ -217,7 +226,7 @@ genForeignDecl p f = do
 
 dsDeclRhs :: Decl -> DsM Decl
 dsDeclRhs (FunctionDecl     p f eqs) = FunctionDecl p f <$> mapM dsEquation eqs
-dsDeclRhs (PatternDecl      p t rhs) = PatternDecl p t <$> dsRhs p id rhs
+dsDeclRhs (PatternDecl      p t rhs) = PatternDecl  p t <$> dsRhs p id rhs
 dsDeclRhs (ForeignDecl p cc ie f ty) = return $ ForeignDecl p cc ie' f ty
   where ie' = ie `mplus` Just (idName f)
 dsDeclRhs fs@(FreeDecl          _ _) = return fs
@@ -225,14 +234,15 @@ dsDeclRhs _ = error "Desugar.dsDeclRhs: no pattern match"
 
 dsEquation :: Equation -> DsM Equation
 dsEquation (Equation p lhs rhs) = do
-  (cs1     , ts1) <- dsNonLinearity             ts
-  funpats         <- desugarFunPats
-  (ds2, cs2, ts2) <- if funpats then dsFunctionalPatterns p ts1
-                                else return ([], [], ts1)
-  (ds3     , ts3) <- mapAccumM (dsPattern p) [] ts2
-  rhs'            <- dsRhs p (addConstraints (cs2 ++ cs1))
-                   $ addDecls (ds2 ++ ds3) $ rhs
-  return $ Equation p (FunLhs f ts3) rhs'
+  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 (dsPattern p) [] ts1
+  rhs'           <- dsRhs p (addConstraints cs) $ addDecls (ds1 ++ ds2) $ rhs
+  return $ Equation p (FunLhs f ts2) rhs'
   where (f, ts) = flatLhs lhs
 
 -- -----------------------------------------------------------------------------

src/Transformations/Lift.hs

@@ -11,12 +11,11 @@
 
    After desugaring and simplifying the code, the compiler lifts all local
    function declarations to the top-level keeping only local variable
-   declarations. The algorithm used here is similar to
-   Johnsson's. It consists of two phases, first we abstract each local
-   function declaration, adding its free variables as initial parameters
-   and update all calls to take these variables into account.
-   Then all local function declarations are collected and lifted to the
-   top-level.
+   declarations. The algorithm used here is similar to Johnsson's, consisting
+   of two phases. First, we abstract each local function declaration,
+   adding its free variables as initial parameters and update all calls
+   to take these variables into account. Second, all local function
+   declarations are collected and lifted to the top-level.
 -}
 {-# LANGUAGE CPP #-}
 module Transformations.Lift (lift) where
@@ -102,7 +101,7 @@ absEquation lvs (Equation p lhs@(FunLhs f ts) rhs) =
 absEquation _ _ = error "Lift.absEquation: no pattern match"
 
 absLhs :: Lhs -> LiftM Lhs
-absLhs (FunLhs f ts) = FunLhs f <$> mapM absPattern ts
+absLhs (FunLhs f ts) = FunLhs f <$> mapM absPat ts
 absLhs _             = error "Lift.absLhs: no simple LHS"
 
 absRhs :: String -> [Ident] -> Rhs -> LiftM Rhs
@@ -234,17 +233,17 @@ absExpr _   _   e                 = internalError $ "Lift.absExpr: " ++ show e
 absAlt :: String -> [Ident] -> Alt -> LiftM Alt
 absAlt pre lvs (Alt p t rhs) = Alt p t <$> absRhs pre (lvs ++ bv t) rhs
 
-absPattern :: Pattern -> LiftM Pattern
-absPattern v@(VariablePattern _) = return v
-absPattern l@(LiteralPattern  _) = return l
-absPattern (ConstructorPattern c ps) = ConstructorPattern c <$> mapM absPattern ps
-absPattern (AsPattern v p) = AsPattern v <$> absPattern p
-absPattern (FunctionPattern f ps) = do
+absPat :: Pattern -> LiftM Pattern
+absPat v@(VariablePattern     _) = return v
+absPat l@(LiteralPattern      _) = return l
+absPat (ConstructorPattern c ps) = ConstructorPattern c <$> mapM absPat ps
+absPat (AsPattern           v p) = AsPattern v <$> absPat p
+absPat (FunctionPattern    f ps) = do
   getAbstractEnv >>= \env -> case Map.lookup (unqualify f) env of
-    Nothing       -> FunctionPattern f  <$> mapM absPattern ps
+    Nothing       -> FunctionPattern f  <$> mapM absPat ps
     Just (f', vs) -> (FunctionPattern f' . (map VariablePattern vs ++))
-                     <$> mapM absPattern ps
-absPattern _ = error "Lift.absPattern"
+                     <$> mapM absPat ps
+absPat p = error $ "Lift.absPat: " ++ show p
 
 -- -----------------------------------------------------------------------------
 -- Lifting
@@ -327,5 +326,4 @@ varType tyEnv v = case lookupValue v tyEnv of
   _ -> internalError $ "Lift.varType: " ++ show v
 
 liftIdent :: String -> Ident -> Ident
-liftIdent prefix x = renameIdent (mkIdent $ prefix ++ showIdent x)
-                   $ idUnique x
+liftIdent prefix x = renameIdent (mkIdent $ prefix ++ showIdent x) $ idUnique x