Commit ca1d26cc authored by Finn Teegen's avatar Finn Teegen

Merge branch 'typevars-with-kinds' into 'master'

Add Kind information to explicitly bound type variables

See merge request !20
parents 0ed232cc e5524712
......@@ -242,7 +242,9 @@ trTypeSynonym (CS.TypeDecl _ t tvs ty) = do
t' <- trQualIdent qid
vis <- getTypeVisibility qid
tEnv <- S.gets tcEnv
ty' <- trType (transType $ expandType m tEnv initClassEnv $ toType tvs ty)
ty' <- trType (transType tEnv $
expandType m tEnv initClassEnv $
toType tvs ty)
return [TypeSyn t' vis [0 .. length tvs - 1] ty']
trTypeSynonym _ = return []
......@@ -293,7 +295,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
......@@ -307,15 +314,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
......@@ -363,8 +369,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
......@@ -467,8 +473,17 @@ instance Normalize TypeExpr where
normalize (ForallType is ty) =
ForallType <$> mapM normalize is <*> normalize ty
instance Normalize b => Normalize (a, b) where
normalize (x, y) = ((,) x) <$> normalize y
instance (Normalize a, Normalize b) => Normalize (a, b) where
normalize (x, y) = (,) <$> normalize x <*> normalize y
instance Normalize a => Normalize [a] where
normalize = mapM normalize
instance Normalize Char where
normalize = return
instance Normalize Kind where
normalize = return
instance Normalize a => Normalize (AFuncDecl a) where
normalize (AFunc f a v ty r) = AFunc f a v <$> normalize ty <*> normalize r
......
......@@ -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 initClassEnv $ toType tvs ty)
ty' <- trType (transType tEnv $
expandType m tEnv initClassEnv $
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
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
......@@ -358,8 +364,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
......@@ -463,8 +469,17 @@ instance Normalize TypeExpr where
normalize (ForallType is ty) =
ForallType <$> mapM normalize is <*> normalize ty
instance Normalize b => Normalize (a, b) where
normalize (x, y) = (,) x <$> normalize y
instance (Normalize a, Normalize b) => Normalize (a, b) where
normalize (x, y) = (,) <$> normalize x <*> normalize y
instance Normalize a => Normalize [a] where
normalize = mapM normalize
instance Normalize Char where
normalize = return
instance Normalize Kind where
normalize = return
instance Normalize TFuncDecl where
normalize (TFunc f a v ty r) = TFunc f a v <$> normalize ty <*> normalize r
......
......@@ -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])]
......@@ -435,7 +458,7 @@ instance SubstType Type where
subst sigma (TypeArrow ty1 ty2)
= TypeArrow (subst sigma ty1) (subst sigma ty2)
subst sigma (TypeForall tvs ty)
= TypeForall tvs (subst (foldr unbindSubst sigma 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.
......@@ -22,6 +22,12 @@ idFun' x = id x
idFun'' :: (forall b. Eq b => b) -> forall c. Ord c => c
idFun'' = idFun
idFun'''' :: (forall b . b) a -> (forall b . b) a
idFun'''' x = x
shadow :: forall a m . ((forall a . a m) -> a -> Int)
shadow _ _= 1
idBool :: Bool -> Bool
idBool = id
......
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