...
 
Commits (2)
......@@ -241,7 +241,9 @@ trTypeSynonym (CS.TypeDecl _ t tvs ty) = do
t' <- trQualIdent qid
vis <- getTypeVisibility qid
tEnv <- S.gets tcEnv
ty' <- trType (transType $ expandType m tEnv $ toType tvs ty)
ty' <- trType (transType tEnv $
expandType m tEnv $
toType tvs ty)
return [TypeSyn t' vis [0 .. length tvs - 1] ty']
trTypeSynonym _ = return []
......@@ -292,7 +294,12 @@ trType :: IL.Type -> FlatState TypeExpr
trType (IL.TypeConstructor t tys) = TCons <$> trQualIdent t <*> mapM trType tys
trType (IL.TypeVariable idx) = return $ TVar $ abs idx
trType (IL.TypeArrow ty1 ty2) = FuncType <$> trType ty1 <*> trType ty2
trType (IL.TypeForall idxs ty) = ForallType (map abs idxs) <$> trType ty
trType (IL.TypeForall idxs ty) = ForallType (map trVar idxs) <$> trType ty
where
trVar (i, k) = (abs i, trKind k)
trKind IL.KindStar = KStar
trKind (IL.KindVariable _) = KStar
trKind (IL.KindArrow k1 k2) = KArrow (trKind k1) (trKind k2)
-- Convert a fixity
cvFixity :: CS.Infix -> Fixity
......@@ -306,15 +313,14 @@ cvFixity CS.Infix = InfixOp
-- Translate a function declaration
trAFuncDecl :: IL.Decl -> FlatState [AFuncDecl TypeExpr]
trAFuncDecl (IL.FunctionDecl f vs _ e) = do
trAFuncDecl (IL.FunctionDecl f vs ty e) = do
f' <- trQualIdent f
a <- getArity f
vis <- getVisibility f
ty' <- trType ty
r' <- trARule ty vs e
return [AFunc f' a vis ty' r']
where ty = foldr IL.TypeArrow (IL.typeOf e) $ map fst vs
trAFuncDecl (IL.ExternalDecl f ty) = do
trAFuncDecl (IL.ExternalDecl f ty) = do
f' <- trQualIdent f
a <- getArity f
vis <- getVisibility f
......@@ -362,8 +368,8 @@ trAExpr (IL.Letrec bs e) = inNestedEnv $ do
ALet <$> trType (IL.typeOf e)
<*> (zip <$> mapM (uncurry newVar) vs <*> mapM trAExpr es)
<*> trAExpr e
trAExpr (IL.Typed e _) = ATyped <$> ty' <*> trAExpr e <*> ty'
where ty' = trType $ IL.typeOf e
trAExpr (IL.Typed e ty) = ATyped <$> ty' <*> trAExpr e <*> ty'
where ty' = trType $ ty
-- Translate a literal
trLiteral :: IL.Literal -> FlatState Literal
......@@ -450,6 +456,9 @@ type NormState a = S.State (Int, Map.Map Int Int) a
class Normalize a where
normalize :: a -> NormState a
instance Normalize a => Normalize [a] where
normalize = mapM normalize
instance Normalize Int where
normalize i = do
(n, m) <- S.get
......@@ -461,38 +470,40 @@ instance Normalize Int where
instance Normalize TypeExpr where
normalize (TVar i) = TVar <$> normalize i
normalize (TCons q tys) = TCons q <$> mapM normalize tys
normalize (TCons q tys) = TCons q <$> normalize tys
normalize (FuncType ty1 ty2) = FuncType <$> normalize ty1 <*> normalize ty2
normalize (ForallType is ty) =
ForallType <$> mapM normalize is <*> normalize ty
instance Normalize b => Normalize (a, b) where
normalize (x, y) = ((,) x) <$> normalize y
normalize (ForallType is ty) = ForallType <$> mapM normalizeTypeVar is
<*> normalize ty
where normalizeTypeVar (tv, k) = (,) <$> normalize tv <*> pure k
instance Normalize a => Normalize (AFuncDecl a) where
normalize (AFunc f a v ty r) = AFunc f a v <$> normalize ty <*> normalize r
instance Normalize a => Normalize (ARule a) where
normalize (ARule ty vs e) = ARule <$> normalize ty
<*> mapM normalize vs
<*> mapM normalizeTuple vs
<*> normalize e
normalize (AExternal ty s) = flip AExternal s <$> normalize ty
normalizeTuple :: Normalize b => (a, b) -> NormState (a, b)
normalizeTuple (a, b) = (,) <$> pure a <*> normalize b
instance Normalize a => Normalize (AExpr a) where
normalize (AVar ty v) = flip AVar v <$> normalize ty
normalize (ALit ty l) = flip ALit l <$> normalize ty
normalize (AComb ty ct f es) = flip AComb ct <$> normalize ty
<*> normalize f
<*> mapM normalize es
<*> normalizeTuple f
<*> normalize es
normalize (ALet ty ds e) = ALet <$> normalize ty
<*> mapM normalizeBinding ds
<*> normalize e
where normalizeBinding (v, b) = (,) <$> normalize v <*> normalize b
where normalizeBinding (v, b) = (,) <$> normalizeTuple v <*> normalize b
normalize (AOr ty a b) = AOr <$> normalize ty <*> normalize a
<*> normalize b
normalize (ACase ty ct e bs) = flip ACase ct <$> normalize ty <*> normalize e
<*> mapM normalize bs
normalize (AFree ty vs e) = AFree <$> normalize ty <*> mapM normalize vs
<*> normalize bs
normalize (AFree ty vs e) = AFree <$> normalize ty
<*> mapM normalizeTuple vs
<*> normalize e
normalize (ATyped ty e ty') = ATyped <$> normalize ty <*> normalize e
<*> normalize ty'
......@@ -501,8 +512,9 @@ instance Normalize a => Normalize (ABranchExpr a) where
normalize (ABranch p e) = ABranch <$> normalize p <*> normalize e
instance Normalize a => Normalize (APattern a) where
normalize (APattern ty c vs) = APattern <$> normalize ty <*> normalize c
<*> mapM normalize vs
normalize (APattern ty c vs) = APattern <$> normalize ty
<*> normalizeTuple c
<*> mapM normalizeTuple vs
normalize (ALPattern ty l) = flip ALPattern l <$> normalize ty
-- -----------------------------------------------------------------------------
......
......@@ -240,7 +240,9 @@ trTypeSynonym (CS.TypeDecl _ t tvs ty) = do
t' <- trQualIdent qid
vis <- getTypeVisibility qid
tEnv <- S.gets tcEnv
ty' <- trType (transType $ expandType m tEnv $ toType tvs ty)
ty' <- trType (transType tEnv $
expandType m tEnv $
toType tvs ty)
return [TypeSyn t' vis [0 .. length tvs - 1] ty']
trTypeSynonym _ = return []
......@@ -291,7 +293,12 @@ trType :: IL.Type -> FlatState TypeExpr
trType (IL.TypeConstructor t tys) = TCons <$> trQualIdent t <*> mapM trType tys
trType (IL.TypeVariable idx) = return $ TVar $ abs idx
trType (IL.TypeArrow ty1 ty2) = FuncType <$> trType ty1 <*> trType ty2
trType (IL.TypeForall idxs ty) = ForallType (map abs idxs) <$> trType ty
trType (IL.TypeForall idxs ty) = ForallType (map trVar idxs) <$> trType ty
where
trVar (i, k) = (abs i, trKind k)
trKind IL.KindStar = KStar
trKind (IL.KindVariable _) = KStar
trKind (IL.KindArrow k1 k2) = KArrow (trKind k1) (trKind k2)
-- Convert a fixity
cvFixity :: CS.Infix -> Fixity
......@@ -305,15 +312,14 @@ cvFixity CS.Infix = InfixOp
-- Translate a function declaration
trTFuncDecl :: IL.Decl -> FlatState [TFuncDecl]
trTFuncDecl (IL.FunctionDecl f vs _ e) = do
trTFuncDecl (IL.FunctionDecl f vs ty e) = do
f' <- trQualIdent f
a <- getArity f
vis <- getVisibility f
ty' <- trType ty
r' <- trTRule vs e
return [TFunc f' a vis ty' r']
where ty = foldr IL.TypeArrow (IL.typeOf e) $ map fst vs
trTFuncDecl (IL.ExternalDecl f ty) = do
trTFuncDecl (IL.ExternalDecl f ty) = do
f' <- trQualIdent f
a <- getArity f
vis <- getVisibility f
......@@ -357,8 +363,8 @@ trTExpr (IL.Letrec bs e) = inNestedEnv $ do
let (vs, es) = unzip [ ((IL.typeOf b, v), b) | IL.Binding v b <- bs]
TLet <$> (zip <$> mapM (uncurry newVar) vs <*> mapM trTExpr es)
<*> trTExpr e
trTExpr (IL.Typed e _) = TTyped <$> trTExpr e <*> ty'
where ty' = trType $ IL.typeOf e
trTExpr (IL.Typed e ty) = TTyped <$> trTExpr e <*> ty'
where ty' = trType $ ty
-- Translate a literal
trLiteral :: IL.Literal -> FlatState Literal
......@@ -446,6 +452,9 @@ type NormState a = S.State (Int, Map.Map Int Int) a
class Normalize a where
normalize :: a -> NormState a
instance Normalize a => Normalize [a] where
normalize = mapM normalize
instance Normalize Int where
normalize i = do
(n, m) <- S.get
......@@ -457,36 +466,37 @@ instance Normalize Int where
instance Normalize TypeExpr where
normalize (TVar i) = TVar <$> normalize i
normalize (TCons q tys) = TCons q <$> mapM normalize tys
normalize (TCons q tys) = TCons q <$> normalize tys
normalize (FuncType ty1 ty2) = FuncType <$> normalize ty1 <*> normalize ty2
normalize (ForallType is ty) =
ForallType <$> mapM normalize is <*> normalize ty
instance Normalize b => Normalize (a, b) where
normalize (x, y) = (,) x <$> normalize y
normalize (ForallType is ty) = ForallType <$> mapM normalizeTypeVar is
<*> normalize ty
where normalizeTypeVar (tv, k) = (,) <$> normalize tv <*> pure k
instance Normalize TFuncDecl where
normalize (TFunc f a v ty r) = TFunc f a v <$> normalize ty <*> normalize r
instance Normalize TRule where
normalize (TRule vs e) = TRule <$> mapM normalize vs
normalize (TRule vs e) = TRule <$> mapM normalizeVar vs
<*> normalize e
normalize (TExternal ty s) = flip TExternal s <$> normalize ty
normalizeVar :: (VarIndex, TypeExpr) -> NormState (VarIndex, TypeExpr)
normalizeVar (v, ty) = (,) <$> pure v <*> normalize ty
instance Normalize TExpr where
normalize (TVarE ty v) = flip TVarE v <$> normalize ty
normalize (TLit ty l) = flip TLit l <$> normalize ty
normalize (TComb ty ct f es) = flip TComb ct <$> normalize ty
<*> pure f
<*> mapM normalize es
<*> normalize es
normalize (TLet ds e) = TLet <$> mapM normalizeBinding ds
<*> normalize e
where normalizeBinding (v, b) = (,) <$> normalize v <*> normalize b
where normalizeBinding (v, b) = (,) <$> normalizeVar v <*> normalize b
normalize (TOr a b) = TOr <$> normalize a
<*> normalize b
normalize (TCase ct e bs) = TCase ct <$> normalize e
<*> mapM normalize bs
normalize (TFree vs e) = TFree <$> mapM normalize vs
<*> normalize bs
normalize (TFree vs e) = TFree <$> mapM normalizeVar vs
<*> normalize e
normalize (TTyped e ty') = TTyped <$> normalize e
<*> normalize ty'
......@@ -497,7 +507,7 @@ instance Normalize TBranchExpr where
instance Normalize TPattern where
normalize (TPattern ty c vs) = TPattern <$> normalize ty
<*> pure c
<*> mapM normalize vs
<*> mapM normalizeVar vs
normalize (TLPattern ty l) = flip TLPattern l <$> normalize ty
-- -----------------------------------------------------------------------------
......
......@@ -104,10 +104,10 @@ ppTypeVar n
| n >= 0 = text (typeVars !! n)
| otherwise = text ('_':show (-n))
ppQuantifiedTypeVars :: [Int] -> Doc
ppQuantifiedTypeVars :: [(Int, Kind)] -> Doc
ppQuantifiedTypeVars ns
| null ns = empty
| otherwise = text "forall" <+> hsep (map ppTypeVar ns) <+> char '.'
| otherwise = text "forall" <+> hsep (map (ppTypeVar . fst) ns) <> char '.'
ppBinding :: Binding -> Doc
ppBinding (Binding v expr) = sep
......
......@@ -44,7 +44,7 @@
module IL.Type
( -- * Data types
Module (..), Decl (..), ConstrDecl (..), NewConstrDecl (..), Type (..)
, Literal (..), ConstrTerm (..), Expression (..), Eval (..)
, Kind (..), Literal (..), ConstrTerm (..), Expression (..), Eval (..)
, Alt (..), Binding (..)
) where
......@@ -73,9 +73,15 @@ data Type
= TypeConstructor QualIdent [Type]
| TypeVariable Int
| TypeArrow Type Type
| TypeForall [Int] Type
| TypeForall [(Int, Kind)] Type
deriving (Eq, Show)
data Kind
= KindStar
| KindVariable Int
| KindArrow Kind Kind
deriving (Eq, Ord, Show)
data Literal
= Char Char
| Int Integer
......
......@@ -26,6 +26,8 @@ import Transformations.Newtypes as NT (removeNewtypes)
import Transformations.Qual as Q (qual)
import Transformations.Simplify as S (simplify)
import Env.TypeConstructor
import CompilerEnv
import Imports (qualifyEnv)
import qualified IL
......@@ -75,12 +77,12 @@ lift (env, mdl) = (env { valueEnv = tyEnv' }, mdl')
-- |Translate into the intermediate language
ilTrans :: Bool -> CompEnv (Module Type) -> CompEnv IL.Module
ilTrans remIm (env, mdl) = (env, il)
where il = IL.ilTrans remIm (valueEnv env) mdl
where il = IL.ilTrans remIm (valueEnv env) (tyConsEnv env) mdl
-- |Translate a type into its representation in the intermediate language
transType :: Type -> IL.Type
transType :: TCEnv -> Type -> IL.Type
transType = IL.transType
-- |Add missing case branches
completeCase :: CompEnv IL.Module -> CompEnv IL.Module
completeCase (env, mdl) = (env, CC.completeCase (interfaceEnv env) mdl)
completeCase (env, mdl) =
(env, CC.completeCase (interfaceEnv env) (tyConsEnv env) mdl)
......@@ -50,6 +50,7 @@ import Base.Types ( boolType, charType, floatType
)
import Base.Subst
import Env.TypeConstructor
import Env.Interface (InterfaceEnv, lookupInterface)
import Transformations.CurryToIL (transType)
......@@ -59,9 +60,9 @@ import IL
-- Completes case expressions by adding branches for missing constructors.
-- The interface environment 'iEnv' is needed to compute these constructors.
completeCase :: InterfaceEnv -> Module -> Module
completeCase iEnv mdl@(Module mid is ds) = Module mid is ds'
where ds'= S.evalState (mapM ccDecl ds) (CCState mdl iEnv 0)
completeCase :: InterfaceEnv -> TCEnv -> Module -> Module
completeCase iEnv tcEnv mdl@(Module mid is ds) = Module mid is ds'
where ds'= S.evalState (mapM ccDecl ds) (CCState mdl iEnv 0 tcEnv )
-- -----------------------------------------------------------------------------
-- Internally used state monad
......@@ -71,6 +72,7 @@ data CCState = CCState
{ modul :: Module
, interfaceEnv :: InterfaceEnv
, nextId :: Int
, tyconEnv :: TCEnv
}
type CCM a = S.State CCState a
......@@ -78,6 +80,9 @@ type CCM a = S.State CCState a
getModule :: CCM Module
getModule = S.gets modul
getTCEnv :: CCM TCEnv
getTCEnv = S.gets tyconEnv
getInterfaceEnv :: CCM InterfaceEnv
getInterfaceEnv = S.gets interfaceEnv
......@@ -166,8 +171,9 @@ completeConsAlts :: Eval -> Expression -> [Alt] -> CCM Expression
completeConsAlts ea ce alts = do
mdl <- getModule
menv <- getInterfaceEnv
tcEnv <- getTCEnv
-- complementary constructor patterns
complPats <- mapM genPat $ getComplConstrs mdl menv
complPats <- mapM genPat $ getComplConstrs mdl menv tcEnv
[ c | (Alt (ConstructorPattern _ c _) _) <- consAlts ]
v <- freshIdent
w <- freshIdent
......@@ -325,7 +331,12 @@ eqExpr e1 e2 = Apply (Apply (Function eqTy eq 2) e1) e2
Int _ -> intType
Float _ -> floatType
_ -> internalError "CaseCompletion.eqExpr: no literal"
ty' = transType ty
ty' = case e2 of
Literal _ l -> case l of
Char _ -> charType'
Int _ -> intType'
Float _ -> floatType'
_ -> internalError "CaseCompletion.eqExpr: no literal"
eqTy = TypeArrow ty' (TypeArrow ty' boolType')
truePatt :: ConstrTerm
......@@ -335,7 +346,16 @@ falsePatt :: ConstrTerm
falsePatt = ConstructorPattern boolType' qFalseId []
boolType' :: Type
boolType' = transType boolType
boolType' = IL.TypeConstructor qBoolId []
charType' :: Type
charType' = IL.TypeConstructor qCharId []
intType' :: Type
intType' = IL.TypeConstructor qIntId []
floatType' :: Type
floatType' = IL.TypeConstructor qFloatId []
-- ---------------------------------------------------------------------------
-- The following functions compute the missing constructors for generating
......@@ -346,17 +366,20 @@ boolType' = transType boolType
-- This functions uses the module environment 'menv', which contains all
-- imported constructors, except for the built-in list constructors.
-- TODO: Check if the list constructors are in the menv.
getComplConstrs :: Module -> InterfaceEnv -> [QualIdent] -> [(QualIdent, [Type])]
getComplConstrs _ _ []
getComplConstrs :: Module -> InterfaceEnv -> TCEnv
-> [QualIdent] -> [(QualIdent, [Type])]
getComplConstrs _ _ _ []
= internalError "CaseCompletion.getComplConstrs: empty constructor list"
getComplConstrs (Module mid _ ds) menv cs@(c:_)
getComplConstrs (Module mid _ ds) menv tcEnv cs@(c:_)
-- built-in lists
| c `elem` [qNilId, qConsId] = complementary cs
[(qNilId, []), (qConsId, [TypeVariable 0, transType (listType boolType)])]
[ (qNilId, [])
, (qConsId, [TypeVariable 0, transType tcEnv (listType boolType)])
]
-- current module
| mid' == mid = getCCFromDecls cs ds
-- imported module
| otherwise = maybe [] (getCCFromIDecls mid' cs)
| otherwise = maybe [] (getCCFromIDecls mid' cs tcEnv)
(lookupInterface mid' menv)
where mid' = fromMaybe mid (qidModule c)
......@@ -380,9 +403,9 @@ getCCFromDecls cs ds = complementary cs cinfos
constrInfo (ConstrDecl cid tys) = (cid, tys)
-- Find complementary constructors within the module environment
getCCFromIDecls :: ModuleIdent -> [QualIdent] -> CS.Interface
getCCFromIDecls :: ModuleIdent -> [QualIdent] -> TCEnv-> CS.Interface
-> [(QualIdent, [Type])]
getCCFromIDecls mid cs (CS.Interface _ _ ds) = complementary cs cinfos
getCCFromIDecls mid cs tcEnv (CS.Interface _ _ ds) = complementary cs cinfos
where
cinfos = map (uncurry constrInfo)
$ maybe [] extractConstrDecls (find (`declares` head cs) ds)
......@@ -411,7 +434,7 @@ getCCFromIDecls mid cs (CS.Interface _ _ ds) = complementary cs cinfos
, [transType' vs ty | CS.FieldDecl _ ls ty <- fs, _ <- ls]
)
transType' vs = transType . toType vs
transType' vs = transType tcEnv . toType vs
-- Compute complementary constructors
complementary :: [QualIdent] -> [(QualIdent, [Type])] -> [(QualIdent, [Type])]
......@@ -431,10 +454,11 @@ instance SubstType a => SubstType [a] where
instance SubstType Type where
subst sigma (TypeConstructor q tys) = TypeConstructor q $ subst sigma tys
subst sigma (TypeVariable tv) = substVar' TypeVariable subst sigma tv
subst sigma (TypeArrow ty1 ty2) = TypeArrow (subst sigma ty1) (subst sigma ty2)
subst _ (TypeForall _ _) =
internalError "Transformations.CaseCompletion.SubstType.Type.subst"
subst sigma (TypeVariable tv) = substVar' TypeVariable subst sigma tv
subst sigma (TypeArrow ty1 ty2)
= TypeArrow (subst sigma ty1) (subst sigma ty2)
subst sigma (TypeForall tvs ty)
= TypeForall tvs (subst (foldr (unbindSubst . fst) sigma tvs) ty)
matchType :: Type -> Type -> TypeSubst -> TypeSubst
matchType ty1 ty2 = fromMaybe noMatch (matchType' ty1 ty2)
......
This diff is collapsed.