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