{- |
    Module      :  $Header$
    Description :  Environment of type identifiers
    Copyright   :  (c) 2016        Finn Teegen
    License     :  BSD-3-clause

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

    At the type level, we distinguish data and renaming types, synonym
    types, and type classes. Type variables are not recorded. Type
    synonyms use a kind of their own so that the compiler can verify that
    no type synonyms are used in type expressions in interface files.
-}

module Env.Type
  ( TypeKind (..), toTypeKind,
    TypeEnv, bindTypeKind, lookupTypeKind, qualLookupTypeKind
  ) where

import Curry.Base.Ident

import Base.Messages (internalError)
import Base.TopEnv
import Base.Types (constrIdent, methodName)

import Env.TypeConstructor (TypeInfo (..))

import Data.List (union)

data TypeKind
  = Data  QualIdent [Ident]
  | Alias QualIdent
  | Class QualIdent [Ident]
  deriving (TypeKind -> TypeKind -> Bool
(TypeKind -> TypeKind -> Bool)
-> (TypeKind -> TypeKind -> Bool) -> Eq TypeKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypeKind -> TypeKind -> Bool
$c/= :: TypeKind -> TypeKind -> Bool
== :: TypeKind -> TypeKind -> Bool
$c== :: TypeKind -> TypeKind -> Bool
Eq, Int -> TypeKind -> ShowS
[TypeKind] -> ShowS
TypeKind -> String
(Int -> TypeKind -> ShowS)
-> (TypeKind -> String) -> ([TypeKind] -> ShowS) -> Show TypeKind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeKind] -> ShowS
$cshowList :: [TypeKind] -> ShowS
show :: TypeKind -> String
$cshow :: TypeKind -> String
showsPrec :: Int -> TypeKind -> ShowS
$cshowsPrec :: Int -> TypeKind -> ShowS
Show)

instance Entity TypeKind where
  origName :: TypeKind -> QualIdent
origName (Data  tc :: QualIdent
tc  _) = QualIdent
tc
  origName (Alias tc :: QualIdent
tc   ) = QualIdent
tc
  origName (Class cls :: QualIdent
cls _) = QualIdent
cls

  merge :: TypeKind -> TypeKind -> Maybe TypeKind
merge (Data tc :: QualIdent
tc cs :: [Ident]
cs) (Data tc' :: QualIdent
tc' cs' :: [Ident]
cs')
    | QualIdent
tc QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
tc' = TypeKind -> Maybe TypeKind
forall a. a -> Maybe a
Just (TypeKind -> Maybe TypeKind) -> TypeKind -> Maybe TypeKind
forall a b. (a -> b) -> a -> b
$ QualIdent -> [Ident] -> TypeKind
Data QualIdent
tc ([Ident] -> TypeKind) -> [Ident] -> TypeKind
forall a b. (a -> b) -> a -> b
$ [Ident]
cs [Ident] -> [Ident] -> [Ident]
forall a. Eq a => [a] -> [a] -> [a]
`union` [Ident]
cs'
  merge (Alias tc :: QualIdent
tc) (Alias tc' :: QualIdent
tc')
    | QualIdent
tc QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
tc' = TypeKind -> Maybe TypeKind
forall a. a -> Maybe a
Just (TypeKind -> Maybe TypeKind) -> TypeKind -> Maybe TypeKind
forall a b. (a -> b) -> a -> b
$ QualIdent -> TypeKind
Alias QualIdent
tc
  merge (Class cls :: QualIdent
cls ms :: [Ident]
ms) (Class cls' :: QualIdent
cls' ms' :: [Ident]
ms')
    | QualIdent
cls QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
cls' = TypeKind -> Maybe TypeKind
forall a. a -> Maybe a
Just (TypeKind -> Maybe TypeKind) -> TypeKind -> Maybe TypeKind
forall a b. (a -> b) -> a -> b
$QualIdent -> [Ident] -> TypeKind
Class QualIdent
cls ([Ident] -> TypeKind) -> [Ident] -> TypeKind
forall a b. (a -> b) -> a -> b
$ [Ident]
ms [Ident] -> [Ident] -> [Ident]
forall a. Eq a => [a] -> [a] -> [a]
`union` [Ident]
ms'
  merge _ _ = Maybe TypeKind
forall a. Maybe a
Nothing

toTypeKind :: TypeInfo -> TypeKind
toTypeKind :: TypeInfo -> TypeKind
toTypeKind (DataType     tc :: QualIdent
tc    _ cs :: [DataConstr]
cs) = QualIdent -> [Ident] -> TypeKind
Data QualIdent
tc ((DataConstr -> Ident) -> [DataConstr] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map DataConstr -> Ident
constrIdent [DataConstr]
cs)
toTypeKind (RenamingType tc :: QualIdent
tc    _ nc :: DataConstr
nc) = QualIdent -> [Ident] -> TypeKind
Data QualIdent
tc [DataConstr -> Ident
constrIdent DataConstr
nc]
toTypeKind (AliasType    tc :: QualIdent
tc  _ _  _) = QualIdent -> TypeKind
Alias QualIdent
tc
toTypeKind (TypeClass    cls :: QualIdent
cls   _ ms :: [ClassMethod]
ms) = QualIdent -> [Ident] -> TypeKind
Class QualIdent
cls ((ClassMethod -> Ident) -> [ClassMethod] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map ClassMethod -> Ident
methodName [ClassMethod]
ms)
toTypeKind (TypeVar               _) =
  String -> TypeKind
forall a. String -> a
internalError "Env.Type.toTypeKind: type variable"

type TypeEnv = TopEnv TypeKind

bindTypeKind :: ModuleIdent -> Ident -> TypeKind -> TypeEnv -> TypeEnv
bindTypeKind :: ModuleIdent -> Ident -> TypeKind -> TypeEnv -> TypeEnv
bindTypeKind m :: ModuleIdent
m ident :: Ident
ident tk :: TypeKind
tk = Ident -> TypeKind -> TypeEnv -> TypeEnv
forall a. Ident -> a -> TopEnv a -> TopEnv a
bindTopEnv Ident
ident TypeKind
tk (TypeEnv -> TypeEnv) -> (TypeEnv -> TypeEnv) -> TypeEnv -> TypeEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualIdent -> TypeKind -> TypeEnv -> TypeEnv
forall a. QualIdent -> a -> TopEnv a -> TopEnv a
qualBindTopEnv QualIdent
qident TypeKind
tk
  where
    qident :: QualIdent
qident = ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
ident

lookupTypeKind :: Ident -> TypeEnv -> [TypeKind]
lookupTypeKind :: Ident -> TypeEnv -> [TypeKind]
lookupTypeKind = Ident -> TypeEnv -> [TypeKind]
forall a. Ident -> TopEnv a -> [a]
lookupTopEnv

qualLookupTypeKind :: QualIdent -> TypeEnv -> [TypeKind]
qualLookupTypeKind :: QualIdent -> TypeEnv -> [TypeKind]
qualLookupTypeKind = QualIdent -> TypeEnv -> [TypeKind]
forall a. QualIdent -> TopEnv a -> [a]
qualLookupTopEnv