{- |
    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 Int -> TypeInfo -> ShowS
[TypeInfo] -> ShowS
TypeInfo -> String
(Int -> TypeInfo -> ShowS)
-> (TypeInfo -> String) -> ([TypeInfo] -> ShowS) -> Show TypeInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeInfo] -> ShowS
$cshowList :: [TypeInfo] -> ShowS
show :: TypeInfo -> String
$cshow :: TypeInfo -> String
showsPrec :: Int -> TypeInfo -> ShowS
$cshowsPrec :: Int -> TypeInfo -> ShowS
Show

instance Entity TypeInfo where
  origName :: TypeInfo -> QualIdent
origName (DataType     tc :: QualIdent
tc    _ _) = QualIdent
tc
  origName (RenamingType tc :: QualIdent
tc    _ _) = QualIdent
tc
  origName (AliasType    tc :: QualIdent
tc  _ _ _) = QualIdent
tc
  origName (TypeClass    cls :: QualIdent
cls   _ _) = QualIdent
cls
  origName (TypeVar              _) =
    String -> QualIdent
forall a. String -> a
internalError "Env.TypeConstructor.origName: type variable"

  merge :: TypeInfo -> TypeInfo -> Maybe TypeInfo
merge (DataType tc :: QualIdent
tc k :: Kind
k cs :: [DataConstr]
cs) (DataType tc' :: QualIdent
tc' k' :: Kind
k' cs' :: [DataConstr]
cs')
    | QualIdent
tc QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
tc' Bool -> Bool -> Bool
&& Kind
k Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
k' Bool -> Bool -> Bool
&& ([DataConstr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataConstr]
cs Bool -> Bool -> Bool
|| [DataConstr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataConstr]
cs' Bool -> Bool -> Bool
|| [DataConstr]
cs [DataConstr] -> [DataConstr] -> Bool
forall a. Eq a => a -> a -> Bool
== [DataConstr]
cs') =
    TypeInfo -> Maybe TypeInfo
forall a. a -> Maybe a
Just (TypeInfo -> Maybe TypeInfo) -> TypeInfo -> Maybe TypeInfo
forall a b. (a -> b) -> a -> b
$ QualIdent -> Kind -> [DataConstr] -> TypeInfo
DataType QualIdent
tc Kind
k ([DataConstr] -> TypeInfo) -> [DataConstr] -> TypeInfo
forall a b. (a -> b) -> a -> b
$ if [DataConstr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataConstr]
cs then [DataConstr]
cs' else [DataConstr]
cs
  merge (DataType tc :: QualIdent
tc k :: Kind
k _) (RenamingType tc' :: QualIdent
tc' k' :: Kind
k' nc :: DataConstr
nc)
    | QualIdent
tc QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
tc' Bool -> Bool -> Bool
&& Kind
k Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
k' = TypeInfo -> Maybe TypeInfo
forall a. a -> Maybe a
Just (QualIdent -> Kind -> DataConstr -> TypeInfo
RenamingType QualIdent
tc Kind
k DataConstr
nc)
  merge l :: TypeInfo
l@(RenamingType tc :: QualIdent
tc k :: Kind
k _) (DataType tc' :: QualIdent
tc' k' :: Kind
k' _)
    | QualIdent
tc QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
tc' Bool -> Bool -> Bool
&& Kind
k Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
k' = TypeInfo -> Maybe TypeInfo
forall a. a -> Maybe a
Just TypeInfo
l
  merge l :: TypeInfo
l@(RenamingType tc :: QualIdent
tc k :: Kind
k _) (RenamingType tc' :: QualIdent
tc' k' :: Kind
k' _)
    | QualIdent
tc QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
tc' Bool -> Bool -> Bool
&& Kind
k Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
k' = TypeInfo -> Maybe TypeInfo
forall a. a -> Maybe a
Just TypeInfo
l
  merge l :: TypeInfo
l@(AliasType tc :: QualIdent
tc k :: Kind
k _ _) (AliasType tc' :: QualIdent
tc' k' :: Kind
k' _ _)
    | QualIdent
tc QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
tc' Bool -> Bool -> Bool
&& Kind
k Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
k' = TypeInfo -> Maybe TypeInfo
forall a. a -> Maybe a
Just TypeInfo
l
  merge (TypeClass cls :: QualIdent
cls k :: Kind
k ms :: [ClassMethod]
ms) (TypeClass cls' :: QualIdent
cls' k' :: Kind
k' ms' :: [ClassMethod]
ms')
    | QualIdent
cls QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
cls' Bool -> Bool -> Bool
&& Kind
k Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
k' Bool -> Bool -> Bool
&& ([ClassMethod] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClassMethod]
ms Bool -> Bool -> Bool
|| [ClassMethod] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClassMethod]
ms' Bool -> Bool -> Bool
|| [ClassMethod]
ms [ClassMethod] -> [ClassMethod] -> Bool
forall a. Eq a => a -> a -> Bool
== [ClassMethod]
ms') =
    TypeInfo -> Maybe TypeInfo
forall a. a -> Maybe a
Just (TypeInfo -> Maybe TypeInfo) -> TypeInfo -> Maybe TypeInfo
forall a b. (a -> b) -> a -> b
$ QualIdent -> Kind -> [ClassMethod] -> TypeInfo
TypeClass QualIdent
cls Kind
k ([ClassMethod] -> TypeInfo) -> [ClassMethod] -> TypeInfo
forall a b. (a -> b) -> a -> b
$ if [ClassMethod] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClassMethod]
ms then [ClassMethod]
ms' else [ClassMethod]
ms
  merge _ _ = Maybe TypeInfo
forall a. Maybe a
Nothing

instance Pretty TypeInfo where
  pPrint :: TypeInfo -> Doc
pPrint (DataType qid :: QualIdent
qid k :: Kind
k cs :: [DataConstr]
cs)    =      String -> Doc
text "data" Doc -> Doc -> Doc
<+> QualIdent -> Doc
forall a. Pretty a => a -> Doc
pPrint QualIdent
qid
                                   Doc -> Doc -> Doc
<>  String -> Doc
text "/" Doc -> Doc -> Doc
<> Kind -> Doc
forall a. Pretty a => a -> Doc
pPrint Kind
k
                                   Doc -> Doc -> Doc
<+> Doc
equals
                                   Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep (Doc -> [Doc] -> [Doc]
punctuate (String -> Doc
text "|") ((DataConstr -> Doc) -> [DataConstr] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map DataConstr -> Doc
forall a. Pretty a => a -> Doc
pPrint [DataConstr]
cs))
  pPrint (RenamingType qid :: QualIdent
qid k :: Kind
k c :: DataConstr
c) =      String -> Doc
text "newtype" Doc -> Doc -> Doc
<+> QualIdent -> Doc
forall a. Pretty a => a -> Doc
pPrint QualIdent
qid
                                   Doc -> Doc -> Doc
<>  String -> Doc
text "/" Doc -> Doc -> Doc
<> Kind -> Doc
forall a. Pretty a => a -> Doc
pPrint Kind
k
                                   Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> DataConstr -> Doc
forall a. Pretty a => a -> Doc
pPrint DataConstr
c
  pPrint (AliasType qid :: QualIdent
qid k :: Kind
k ar :: Int
ar ty :: Type
ty)=      String -> Doc
text "type" Doc -> Doc -> Doc
<+> QualIdent -> Doc
forall a. Pretty a => a -> Doc
pPrint QualIdent
qid
                                   Doc -> Doc -> Doc
<>  String -> Doc
text "/" Doc -> Doc -> Doc
<> Kind -> Doc
forall a. Pretty a => a -> Doc
pPrint Kind
k Doc -> Doc -> Doc
<> String -> Doc
text "/" Doc -> Doc -> Doc
<> Int -> Doc
int Int
ar
                                   Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> Type -> Doc
forall a. Pretty a => a -> Doc
pPrint Type
ty
  pPrint (TypeClass qid :: QualIdent
qid k :: Kind
k ms :: [ClassMethod]
ms)   =      String -> Doc
text "class" Doc -> Doc -> Doc
<+> QualIdent -> Doc
forall a. Pretty a => a -> Doc
pPrint QualIdent
qid
                                   Doc -> Doc -> Doc
<>  String -> Doc
text "/" Doc -> Doc -> Doc
<> Kind -> Doc
forall a. Pretty a => a -> Doc
pPrint Kind
k
                                   Doc -> Doc -> Doc
<+> Doc
equals
                                   Doc -> Doc -> Doc
<+> [Doc] -> Doc
vcat (Doc
blankLine Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (ClassMethod -> Doc) -> [ClassMethod] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ClassMethod -> Doc
forall a. Pretty a => a -> Doc
pPrint [ClassMethod]
ms)
  pPrint (TypeVar _)            =
    String -> Doc
forall a. String -> a
internalError (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ "Env.TypeConstructor.Pretty.TypeInfo.pPrint: type variable"

tcKind :: ModuleIdent -> QualIdent -> TCEnv -> Kind
tcKind :: ModuleIdent -> QualIdent -> TCEnv -> Kind
tcKind m :: ModuleIdent
m tc :: QualIdent
tc tcEnv :: TCEnv
tcEnv = case QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfo QualIdent
tc TCEnv
tcEnv of
  [DataType     _ k :: Kind
k   _] -> Kind
k
  [RenamingType _ k :: Kind
k   _] -> Kind
k
  [AliasType    _ k :: Kind
k _ _] -> Kind
k
  _ -> case QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfo (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
tc) TCEnv
tcEnv of
    [DataType     _ k :: Kind
k   _] -> Kind
k
    [RenamingType _ k :: Kind
k   _] -> Kind
k
    [AliasType    _ k :: Kind
k _ _] -> Kind
k
    _ -> String -> Kind
forall a. String -> a
internalError (String -> Kind) -> String -> Kind
forall a b. (a -> b) -> a -> b
$
           "Env.TypeConstructor.tcKind: no type constructor: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
tc

clsKind :: ModuleIdent -> QualIdent -> TCEnv -> Kind
clsKind :: ModuleIdent -> QualIdent -> TCEnv -> Kind
clsKind m :: ModuleIdent
m cls :: QualIdent
cls tcEnv :: TCEnv
tcEnv = case QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfo QualIdent
cls TCEnv
tcEnv of
  [TypeClass _ k :: Kind
k _] -> Kind
k
  _ -> case QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfo (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
cls) TCEnv
tcEnv of
    [TypeClass _ k :: Kind
k _] -> Kind
k
    _ -> String -> Kind
forall a. String -> a
internalError (String -> Kind) -> String -> Kind
forall a b. (a -> b) -> a -> b
$
           "Env.TypeConstructor.clsKind: no type class: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
cls

varKind :: Ident -> TCEnv -> Kind
varKind :: Ident -> TCEnv -> Kind
varKind tv :: Ident
tv tcEnv :: TCEnv
tcEnv
  | Ident -> Bool
isAnonId Ident
tv = Kind
KindStar
  | Bool
otherwise = case Ident -> TCEnv -> [TypeInfo]
lookupTypeInfo Ident
tv TCEnv
tcEnv of
    [TypeVar k :: Kind
k] -> Kind
k
    _ -> String -> Kind
forall a. String -> a
internalError "Env.TypeConstructor.varKind: no type variable"

clsMethods :: ModuleIdent -> QualIdent -> TCEnv -> [Ident]
clsMethods :: ModuleIdent -> QualIdent -> TCEnv -> [Ident]
clsMethods m :: ModuleIdent
m cls :: QualIdent
cls tcEnv :: TCEnv
tcEnv = case QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfo QualIdent
cls TCEnv
tcEnv of
  [TypeClass _ _ ms :: [ClassMethod]
ms] -> (ClassMethod -> Ident) -> [ClassMethod] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map ClassMethod -> Ident
methodName [ClassMethod]
ms
  _ -> case QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfo (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
cls) TCEnv
tcEnv of
    [TypeClass _ _ ms :: [ClassMethod]
ms] -> (ClassMethod -> Ident) -> [ClassMethod] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map ClassMethod -> Ident
methodName [ClassMethod]
ms
    _ -> String -> [Ident]
forall a. String -> a
internalError (String -> [Ident]) -> String -> [Ident]
forall a b. (a -> b) -> a -> b
$ "Env.TypeConstructor.clsMethods: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
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 :: TCEnv
initTCEnv = ((Type, [DataConstr]) -> TCEnv -> TCEnv)
-> TCEnv -> [(Type, [DataConstr])] -> TCEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Type -> [DataConstr] -> TCEnv -> TCEnv)
-> (Type, [DataConstr]) -> TCEnv -> TCEnv
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Type -> [DataConstr] -> TCEnv -> TCEnv)
 -> (Type, [DataConstr]) -> TCEnv -> TCEnv)
-> (Type -> [DataConstr] -> TCEnv -> TCEnv)
-> (Type, [DataConstr])
-> TCEnv
-> TCEnv
forall a b. (a -> b) -> a -> b
$ (Type, [Type]) -> [DataConstr] -> TCEnv -> TCEnv
forall (t :: * -> *) a.
Foldable t =>
(Type, t a) -> [DataConstr] -> TCEnv -> TCEnv
predefTC ((Type, [Type]) -> [DataConstr] -> TCEnv -> TCEnv)
-> (Type -> (Type, [Type]))
-> Type
-> [DataConstr]
-> TCEnv
-> TCEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Type -> (Type, [Type])
unapplyType Bool
False) TCEnv
forall a. TopEnv a
emptyTopEnv [(Type, [DataConstr])]
predefTypes
  where
    predefTC :: (Type, t a) -> [DataConstr] -> TCEnv -> TCEnv
predefTC (TypeConstructor tc :: QualIdent
tc, tys :: t a
tys) =
      QualIdent -> TypeInfo -> TCEnv -> TCEnv
forall a. QualIdent -> a -> TopEnv a -> TopEnv a
predefTopEnv QualIdent
tc (TypeInfo -> TCEnv -> TCEnv)
-> ([DataConstr] -> TypeInfo) -> [DataConstr] -> TCEnv -> TCEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualIdent -> Kind -> [DataConstr] -> TypeInfo
DataType QualIdent
tc (Int -> Kind
simpleKind (Int -> Kind) -> Int -> Kind
forall a b. (a -> b) -> a -> b
$ t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
tys)
    predefTC _                        =
      String -> [DataConstr] -> TCEnv -> TCEnv
forall a. String -> a
internalError "Env.TypeConstructor.initTCEnv.predefTC: no type constructor"

bindTypeInfo :: ModuleIdent -> Ident -> TypeInfo -> TCEnv -> TCEnv
bindTypeInfo :: ModuleIdent -> Ident -> TypeInfo -> TCEnv -> TCEnv
bindTypeInfo m :: ModuleIdent
m ident :: Ident
ident ti :: TypeInfo
ti = Ident -> TypeInfo -> TCEnv -> TCEnv
forall a. Ident -> a -> TopEnv a -> TopEnv a
bindTopEnv Ident
ident TypeInfo
ti (TCEnv -> TCEnv) -> (TCEnv -> TCEnv) -> TCEnv -> TCEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualIdent -> TypeInfo -> TCEnv -> TCEnv
forall a. QualIdent -> a -> TopEnv a -> TopEnv a
qualBindTopEnv QualIdent
qident TypeInfo
ti
  where
    qident :: QualIdent
qident = ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
ident

rebindTypeInfo :: ModuleIdent -> Ident -> TypeInfo -> TCEnv -> TCEnv
rebindTypeInfo :: ModuleIdent -> Ident -> TypeInfo -> TCEnv -> TCEnv
rebindTypeInfo m :: ModuleIdent
m ident :: Ident
ident ti :: TypeInfo
ti = Ident -> TypeInfo -> TCEnv -> TCEnv
forall a. Ident -> a -> TopEnv a -> TopEnv a
rebindTopEnv Ident
ident TypeInfo
ti (TCEnv -> TCEnv) -> (TCEnv -> TCEnv) -> TCEnv -> TCEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualIdent -> TypeInfo -> TCEnv -> TCEnv
forall a. QualIdent -> a -> TopEnv a -> TopEnv a
qualRebindTopEnv QualIdent
qident TypeInfo
ti
  where
    qident :: QualIdent
qident = ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
ident

lookupTypeInfo :: Ident -> TCEnv -> [TypeInfo]
lookupTypeInfo :: Ident -> TCEnv -> [TypeInfo]
lookupTypeInfo ident :: Ident
ident tcEnv :: TCEnv
tcEnv = Ident -> TCEnv -> [TypeInfo]
forall a. Ident -> TopEnv a -> [a]
lookupTopEnv Ident
ident TCEnv
tcEnv [TypeInfo] -> [TypeInfo] -> [TypeInfo]
forall a. [a] -> [a] -> [a]
++! Ident -> [TypeInfo]
lookupTupleTC Ident
ident

qualLookupTypeInfo :: QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfo :: QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfo ident :: QualIdent
ident tcEnv :: TCEnv
tcEnv =
  QualIdent -> TCEnv -> [TypeInfo]
forall a. QualIdent -> TopEnv a -> [a]
qualLookupTopEnv QualIdent
ident TCEnv
tcEnv [TypeInfo] -> [TypeInfo] -> [TypeInfo]
forall a. [a] -> [a] -> [a]
++! Ident -> [TypeInfo]
lookupTupleTC (QualIdent -> Ident
unqualify QualIdent
ident)

qualLookupTypeInfoUnique :: ModuleIdent -> QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfoUnique :: ModuleIdent -> QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfoUnique m :: ModuleIdent
m qident :: QualIdent
qident tcEnv :: TCEnv
tcEnv =
  case QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfo QualIdent
qident TCEnv
tcEnv of
    []   -> []
    [ti :: TypeInfo
ti] -> [TypeInfo
ti]
    tis :: [TypeInfo]
tis  -> case QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfo (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
qident) TCEnv
tcEnv of
      []  -> [TypeInfo]
tis
      [ti :: TypeInfo
ti] -> [TypeInfo
ti]
      tis' :: [TypeInfo]
tis' -> [TypeInfo]
tis'

getOrigName :: ModuleIdent -> QualIdent -> TCEnv -> QualIdent
getOrigName :: ModuleIdent -> QualIdent -> TCEnv -> QualIdent
getOrigName m :: ModuleIdent
m tc :: QualIdent
tc tcEnv :: TCEnv
tcEnv = case QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfo QualIdent
tc TCEnv
tcEnv of
  [y :: TypeInfo
y] -> TypeInfo -> QualIdent
forall a. Entity a => a -> QualIdent
origName TypeInfo
y
  _ -> case QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfo (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
tc) TCEnv
tcEnv of
    [y :: TypeInfo
y] -> TypeInfo -> QualIdent
forall a. Entity a => a -> QualIdent
origName TypeInfo
y
    _ -> String -> QualIdent
forall a. String -> a
internalError (String -> QualIdent) -> String -> QualIdent
forall a b. (a -> b) -> a -> b
$ "Env.TypeConstructor.getOrigName: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
tc

reverseLookupByOrigName :: QualIdent -> TCEnv -> [QualIdent]
reverseLookupByOrigName :: QualIdent -> TCEnv -> [QualIdent]
reverseLookupByOrigName on :: QualIdent
on
  | QualIdent -> Bool
isQTupleId QualIdent
on = [QualIdent] -> TCEnv -> [QualIdent]
forall a b. a -> b -> a
const [QualIdent
on]
  | Bool
otherwise     = ((QualIdent, TypeInfo) -> QualIdent)
-> [(QualIdent, TypeInfo)] -> [QualIdent]
forall a b. (a -> b) -> [a] -> [b]
map (QualIdent, TypeInfo) -> QualIdent
forall a b. (a, b) -> a
fst ([(QualIdent, TypeInfo)] -> [QualIdent])
-> (TCEnv -> [(QualIdent, TypeInfo)]) -> TCEnv -> [QualIdent]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((QualIdent, TypeInfo) -> Bool)
-> [(QualIdent, TypeInfo)] -> [(QualIdent, TypeInfo)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
on) (QualIdent -> Bool)
-> ((QualIdent, TypeInfo) -> QualIdent)
-> (QualIdent, TypeInfo)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeInfo -> QualIdent
forall a. Entity a => a -> QualIdent
origName (TypeInfo -> QualIdent)
-> ((QualIdent, TypeInfo) -> TypeInfo)
-> (QualIdent, TypeInfo)
-> QualIdent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QualIdent, TypeInfo) -> TypeInfo
forall a b. (a, b) -> b
snd) ([(QualIdent, TypeInfo)] -> [(QualIdent, TypeInfo)])
-> (TCEnv -> [(QualIdent, TypeInfo)])
-> TCEnv
-> [(QualIdent, TypeInfo)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TCEnv -> [(QualIdent, TypeInfo)]
forall a. TopEnv a -> [(QualIdent, a)]
allBindings

lookupTupleTC :: Ident -> [TypeInfo]
lookupTupleTC :: Ident -> [TypeInfo]
lookupTupleTC tc :: Ident
tc | Ident -> Bool
isTupleId Ident
tc = [[TypeInfo]
tupleTCs [TypeInfo] -> Int -> TypeInfo
forall a. [a] -> Int -> a
!! (Ident -> Int
tupleArity Ident
tc Int -> Int -> Int
forall a. Num a => a -> a -> a
- 2)]
                 | Bool
otherwise    = []

tupleTCs :: [TypeInfo]
tupleTCs :: [TypeInfo]
tupleTCs = (DataConstr -> TypeInfo) -> [DataConstr] -> [TypeInfo]
forall a b. (a -> b) -> [a] -> [b]
map DataConstr -> TypeInfo
typeInfo [DataConstr]
tupleData
  where
    typeInfo :: DataConstr -> TypeInfo
typeInfo dc :: DataConstr
dc@(DataConstr _ tys :: [Type]
tys) =
      let n :: Int
n = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tys in QualIdent -> Kind -> [DataConstr] -> TypeInfo
DataType (Int -> QualIdent
qTupleId Int
n) (Int -> Kind
simpleKind Int
n) [DataConstr
dc]
    typeInfo (RecordConstr  _ _ _) =
      String -> TypeInfo
forall a. String -> a
internalError "Env.TypeConstructor.tupleTCs: record constructor"