{- | Module : $Header$ Description : Environment for functions, constructors and labels Copyright : (c) 2001 - 2004 Wolfgang Lux 2011 Björn Peemöller 2015 Jan Tikovsky 2016 Finn Teegen License : BSD-3-clause Maintainer : bjp@informatik.uni-kiel.de Stability : experimental Portability : portable In order to test the type correctness of a module, the compiler needs to determine the type of every data constructor, function and variable in the module. For the purpose of type checking there is no need for distinguishing between variables and functions. For all objects their original names and their types are saved. In addition, the compiler also saves the (optional) list of field labels for data and newtype constructors. Data constructors and functions also contain arity information. On import two values are considered equal if their original names match. -} {-# LANGUAGE CPP #-} module Env.Value ( ValueEnv, ValueInfo (..) , bindGlobalInfo, bindFun, qualBindFun, rebindFun, unbindFun , lookupValue, qualLookupValue, qualLookupValueUnique , initDCEnv , ValueType (..), bindLocalVars, bindLocalVar ) where #if __GLASGOW_HASKELL__ >= 804 import Prelude hiding ((<>)) #endif import Curry.Base.Ident import Curry.Base.Pretty (Pretty(..)) import Base.Messages (internalError) import Base.PrettyTypes () import Base.TopEnv import Base.Types import Base.Utils ((++!)) import Text.PrettyPrint data ValueInfo -- |Data constructor with original name, arity, list of record labels and type = DataConstructor QualIdent Int [Ident] ExistTypeScheme -- |Newtype constructor with original name, record label and type -- (arity is always 1) | NewtypeConstructor QualIdent Ident ExistTypeScheme -- |Value with original name, class method flag, arity and type | Value QualIdent Bool Int TypeScheme -- |Record label with original name, list of constructors for which label -- is valid field and type (arity is always 1) | 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 cm1 ty1) (Value x2 ar2 cm2 ty2) | x1 == x2 && ar1 == ar2 && cm1 == cm2 && ty1 == ty2 = Just (Value x1 ar1 cm1 ty1) merge (Label l1 cs1 ty1) (Label l2 cs2 ty2) | l1 == l2 && cs1 == cs2 && ty1 == ty2 = Just (Label l1 cs1 ty1) merge _ _ = Nothing instance Pretty ValueInfo where pPrint (DataConstructor qid ar _ tySc) = text "data" <+> pPrint qid <> text "/" <> int ar <+> equals <+> pPrint tySc pPrint (NewtypeConstructor qid _ tySc) = text "newtype" <+> pPrint qid <+> equals <+> pPrint tySc pPrint (Value qid _ ar tySc) = pPrint qid <> text "/" <> int ar <+> equals <+> pPrint tySc pPrint (Label qid _ tySc) = text "label" <+> pPrint qid <+> equals <+> pPrint tySc mergeLabel :: Ident -> Ident -> Maybe Ident mergeLabel l1 l2 | l1 == anonId = Just l2 | l2 == anonId = Just l1 | l1 == l2 = Just l1 | otherwise = Nothing -- Even though value declarations may be nested, the compiler uses only -- flat environments for saving type information. This is possible -- because all identifiers are renamed by the compiler. Here we need -- special cases for handling tuple constructors. -- -- Note: the function 'qualLookupValue' has been extended to -- allow the usage of the qualified list constructor (Prelude.:). 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 -> Bool -> Int -> TypeScheme -> ValueEnv -> ValueEnv bindFun m f cm a ty | hasGlobalScope f = bindTopEnv f v . qualBindTopEnv qf v | otherwise = bindTopEnv f v where qf = qualifyWith m f v = Value qf cm a ty qualBindFun :: ModuleIdent -> Ident -> Bool -> Int -> TypeScheme -> ValueEnv -> ValueEnv qualBindFun m f cm a ty = qualBindTopEnv qf $ Value qf cm a ty where qf = qualifyWith m f rebindFun :: ModuleIdent -> Ident -> Bool -> Int -> TypeScheme -> ValueEnv -> ValueEnv rebindFun m f cm a ty | hasGlobalScope f = rebindTopEnv f v . qualRebindTopEnv qf v | otherwise = rebindTopEnv f v where qf = qualifyWith m f v = Value qf cm 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 _ _ _ tys) = let n = length tys in DataConstructor (qTupleId n) n (replicate n anonId) $ ForAllExist n 0 $ predType $ foldr TypeArrow (tupleType tys) tys dataInfo (RecordConstr _ _ _ _ _) = internalError $ "Env.Value.tupleDCs: " ++ show tupleDCs -- Since all predefined types are free of existentially quantified type -- variables and have an empty predicate set, we can ignore both of them -- when entering the types into the value environment. initDCEnv :: ValueEnv initDCEnv = foldr predefDC emptyTopEnv [ (c, length tys, constrType (polyType ty) tys) | (ty, cs) <- predefTypes, DataConstr c _ _ 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 (PredType ps ty)) = ForAllExist n 0 . PredType ps . foldr TypeArrow ty -- The functions 'bindLocalVar' and 'bindLocalVars' add the type of one or -- many local variables or functions to the value environment. In contrast -- to global functions, we do not care about the name of the module containing -- the variable or function's definition. class ValueType t where toValueType :: Type -> t fromValueType :: t -> PredType instance ValueType Type where toValueType = id fromValueType = predType instance ValueType PredType where toValueType = predType fromValueType = id bindLocalVars :: ValueType t => [(Ident, Int, t)] -> ValueEnv -> ValueEnv bindLocalVars = flip $ foldr bindLocalVar bindLocalVar :: ValueType t => (Ident, Int, t) -> ValueEnv -> ValueEnv bindLocalVar (v, a, ty) = bindTopEnv v $ Value (qualify v) False a $ typeScheme $ fromValueType ty