{-# LANGUAGE TemplateHaskell #-}

module Language.PureScript.Environment where

import Prelude.Compat

import Data.Aeson.TH

import qualified Data.Aeson as A

import qualified Data.Map as M

import qualified Data.Set as S

import Data.Maybe (fromMaybe, mapMaybe)

import Data.Text (Text)

import qualified Data.Text as T

import Data.List (nub)

import Data.Tree (Tree, rootLabel)

import qualified Data.Graph as G

import Data.Foldable (toList)

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

-- | The @Environment@ defines all values and types which are currently in scope:

data Environment = Environment

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

-- ^ Values currently in scope

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

-- ^ Type names currently in scope

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

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

-- constructor name, argument types and return type.

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

-- ^ Type synonyms currently in scope

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

-- ^ Available type class dictionaries

, typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData

-- ^ Type classes

, kinds :: S.Set (Qualified (ProperName 'KindName))

-- ^ Kinds in scope

} deriving Show

-- | Information about a type class

data TypeClassData = TypeClassData

{ typeClassArguments :: [(Text, Maybe Kind)]

-- ^ A list of type argument names, and their kinds, where kind annotations

-- were provided.

, typeClassMembers :: [(Ident, Type)]

-- ^ A list of type class members and their types. Type arguments listed above

-- are considered bound in these types.

, typeClassSuperclasses :: [Constraint]

-- ^ A list of superclasses of this type class. Type arguments listed above

-- are considered bound in the types appearing in these constraints.

, typeClassDependencies :: [FunctionalDependency]

-- ^ A list of functional dependencies for the type arguments of this class.

, typeClassDeterminedArguments :: S.Set Int

-- ^ A set of indexes of type argument that are fully determined by other

-- arguments via functional dependencies. This can be computed from both

-- typeClassArguments and typeClassDependencies.

, typeClassCoveringSets :: S.Set (S.Set Int)

-- ^ A sets of arguments that can be used to infer all other arguments.

} deriving Show

-- | A functional dependency indicates a relationship between two sets of

data FunctionalDependency = FunctionalDependency

{ fdDeterminers :: [Int]

-- ^ the type arguments which determine the determined type arguments

, fdDetermined :: [Int]

-- ^ the determined type arguments

} deriving Show

-- |

initEnvironment :: Environment

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

-- |

makeTypeClassData

:: [(Text, Maybe Kind)]

-> [(Ident, Type)]

-> [Constraint]

-> [FunctionalDependency]

-> TypeClassData

makeTypeClassData args m s deps = TypeClassData args m s deps determinedArgs coveringSets

where

argumentIndicies = [0 .. length args - 1]

-- each argument determines themselves

identities = (\i -> (i, [i])) <$> argumentIndicies

-- list all the edges in the graph: for each fundep an edge exists for each determiner to each determined

contributingDeps = M.fromListWith (++) $ identities ++ do

fd <- deps

src <- fdDeterminers fd

(src, fdDetermined fd) : map (, []) (fdDetermined fd)

-- build a graph of which arguments determine other arguments

(depGraph, fromVertex, fromKey) = G.graphFromEdges ((\(n, v) -> (n, n, nub v)) <$> M.toList contributingDeps)

-- do there exist any arguments that contribute to `arg` that `arg` doesn't contribute to

isFunDepDetermined :: Int -> Bool

isFunDepDetermined arg = case fromKey arg of

Nothing -> internalError "Unknown argument index in makeTypeClassData"

Just v -> let contributesToVar = G.reachable (G.transposeG depGraph) v

varContributesTo = G.reachable depGraph v

in any (\r -> not (r `elem` varContributesTo)) contributesToVar

-- find all the arguments that are determined

determinedArgs :: S.Set Int

determinedArgs = S.fromList $ filter isFunDepDetermined argumentIndicies

argFromVertex :: G.Vertex -> Int

argFromVertex index = let (_, arg, _) = fromVertex index in arg

isVertexDetermined :: G.Vertex -> Bool

isVertexDetermined = isFunDepDetermined . argFromVertex

-- from an scc find the non-determined args

sccNonDetermined :: Tree G.Vertex -> Maybe [Int]

sccNonDetermined tree

-- if any arg in an scc is determined then all of them are

| isVertexDetermined (rootLabel tree) = Nothing

| otherwise = Just (argFromVertex <$> toList tree)

-- find the covering sets

coveringSets :: S.Set (S.Set Int)

coveringSets = let funDepSets = sequence (mapMaybe sccNonDetermined (G.scc depGraph))

in S.fromList (S.fromList <$> funDepSets)

-- |

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

-- |

data TypeKind

-- |

-- Data type

--

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

-- |

-- Type synonym

--

| TypeSynonym

-- |

-- Foreign data

--

| ExternData

-- |

-- A local type variable

--

| LocalTypeVariable

-- |

-- A scoped type variable

--

| ScopedTypeVar

deriving (Show, Eq)

-- |

data DataDeclType

-- |

-- A standard data constructor

--

= Data

-- |

-- A newtype constructor

--

| Newtype

deriving (Show, Eq, Ord)

showDataDeclType :: DataDeclType -> Text

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 :: Text -> Qualified (ProperName a)

primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName

primKind :: Text -> Kind

primKind = NamedKind . primName

-- |

kindType :: Kind

kindType = primKind C.typ

kindEffect :: Kind

kindEffect = primKind C.effect

kindSymbol :: Kind

kindSymbol = primKind C.symbol

-- |

primTy :: Text -> 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)

-- |

primKinds :: S.Set (Qualified (ProperName 'KindName))

primKinds =

S.fromList

[ primName C.typ

, primName C.effect

, primName C.symbol

]

-- |

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

primTypes =

M.fromList

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

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

, (primName "Record", (FunKind (Row kindType) kindType, ExternData))

, (primName "String", (kindType, ExternData))

, (primName "Char", (kindType, ExternData))

, (primName "Number", (kindType, ExternData))

, (primName "Int", (kindType, ExternData))

, (primName "Boolean", (kindType, ExternData))

, (primName "Partial", (kindType, ExternData))

, (primName "Fail", (FunKind kindSymbol kindType, ExternData))

, (primName "Warn", (FunKind kindSymbol kindType, ExternData))

, (primName "TypeString", (FunKind kindType kindSymbol, ExternData))

, (primName "TypeConcat", (FunKind kindSymbol (FunKind kindSymbol kindSymbol), ExternData))

]

-- |

primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData

primClasses =

M.fromList

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

, (primName "Fail", (makeTypeClassData [("message", Just kindSymbol)] [] [] []))

, (primName "Warn", (makeTypeClassData [("message", Just kindSymbol)] [] [] []))

]

-- |

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 ident = ident `M.lookup` names env

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

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