Commit 1af263e7 authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

Moved expansion of alias types into auxiliary module

parent 87a3a2fd
......@@ -17,11 +17,13 @@ module Base.TypeSubst
import Data.List (nub)
import Base.Messages (internalError)
import Base.Subst
import Base.TopEnv
import Base.Types
import Env.Value (ValueInfo (..))
import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC)
import Env.Value (ValueInfo (..))
type TypeSubst = Subst Int Type
......@@ -62,6 +64,20 @@ instance SubstType ValueInfo where
instance SubstType a => SubstType (TopEnv a) where
subst = fmap . subst
-- Expand all type synonyms in a type
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
-- The function 'expandAliasType' expands all occurrences of a
-- type synonym in a type. After the expansion we have to reassign the
-- type indices for all type variables. Otherwise, expanding a type
......
......@@ -48,7 +48,7 @@ import Base.Messages (Message, posMessage, internalError)
import Base.SCC
import Base.TopEnv
import Base.Types
import Base.TypeSubst
import Base.TypeSubst hiding (expandType)
import Base.Utils (foldr2)
import Env.TypeConstructor (TCEnv, TypeInfo (..), bindTypeInfo, qualLookupTC)
......
......@@ -81,7 +81,7 @@ import Base.Expr
import Base.CurryTypes (toType, fromType)
import Base.Messages (internalError)
import Base.Types
import Base.TypeSubst (expandAliasType)
import Base.TypeSubst (expandType)
import Base.Typing
import Base.Utils (mapAccumM, concatMapM)
......@@ -1012,20 +1012,6 @@ instType (ForAllExist _ _ ty) = inst ty
inst (TypeArrow ty1 ty2) = TypeArrow (inst ty1) (inst ty2)
inst ty' = ty'
-- Expand all type synonyms in a type
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
-- Retrieve all constructors of a type
constructors :: QualIdent -> DsM [DataConstr]
constructors c = getTyConsEnv >>= \tcEnv -> return $
......
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