{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE TemplateHaskell #-}

module Language.PureScript.Environment where

import Prelude.Compat

import Data.Aeson.TH

import Data.Maybe (fromMaybe)

import qualified Data.Aeson as A

import qualified Data.Map as M

import qualified Data.Text as T

import Language.PureScript.Crash

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 {

-- |

-- Value names currently in scope

--

names :: M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)

-- |

-- Type names currently in scope

--

, types :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)

-- |

-- Data constructors currently in scope, along with their associated type

-- constructor name, argument types and return type.

, dataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, Type, [Ident])

-- |

-- Type synonyms currently in scope

--

, typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(String, Maybe Kind)], Type)

-- |

-- Available type class dictionaries

--

, typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))

-- |

-- Type classes

--

, typeClasses :: M.Map (Qualified (ProperName 'ClassName)) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])

} deriving (Show, Read)

-- |

initEnvironment :: Environment

initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClasses

-- |

data NameVisibility

-- |

-- The name is defined in the current binding group, but is not visible

--

= Undefined

-- |

-- The name is defined in the another binding group, or has been made visible by a function binder

--

| Defined deriving (Show, Read, Eq)

-- |

data NameKind

-- |

-- A private value introduced as an artifact of code generation (class instances, class member

-- accessors, etc.)

--

= Private

-- |

-- A public value for a module member or foreing import declaration

--

| Public

-- |

-- A name for member introduced by foreign import

--

| External

deriving (Show, Read, Eq)

-- |

data TypeKind

-- |

-- Data type

--

= DataType [(String, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]

-- |

-- Type synonym

--

| TypeSynonym

-- |

-- Foreign data

--

| ExternData

-- |

-- A local type variable

--

| LocalTypeVariable

-- |

-- A scoped type variable

--

| ScopedTypeVar

deriving (Show, Read, Eq)

-- |

data DataDeclType

-- |

-- A standard data constructor

--

= Data

-- |

-- A newtype constructor

--

| Newtype

deriving (Show, Read, Eq, Ord)

showDataDeclType :: DataDeclType -> String

showDataDeclType Data = "data"

showDataDeclType Newtype = "newtype"

instance A.ToJSON DataDeclType where

toJSON = A.toJSON . showDataDeclType

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

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"

-- |

tyRecord :: Type

tyRecord = primTy "Record"

-- |

isObject :: Type -> Bool

isObject = isTypeOrApplied tyRecord

-- |

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 'TypeName)) (Kind, TypeKind)

primTypes =

M.fromList

[ (primName "Function", (FunKind Star (FunKind Star Star), ExternData))

, (primName "Array", (FunKind Star Star, ExternData))

, (primName "Record", (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))

, (primName "Partial", (Star, ExternData))

, (primName "Fail", (FunKind Symbol Star, ExternData))

]

-- |

primClasses :: M.Map (Qualified (ProperName 'ClassName)) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])

primClasses =

M.fromList

[ (primName "Partial", ([], [], []))

, (primName "Fail", ([("message", Just Symbol)], [], []))

]

-- |

lookupConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> (DataDeclType, ProperName 'TypeName, Type, [Ident])

lookupConstructor env ctor =

fromMaybe (internalError "Data constructor not found") $ ctor `M.lookup` dataConstructors env

-- |

isNewtypeConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> 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

$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''TypeKind)