module Language.PureScript.Environment where
import Data.Data
import Data.Maybe (fromMaybe)
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Aeson as A
import Language.PureScript.Kinds
import Language.PureScript.Names
import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Types
import qualified Language.PureScript.Constants as C
data Environment = Environment {
names :: M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)
, types :: M.Map (Qualified ProperName) (Kind, TypeKind)
, dataConstructors :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident])
, typeSynonyms :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], Type)
, typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope))
, typeClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])
} deriving (Show)
initEnvironment :: Environment
initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty M.empty
data NameVisibility
= Undefined
| Defined deriving (Show, Eq)
data NameKind
= Private
| Public
| External deriving (Show, Eq, Data, Typeable)
data TypeKind
= DataType [(String, Maybe Kind)] [(ProperName, [Type])]
| TypeSynonym
| ExternData
| LocalTypeVariable
| ScopedTypeVar
deriving (Show, Eq, Data, Typeable)
data DataDeclType
= Data
| Newtype deriving (Eq, Ord, Data, Typeable)
instance Show DataDeclType where
show Data = "data"
show Newtype = "newtype"
instance A.ToJSON DataDeclType where
toJSON = A.toJSON . show
instance A.FromJSON DataDeclType where
parseJSON = A.withText "DataDeclType" $ \str ->
case str of
"data" -> return Data
"newtype" -> return Newtype
other -> fail $ "invalid type: '" ++ T.unpack other ++ "'"
primName :: String -> Qualified ProperName
primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName
primTy :: String -> Type
primTy = TypeConstructor . primName
tyFunction :: Type
tyFunction = primTy "Function"
tyString :: Type
tyString = primTy "String"
tyChar :: Type
tyChar = primTy "Char"
tyNumber :: Type
tyNumber = primTy "Number"
tyInt :: Type
tyInt = primTy "Int"
tyBoolean :: Type
tyBoolean = primTy "Boolean"
tyArray :: Type
tyArray = primTy "Array"
tyObject :: Type
tyObject = primTy "Object"
isObject :: Type -> Bool
isObject = isTypeOrApplied tyObject
isFunction :: Type -> Bool
isFunction = isTypeOrApplied tyFunction
isTypeOrApplied :: Type -> Type -> Bool
isTypeOrApplied t1 (TypeApp t2 _) = t1 == t2
isTypeOrApplied t1 t2 = t1 == t2
function :: Type -> Type -> Type
function t1 = TypeApp (TypeApp tyFunction t1)
primTypes :: M.Map (Qualified ProperName) (Kind, TypeKind)
primTypes = M.fromList [ (primName "Function" , (FunKind Star (FunKind Star Star), ExternData))
, (primName "Array" , (FunKind Star Star, ExternData))
, (primName "Object" , (FunKind (Row Star) Star, ExternData))
, (primName "String" , (Star, ExternData))
, (primName "Char" , (Star, ExternData))
, (primName "Number" , (Star, ExternData))
, (primName "Int" , (Star, ExternData))
, (primName "Boolean" , (Star, ExternData)) ]
lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type, [Ident])
lookupConstructor env ctor =
fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors env
isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool
isNewtypeConstructor e ctor = case lookupConstructor e ctor of
(Newtype, _, _, _) -> True
(Data, _, _, _) -> False
lookupValue :: Environment -> Qualified Ident -> Maybe (Type, NameKind, NameVisibility)
lookupValue env (Qualified (Just mn) ident) = (mn, ident) `M.lookup` names env
lookupValue _ _ = Nothing