Commit 2b3d21df authored by Jan Rasmus Tikovsky 's avatar Jan Rasmus Tikovsky

Type synonyms in typed expressions are now desugared - fixes #921

parent 41f56b93
...@@ -4,6 +4,8 @@ Change log for curry-frontend ...@@ -4,6 +4,8 @@ Change log for curry-frontend
Under development Under development
================= =================
* Type synonyms in typed expressions are now desugared - fixes #921
* Declaration of operator precedence is now optional in infix operator * Declaration of operator precedence is now optional in infix operator
declarations declarations
......
...@@ -76,9 +76,10 @@ import Curry.Base.Position hiding (first) ...@@ -76,9 +76,10 @@ import Curry.Base.Position hiding (first)
import Curry.Syntax import Curry.Syntax
import Base.Expr import Base.Expr
import Base.CurryTypes (fromType) import Base.CurryTypes (toType, fromType)
import Base.Messages (internalError) import Base.Messages (internalError)
import Base.Types import Base.Types
import Base.TypeSubst (expandAliasType)
import Base.Typing import Base.Typing
import Base.Utils (mapAccumM, concatMapM) import Base.Utils (mapAccumM, concatMapM)
...@@ -158,7 +159,7 @@ freshMonoTypeVar prefix t = getTypeOf t >>= \ ty -> ...@@ -158,7 +159,7 @@ freshMonoTypeVar prefix t = getTypeOf t >>= \ ty ->
desugar :: [KnownExtension] -> ValueEnv -> TCEnv -> Module desugar :: [KnownExtension] -> ValueEnv -> TCEnv -> Module
-> (Module, ValueEnv) -> (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') = (Module ps m es is ds', valueEnv s')
where (ds', s') = S.runState (desugarModuleDecls ds) where (ds', s') = S.runState (desugarModuleDecls ds)
(DesugarState m xs tcEnv tyEnv 1) (DesugarState m xs tcEnv tyEnv 1)
...@@ -425,7 +426,7 @@ dsExpr _ var@(Variable v) ...@@ -425,7 +426,7 @@ dsExpr _ var@(Variable v)
| otherwise = return var | otherwise = return var
dsExpr _ c@(Constructor _) = return c dsExpr _ c@(Constructor _) = return c
dsExpr p (Paren e) = dsExpr p e 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) = dsExpr p (Tuple pos es) =
apply (Constructor $ tupleConstr es) `liftM` mapM (dsExpr p) es apply (Constructor $ tupleConstr es) `liftM` mapM (dsExpr p) es
where tupleConstr es1 = addRef pos $ if null es1 then qUnitId else qTupleId (length es1) where tupleConstr es1 = addRef pos $ if null es1 then qUnitId else qTupleId (length es1)
...@@ -519,6 +520,27 @@ dsExpr p (RecordUpdate fs rexpr) ...@@ -519,6 +520,27 @@ dsExpr p (RecordUpdate fs rexpr)
r <- recordFromField (fieldLabel (head fs)) r <- recordFromField (fieldLabel (head fs))
dsRecordUpdate p r rexpr (map field2Tuple 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 -- If an alternative in a case expression has boolean guards and all of
-- these guards return 'False', the enclosing case expression does -- these guards return 'False', the enclosing case expression does
-- not fail but continues to match the remaining alternatives against the -- not fail but continues to match the remaining alternatives against the
......
s :: String test1 :: String
s = "hallo" :: String test1 = "hallo" :: String
test2 = ["hallo","welt"] :: [String]
test3 = (False, test2) :: (Bool, [String])
\ No newline at end of file
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