From 2b3d21df41c4cd006af1ec4ca47a52b3abd2f2ec Mon Sep 17 00:00:00 2001
From: Jan Tikovsky <jrt@informatik.uni-kiel.de>
Date: Thu, 7 Aug 2014 15:55:31 +0200
Subject: [PATCH] Type synonyms in typed expressions are now desugared - fixes
 #921

---
 CHANGELOG.md                   |  2 ++
 src/Transformations/Desugar.hs | 28 +++++++++++++++++++++++++---
 test/TypedExpr.curry           |  8 ++++++--
 3 files changed, 33 insertions(+), 5 deletions(-)

diff --git a/CHANGELOG.md b/CHANGELOG.md
index f45deb0d..1bdae0ee 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -4,6 +4,8 @@ Change log for curry-frontend
 Under development
 =================
 
+ * Type synonyms in typed expressions are now desugared - fixes #921
+
   * Declaration of operator precedence is now optional in infix operator
     declarations
 
diff --git a/src/Transformations/Desugar.hs b/src/Transformations/Desugar.hs
index 0d668a28..c5c658cc 100644
--- a/src/Transformations/Desugar.hs
+++ b/src/Transformations/Desugar.hs
@@ -76,9 +76,10 @@ import Curry.Base.Position hiding (first)
 import Curry.Syntax
 
 import Base.Expr
-import Base.CurryTypes (fromType)
+import Base.CurryTypes (toType, fromType)
 import Base.Messages (internalError)
 import Base.Types
+import Base.TypeSubst (expandAliasType)
 import Base.Typing
 import Base.Utils (mapAccumM, concatMapM)
 
@@ -158,7 +159,7 @@ freshMonoTypeVar prefix t = getTypeOf t >>= \ ty ->
 
 desugar :: [KnownExtension] -> ValueEnv -> TCEnv -> Module
         -> (Module, ValueEnv)
-desugar xs tyEnv tcEnv (Module ps m es is ds) 
+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)
@@ -425,7 +426,7 @@ dsExpr _ var@(Variable v)
   | otherwise              = return var
 dsExpr _ c@(Constructor _) = return c
 dsExpr p (Paren         e) = dsExpr p e
-dsExpr p (Typed      e ty) = flip Typed ty `liftM` dsExpr p e
+dsExpr p (Typed      e ty) = liftM2 Typed (dsExpr p e) (dsTypeExpr ty)
 dsExpr p (Tuple    pos es) =
   apply (Constructor $ tupleConstr es) `liftM` mapM (dsExpr p) es
   where tupleConstr es1 = addRef pos $ if null es1 then qUnitId else qTupleId (length es1)
@@ -519,6 +520,27 @@ dsExpr p (RecordUpdate fs rexpr)
     r <- recordFromField (fieldLabel (head fs))
     dsRecordUpdate p r rexpr (map field2Tuple fs)
 
+dsTypeExpr :: TypeExpr -> DsM TypeExpr
+dsTypeExpr ty = do
+  tcEnv <- getTyConsEnv
+  let expType = expandType tcEnv (toType [] ty)
+  return $ fromType expType
+
+expandType :: TCEnv -> Type -> Type
+expandType tcEnv (TypeConstructor tc tys) = case qualLookupTC tc tcEnv of
+  [DataType     tc' _  _] -> TypeConstructor tc' tys'
+  [RenamingType tc' _  _] -> TypeConstructor tc' tys'
+  [AliasType    _   _ ty] -> expandAliasType tys' ty
+  _ -> internalError $ "Desugar.expandType " ++ show tc
+  where tys' = map (expandType tcEnv) tys
+expandType _     tv@(TypeVariable      _) = tv
+expandType _     tc@(TypeConstrained _ _) = tc
+expandType tcEnv (TypeArrow      ty1 ty2) =
+  TypeArrow (expandType tcEnv ty1) (expandType tcEnv ty2)
+expandType _     ts@(TypeSkolem        _) = ts
+expandType tcEnv (TypeRecord       fs rv) =
+  TypeRecord (map (\ (l, ty) -> (l, expandType tcEnv ty)) fs) rv
+
 -- If an alternative in a case expression has boolean guards and all of
 -- these guards return 'False', the enclosing case expression does
 -- not fail but continues to match the remaining alternatives against the
diff --git a/test/TypedExpr.curry b/test/TypedExpr.curry
index bda70a0f..aea0c924 100644
--- a/test/TypedExpr.curry
+++ b/test/TypedExpr.curry
@@ -1,2 +1,6 @@
-s :: String
-s = "hallo" :: String
+test1 :: String
+test1 = "hallo" :: String
+
+test2 = ["hallo","welt"] :: [String]
+
+test3 = (False, test2) :: (Bool, [String])
\ No newline at end of file
-- 
GitLab