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
data Environment = Environment
{ names :: M.Map (Qualified Ident) (Type, NameKind, NameVisibility)
, types :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)
, dataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, Type, [Ident])
, typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe Kind)], Type)
, typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict))
, typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData
, kinds :: S.Set (Qualified (ProperName 'KindName))
} deriving Show
data TypeClassData = TypeClassData
{ typeClassArguments :: [(Text, Maybe Kind)]
, typeClassMembers :: [(Ident, Type)]
, typeClassSuperclasses :: [Constraint]
, typeClassDependencies :: [FunctionalDependency]
, typeClassDeterminedArguments :: S.Set Int
, typeClassCoveringSets :: S.Set (S.Set Int)
} deriving Show
data FunctionalDependency = FunctionalDependency
{ fdDeterminers :: [Int]
, fdDetermined :: [Int]
} 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]
identities = (\i -> (i, [i])) <$> argumentIndicies
contributingDeps = M.fromListWith (++) $ identities ++ do
fd <- deps
src <- fdDeterminers fd
(src, fdDetermined fd) : map (, []) (fdDetermined fd)
(depGraph, fromVertex, fromKey) = G.graphFromEdges ((\(n, v) -> (n, n, nub v)) <$> M.toList contributingDeps)
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
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
sccNonDetermined :: Tree G.Vertex -> Maybe [Int]
sccNonDetermined tree
| isVertexDetermined (rootLabel tree) = Nothing
| otherwise = Just (argFromVertex <$> toList tree)
coveringSets :: S.Set (S.Set Int)
coveringSets = let funDepSets = sequence (mapMaybe sccNonDetermined (G.scc depGraph))
in S.fromList (S.fromList <$> funDepSets)
data NameVisibility
= Undefined
| Defined deriving (Show, Eq)
data NameKind
= Private
| Public
| External
deriving (Show, Eq)
data TypeKind
= DataType [(Text, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]
| TypeSynonym
| ExternData
| LocalTypeVariable
| ScopedTypeVar
deriving (Show, Eq)
data DataDeclType
= Data
| 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)