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

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

    The compiler maintains information about all type classes in an
    environment that maps type classes to a sorted list of their direct
    superclasses and all their associated class methods with an additional
    flag stating whether an default implementation has been provided or not.
    For both the type class identifier and the list of super classes original
    names are used. Thus, the use of a flat environment is sufficient.
-}

module Env.Class
  ( ClassEnv, initClassEnv
  , ClassInfo, bindClassInfo, mergeClassInfo, lookupClassInfo
  , superClasses, allSuperClasses, classMethods, hasDefaultImpl
  ) where

import           Data.List       (nub, sort)
import qualified Data.Map as Map (Map, empty, insertWith, lookup)

import Curry.Base.Ident

import Base.Messages (internalError)

type ClassInfo = ([QualIdent], [(Ident, Bool)])

type ClassEnv = Map.Map QualIdent ClassInfo

initClassEnv :: ClassEnv
initClassEnv :: ClassEnv
initClassEnv = ClassEnv
forall k a. Map k a
Map.empty

bindClassInfo :: QualIdent -> ClassInfo -> ClassEnv -> ClassEnv
bindClassInfo :: QualIdent -> ClassInfo -> ClassEnv -> ClassEnv
bindClassInfo cls :: QualIdent
cls (sclss :: [QualIdent]
sclss, ms :: [(Ident, Bool)]
ms) =
  (ClassInfo -> ClassInfo -> ClassInfo)
-> QualIdent -> ClassInfo -> ClassEnv -> ClassEnv
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith ClassInfo -> ClassInfo -> ClassInfo
mergeClassInfo QualIdent
cls ([QualIdent] -> [QualIdent]
forall a. Ord a => [a] -> [a]
sort [QualIdent]
sclss, [(Ident, Bool)]
ms)

-- We have to be careful when merging two class infos into one as hidden class
-- declarations in interfaces provide no information about class methods. If
-- one of the method lists is empty, we simply take the other one. This way,
-- we do overwrite the list of class methods that may have been entered into
-- the class environment before with an empty list.

mergeClassInfo :: ClassInfo -> ClassInfo -> ClassInfo
mergeClassInfo :: ClassInfo -> ClassInfo -> ClassInfo
mergeClassInfo (sclss1 :: [QualIdent]
sclss1, ms1 :: [(Ident, Bool)]
ms1) (_, ms2 :: [(Ident, Bool)]
ms2) = ([QualIdent]
sclss1, if [(Ident, Bool)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Ident, Bool)]
ms1 then [(Ident, Bool)]
ms2 else [(Ident, Bool)]
ms1)

lookupClassInfo :: QualIdent -> ClassEnv -> Maybe ClassInfo
lookupClassInfo :: QualIdent -> ClassEnv -> Maybe ClassInfo
lookupClassInfo = QualIdent -> ClassEnv -> Maybe ClassInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup

superClasses :: QualIdent -> ClassEnv -> [QualIdent]
superClasses :: QualIdent -> ClassEnv -> [QualIdent]
superClasses cls :: QualIdent
cls clsEnv :: ClassEnv
clsEnv = case QualIdent -> ClassEnv -> Maybe ClassInfo
lookupClassInfo QualIdent
cls ClassEnv
clsEnv of
  Just (sclss :: [QualIdent]
sclss, _) -> [QualIdent]
sclss
  _ -> String -> [QualIdent]
forall a. String -> a
internalError (String -> [QualIdent]) -> String -> [QualIdent]
forall a b. (a -> b) -> a -> b
$ "Env.Classes.superClasses: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
cls

allSuperClasses :: QualIdent -> ClassEnv -> [QualIdent]
allSuperClasses :: QualIdent -> ClassEnv -> [QualIdent]
allSuperClasses cls :: QualIdent
cls clsEnv :: ClassEnv
clsEnv = [QualIdent] -> [QualIdent]
forall a. Eq a => [a] -> [a]
nub ([QualIdent] -> [QualIdent]) -> [QualIdent] -> [QualIdent]
forall a b. (a -> b) -> a -> b
$ QualIdent -> [QualIdent]
classes QualIdent
cls
  where
    classes :: QualIdent -> [QualIdent]
classes cls' :: QualIdent
cls' = QualIdent
cls' QualIdent -> [QualIdent] -> [QualIdent]
forall a. a -> [a] -> [a]
: (QualIdent -> [QualIdent]) -> [QualIdent] -> [QualIdent]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap QualIdent -> [QualIdent]
classes (QualIdent -> ClassEnv -> [QualIdent]
superClasses QualIdent
cls' ClassEnv
clsEnv)

classMethods :: QualIdent -> ClassEnv -> [Ident]
classMethods :: QualIdent -> ClassEnv -> [Ident]
classMethods cls :: QualIdent
cls clsEnv :: ClassEnv
clsEnv = case QualIdent -> ClassEnv -> Maybe ClassInfo
lookupClassInfo QualIdent
cls ClassEnv
clsEnv of
  Just (_, ms :: [(Ident, Bool)]
ms) -> ((Ident, Bool) -> Ident) -> [(Ident, Bool)] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map (Ident, Bool) -> Ident
forall a b. (a, b) -> a
fst [(Ident, Bool)]
ms
  _ -> String -> [Ident]
forall a. String -> a
internalError (String -> [Ident]) -> String -> [Ident]
forall a b. (a -> b) -> a -> b
$ "Env.Classes.classMethods: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
cls

hasDefaultImpl :: QualIdent -> Ident -> ClassEnv -> Bool
hasDefaultImpl :: QualIdent -> Ident -> ClassEnv -> Bool
hasDefaultImpl cls :: QualIdent
cls f :: Ident
f clsEnv :: ClassEnv
clsEnv = case QualIdent -> ClassEnv -> Maybe ClassInfo
lookupClassInfo QualIdent
cls ClassEnv
clsEnv of
  Just (_, ms :: [(Ident, Bool)]
ms) -> case Ident -> [(Ident, Bool)] -> Maybe Bool
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Ident
f [(Ident, Bool)]
ms of
    Just dflt :: Bool
dflt -> Bool
dflt
    Nothing -> String -> Bool
forall a. String -> a
internalError (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ "Env.Classes.hasDefaultImpl: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
forall a. Show a => a -> String
show Ident
f
  _ -> String -> Bool
forall a. String -> a
internalError (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ "Env.Classes.hasDefaultImpl: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
cls