module Env.TypeConstructor
( TCEnv, TypeInfo (..), initTCEnv, tcArity, bindTypeInfo
, lookupTC, qualLookupTC, qualLookupTCUnique
, TypeEnv, TypeKind (..), typeKind
) where
import Curry.Base.Ident
import Base.Messages (internalError)
import Base.TopEnv
import Base.Types
import Base.Utils ((++!))
data TypeInfo
= DataType QualIdent Int [DataConstr]
| RenamingType QualIdent Int DataConstr
| AliasType QualIdent Int Type
deriving Show
instance Entity TypeInfo where
origName (DataType tc _ _) = tc
origName (RenamingType tc _ _) = tc
origName (AliasType tc _ _) = tc
merge (DataType tc n cs) (DataType tc' _ cs')
| tc == tc' && (null cs || null cs' || cs == cs') =
Just $ DataType tc n (if null cs then cs' else cs)
merge (DataType tc n _) (RenamingType tc' _ nc)
| tc == tc' = Just (RenamingType tc n nc)
merge l@(RenamingType tc _ _) (DataType tc' _ _)
| tc == tc' = Just l
merge l@(RenamingType tc _ _) (RenamingType tc' _ _)
| tc == tc' = Just l
merge l@(AliasType tc _ _) (AliasType tc' _ _)
| tc == tc' = Just l
merge _ _ = Nothing
tcArity :: TypeInfo -> Int
tcArity (DataType _ n _) = n
tcArity (RenamingType _ n _) = n
tcArity (AliasType _ n _) = n
type TCEnv = TopEnv TypeInfo
bindTypeInfo :: (QualIdent -> Int -> a -> TypeInfo) -> ModuleIdent
-> Ident -> [Ident] -> a -> TCEnv -> TCEnv
bindTypeInfo f m tc tvs x = bindTopEnv tc ty . qualBindTopEnv qtc ty
where qtc = qualifyWith m tc
ty = f qtc (length tvs) x
lookupTC :: Ident -> TCEnv -> [TypeInfo]
lookupTC tc tcEnv = lookupTopEnv tc tcEnv ++! lookupTupleTC tc
qualLookupTC :: QualIdent -> TCEnv -> [TypeInfo]
qualLookupTC tc tcEnv = qualLookupTopEnv tc tcEnv
++! lookupTupleTC (unqualify tc)
qualLookupTCUnique :: ModuleIdent -> QualIdent -> TCEnv -> [TypeInfo]
qualLookupTCUnique m x tyEnv = case qualLookupTC x tyEnv of
[] -> []
[t] -> [t]
ts -> case qualLookupTC (qualQualify m x) tyEnv of
[] -> ts
[t] -> [t]
qts -> qts
lookupTupleTC :: Ident -> [TypeInfo]
lookupTupleTC tc | isTupleId tc = [tupleTCs !! (tupleArity tc 2)]
| otherwise = []
tupleTCs :: [TypeInfo]
tupleTCs = map typeInfo tupleData
where typeInfo dc@(DataConstr _ n _) = DataType (qTupleId n) n [dc]
typeInfo (RecordConstr _ _ _ _) =
internalError $ "Env.TypeConstructor.tupleTCs: " ++ show tupleData
initTCEnv :: TCEnv
initTCEnv = foldr (uncurry predefTC) emptyTopEnv predefTypes
where
predefTC (TypeConstructor tc tys) = predefTopEnv tc
. DataType tc (length tys)
predefTC _ = internalError "Base.initTCEnv.predefTC: no type constructor"
type TypeEnv = TopEnv TypeKind
data TypeKind
= Data QualIdent [Ident]
| Alias QualIdent
deriving (Eq, Show)
typeKind :: TypeInfo -> TypeKind
typeKind (DataType tc _ cs) = Data tc (map constrIdent cs)
typeKind (RenamingType tc _ nc) = Data tc [constrIdent nc]
typeKind (AliasType tc _ _) = Alias tc
instance Entity TypeKind where
origName (Data tc _) = tc
origName (Alias tc) = tc