module Env.Value
( ValueEnv, ValueInfo (..)
, bindGlobalInfo, bindFun, qualBindFun, rebindFun, unbindFun
, lookupValue, qualLookupValue, qualLookupValueUnique
, initDCEnv, ppTypes
, conType
) where
import Curry.Base.Ident
import Curry.Base.Position
import Curry.Base.Pretty (Doc, vcat)
import Curry.Syntax
import Base.CurryTypes (fromQualType)
import Base.Messages (internalError)
import Base.TopEnv
import Base.Types
import Base.Utils ((++!))
data ValueInfo
= DataConstructor QualIdent Int [Ident] ExistTypeScheme
| NewtypeConstructor QualIdent Ident ExistTypeScheme
| Value QualIdent Int TypeScheme
| Label QualIdent [QualIdent] TypeScheme
deriving Show
instance Entity ValueInfo where
origName (DataConstructor orgName _ _ _) = orgName
origName (NewtypeConstructor orgName _ _) = orgName
origName (Value orgName _ _) = orgName
origName (Label orgName _ _) = orgName
merge (DataConstructor c1 ar1 ls1 ty1) (DataConstructor c2 ar2 ls2 ty2)
| c1 == c2 && ar1 == ar2 && ty1 == ty2 = do
ls' <- sequence (zipWith mergeLabel ls1 ls2)
Just (DataConstructor c1 ar1 ls' ty1)
merge (NewtypeConstructor c1 l1 ty1) (NewtypeConstructor c2 l2 ty2)
| c1 == c2 && ty1 == ty2 = do
l' <- mergeLabel l1 l2
Just (NewtypeConstructor c1 l' ty1)
merge (Value x1 ar1 ty1) (Value x2 ar2 ty2)
| x1 == x2 && ar1 == ar2 && ty1 == ty2 = Just (Value x1 ar1 ty1)
merge (Label l1 cs1 ty1) (Label l2 cs2 ty2)
| l1 == l2 && cs1 == cs2 && ty1 == ty2 = Just (Label l1 cs1 ty1)
merge _ _ = Nothing
mergeLabel :: Ident -> Ident -> Maybe Ident
mergeLabel l1 l2
| l1 == anonId = Just l2
| l2 == anonId = Just l1
| l1 == l2 = Just l1
| otherwise = Nothing
type ValueEnv = TopEnv ValueInfo
bindGlobalInfo :: (QualIdent -> a -> ValueInfo) -> ModuleIdent -> Ident -> a
-> ValueEnv -> ValueEnv
bindGlobalInfo f m c ty = bindTopEnv c v . qualBindTopEnv qc v
where qc = qualifyWith m c
v = f qc ty
bindFun :: ModuleIdent -> Ident -> Int -> TypeScheme -> ValueEnv -> ValueEnv
bindFun m f a ty
| hasGlobalScope f = bindTopEnv f v . qualBindTopEnv qf v
| otherwise = bindTopEnv f v
where qf = qualifyWith m f
v = Value qf a ty
qualBindFun :: ModuleIdent -> Ident -> Int -> TypeScheme -> ValueEnv -> ValueEnv
qualBindFun m f a ty = qualBindTopEnv qf $ Value qf a ty
where qf = qualifyWith m f
rebindFun :: ModuleIdent -> Ident -> Int -> TypeScheme -> ValueEnv
-> ValueEnv
rebindFun m f a ty
| hasGlobalScope f = rebindTopEnv f v . qualRebindTopEnv qf v
| otherwise = rebindTopEnv f v
where qf = qualifyWith m f
v = Value qf a ty
unbindFun :: Ident -> ValueEnv -> ValueEnv
unbindFun = unbindTopEnv
lookupValue :: Ident -> ValueEnv -> [ValueInfo]
lookupValue x tyEnv = lookupTopEnv x tyEnv ++! lookupTuple x
qualLookupValue :: QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValue x tyEnv = qualLookupTopEnv x tyEnv
++! lookupTuple (unqualify x)
qualLookupValueUnique :: ModuleIdent -> QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValueUnique m x tyEnv = case qualLookupValue x tyEnv of
[] -> []
[v] -> [v]
vs -> case qualLookupValue (qualQualify m x) tyEnv of
[] -> vs
[v] -> [v]
qvs -> qvs
lookupTuple :: Ident -> [ValueInfo]
lookupTuple c | isTupleId c = [tupleDCs !! (tupleArity c 2)]
| otherwise = []
tupleDCs :: [ValueInfo]
tupleDCs = map dataInfo tupleData
where dataInfo (DataConstr _ n tys) =
DataConstructor (qTupleId n) n (replicate n anonId)
(ForAllExist n 0 $ foldr TypeArrow (tupleType tys) tys)
dataInfo (RecordConstr _ _ _ _) = internalError $ "Env.Value.tupleDCs: "
++ show tupleDCs
initDCEnv :: ValueEnv
initDCEnv = foldr predefDC emptyTopEnv
[ (c, length tys, constrType (polyType ty) n' tys)
| (ty, cs) <- predefTypes, DataConstr c n' tys <- cs]
where predefDC (c, a, ty) = predefTopEnv c' (DataConstructor c' a ls ty)
where ls = replicate a anonId
c' = qualify c
constrType (ForAll n ty) n' = ForAllExist n n' . foldr TypeArrow ty
ppTypes :: ModuleIdent -> ValueEnv -> Doc
ppTypes mid valueEnv = ppTypes' mid $ localBindings valueEnv
where
ppTypes' :: ModuleIdent -> [(Ident, ValueInfo)] -> Doc
ppTypes' m = vcat . map (ppIDecl . mkDecl) . filter (isValue . snd)
where
mkDecl (v, Value _ a (ForAll _ ty)) =
IFunctionDecl NoPos (qualify v) a (fromQualType m ty)
mkDecl _ = internalError "Env.Value.ppTypes: no value"
isValue (Value _ _ _) = True
isValue _ = False
conType :: QualIdent -> ValueEnv -> ([Ident], ExistTypeScheme)
conType c tyEnv = case qualLookupTopEnv c tyEnv of
[DataConstructor _ _ ls ty] -> (ls , ty)
[NewtypeConstructor _ l ty] -> ([l], ty)
_ -> internalError $ "Env.Value.conType: " ++ show c