{-# 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
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"