curry-frontend-2.0.0: src/Env/TypeConstructor.hs
{- |
Module : $Header$
Description : Environment of type constructors
Copyright : (c) 2002 - 2004 Wolfgang Lux
2011 Björn Peemöller
2016 Finn Teegen
License : BSD-3-clause
Maintainer : bjp@informatik.uni-kiel.de
Stability : experimental
Portability : portable
For all defined types the compiler must maintain kind information.
For algebraic data types and renaming types the compiler also records
all data constructors belonging to that type, for alias types the
type expression to be expanded is saved. Futhermore, recording the
arity is necessary for alias types because the right hand side, i.e.,
the type expression, can have arbitrary kind and therefore the type
alias' arity cannot be determined from its own kind. For instance,
the type alias type List = [] has the kind * -> *, but its arity is 0.
In order to manage the import and export of types, the names of the
original definitions are also recorded. On import two types are
considered equal if their original names match.
The information for a data constructor comprises the number of
existentially quantified type variables, the context and the list
of the argument types. Note that renaming type constructors have only
one type argument.
For type classes the all their methods are saved. Type classes are
recorded in the type constructor environment because type constructors
and type classes share a common name space.
For type variables only their kind is recorded in the environment.
Importing and exporting algebraic data types and renaming types is
complicated by the fact that the constructors of the type may be
(partially) hidden in the interface. This facilitates the definition
of abstract data types. An abstract type is always represented as a
data type without constructors in the interface regardless of whether
it is defined as a data type or as a renaming type. When only some
constructors of a data type are hidden, those constructors are
replaced by underscores in the interface. Furthermore, if the
right-most constructors of a data type are hidden, they are not
exported at all in order to make the interface more stable against
changes which are private to the module.
-}
{-# LANGUAGE CPP #-}
module Env.TypeConstructor
( TypeInfo (..), tcKind, clsKind, varKind, clsMethods
, TCEnv, initTCEnv, bindTypeInfo, rebindTypeInfo
, lookupTypeInfo, qualLookupTypeInfo, qualLookupTypeInfoUnique
, getOrigName, reverseLookupByOrigName
) where
#if __GLASGOW_HASKELL__ >= 804
import Prelude hiding ((<>))
#endif
import Curry.Base.Ident
import Curry.Base.Pretty (Pretty(..), blankLine)
import Base.Kinds
import Base.Messages (internalError)
import Base.PrettyKinds ()
import Base.PrettyTypes ()
import Base.TopEnv
import Base.Types
import Base.Utils ((++!))
import Text.PrettyPrint
data TypeInfo
= DataType QualIdent Kind [DataConstr]
| RenamingType QualIdent Kind DataConstr
| AliasType QualIdent Kind Int Type
| TypeClass QualIdent Kind [ClassMethod]
| TypeVar Kind
deriving Show
instance Entity TypeInfo where
origName (DataType tc _ _) = tc
origName (RenamingType tc _ _) = tc
origName (AliasType tc _ _ _) = tc
origName (TypeClass cls _ _) = cls
origName (TypeVar _) =
internalError "Env.TypeConstructor.origName: type variable"
merge (DataType tc k cs) (DataType tc' k' cs')
| tc == tc' && k == k' && (null cs || null cs' || cs == cs') =
Just $ DataType tc k $ if null cs then cs' else cs
merge (DataType tc k _) (RenamingType tc' k' nc)
| tc == tc' && k == k' = Just (RenamingType tc k nc)
merge l@(RenamingType tc k _) (DataType tc' k' _)
| tc == tc' && k == k' = Just l
merge l@(RenamingType tc k _) (RenamingType tc' k' _)
| tc == tc' && k == k' = Just l
merge l@(AliasType tc k _ _) (AliasType tc' k' _ _)
| tc == tc' && k == k' = Just l
merge (TypeClass cls k ms) (TypeClass cls' k' ms')
| cls == cls' && k == k' && (null ms || null ms' || ms == ms') =
Just $ TypeClass cls k $ if null ms then ms' else ms
merge _ _ = Nothing
instance Pretty TypeInfo where
pPrint (DataType qid k cs) = text "data" <+> pPrint qid
<> text "/" <> pPrint k
<+> equals
<+> hsep (punctuate (text "|") (map pPrint cs))
pPrint (RenamingType qid k c) = text "newtype" <+> pPrint qid
<> text "/" <> pPrint k
<+> equals <+> pPrint c
pPrint (AliasType qid k ar ty)= text "type" <+> pPrint qid
<> text "/" <> pPrint k <> text "/" <> int ar
<+> equals <+> pPrint ty
pPrint (TypeClass qid k ms) = text "class" <+> pPrint qid
<> text "/" <> pPrint k
<+> equals
<+> vcat (blankLine : map pPrint ms)
pPrint (TypeVar _) =
internalError $ "Env.TypeConstructor.Pretty.TypeInfo.pPrint: type variable"
tcKind :: ModuleIdent -> QualIdent -> TCEnv -> Kind
tcKind m tc tcEnv = case qualLookupTypeInfo tc tcEnv of
[DataType _ k _] -> k
[RenamingType _ k _] -> k
[AliasType _ k _ _] -> k
_ -> case qualLookupTypeInfo (qualQualify m tc) tcEnv of
[DataType _ k _] -> k
[RenamingType _ k _] -> k
[AliasType _ k _ _] -> k
_ -> internalError $
"Env.TypeConstructor.tcKind: no type constructor: " ++ show tc
clsKind :: ModuleIdent -> QualIdent -> TCEnv -> Kind
clsKind m cls tcEnv = case qualLookupTypeInfo cls tcEnv of
[TypeClass _ k _] -> k
_ -> case qualLookupTypeInfo (qualQualify m cls) tcEnv of
[TypeClass _ k _] -> k
_ -> internalError $
"Env.TypeConstructor.clsKind: no type class: " ++ show cls
varKind :: Ident -> TCEnv -> Kind
varKind tv tcEnv
| isAnonId tv = KindStar
| otherwise = case lookupTypeInfo tv tcEnv of
[TypeVar k] -> k
_ -> internalError "Env.TypeConstructor.varKind: no type variable"
clsMethods :: ModuleIdent -> QualIdent -> TCEnv -> [Ident]
clsMethods m cls tcEnv = case qualLookupTypeInfo cls tcEnv of
[TypeClass _ _ ms] -> map methodName ms
_ -> case qualLookupTypeInfo (qualQualify m cls) tcEnv of
[TypeClass _ _ ms] -> map methodName ms
_ -> internalError $ "Env.TypeConstructor.clsMethods: " ++ show cls
-- Types can only be defined on the top-level; no nested environments are
-- needed for them. Tuple types must be handled as a special case because
-- there is an infinite number of potential tuple types making it
-- impossible to insert them into the environment in advance.
type TCEnv = TopEnv TypeInfo
initTCEnv :: TCEnv
initTCEnv = foldr (uncurry $ predefTC . unapplyType False) emptyTopEnv predefTypes
where
predefTC (TypeConstructor tc, tys) =
predefTopEnv tc . DataType tc (simpleKind $ length tys)
predefTC _ =
internalError "Env.TypeConstructor.initTCEnv.predefTC: no type constructor"
bindTypeInfo :: ModuleIdent -> Ident -> TypeInfo -> TCEnv -> TCEnv
bindTypeInfo m ident ti = bindTopEnv ident ti . qualBindTopEnv qident ti
where
qident = qualifyWith m ident
rebindTypeInfo :: ModuleIdent -> Ident -> TypeInfo -> TCEnv -> TCEnv
rebindTypeInfo m ident ti = rebindTopEnv ident ti . qualRebindTopEnv qident ti
where
qident = qualifyWith m ident
lookupTypeInfo :: Ident -> TCEnv -> [TypeInfo]
lookupTypeInfo ident tcEnv = lookupTopEnv ident tcEnv ++! lookupTupleTC ident
qualLookupTypeInfo :: QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfo ident tcEnv =
qualLookupTopEnv ident tcEnv ++! lookupTupleTC (unqualify ident)
qualLookupTypeInfoUnique :: ModuleIdent -> QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfoUnique m qident tcEnv =
case qualLookupTypeInfo qident tcEnv of
[] -> []
[ti] -> [ti]
tis -> case qualLookupTypeInfo (qualQualify m qident) tcEnv of
[] -> tis
[ti] -> [ti]
tis' -> tis'
getOrigName :: ModuleIdent -> QualIdent -> TCEnv -> QualIdent
getOrigName m tc tcEnv = case qualLookupTypeInfo tc tcEnv of
[y] -> origName y
_ -> case qualLookupTypeInfo (qualQualify m tc) tcEnv of
[y] -> origName y
_ -> internalError $ "Env.TypeConstructor.getOrigName: " ++ show tc
reverseLookupByOrigName :: QualIdent -> TCEnv -> [QualIdent]
reverseLookupByOrigName on
| isQTupleId on = const [on]
| otherwise = map fst . filter ((== on) . origName . snd) . allBindings
lookupTupleTC :: Ident -> [TypeInfo]
lookupTupleTC tc | isTupleId tc = [tupleTCs !! (tupleArity tc - 2)]
| otherwise = []
tupleTCs :: [TypeInfo]
tupleTCs = map typeInfo tupleData
where
typeInfo dc@(DataConstr _ tys) =
let n = length tys in DataType (qTupleId n) (simpleKind n) [dc]
typeInfo (RecordConstr _ _ _) =
internalError "Env.TypeConstructor.tupleTCs: record constructor"