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)
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