{-# LANGUAGE TemplateHaskell #-}
module Language.PureScript.Externs
( ExternsFile(..)
, ExternsImport(..)
, ExternsFixity(..)
, ExternsTypeFixity(..)
, ExternsDeclaration(..)
, moduleToExternsFile
, applyExternsFileToEnvironment
, decodeExterns
) where
import Prelude.Compat
import Control.Monad (guard)
import Data.Aeson (decode)
import Data.Aeson.TH
import Data.ByteString.Lazy (ByteString)
import Data.Maybe (fromMaybe, mapMaybe, maybeToList)
import Data.List (foldl', find)
import Data.Foldable (fold)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Version (showVersion)
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.List.NonEmpty as NEL
import Language.PureScript.AST
import Language.PureScript.Crash
import Language.PureScript.Environment
import Language.PureScript.Kinds
import Language.PureScript.Names
import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Types
import Paths_purescript as Paths
data ExternsFile = ExternsFile
{ efVersion :: Text
, efModuleName :: ModuleName
, efExports :: [DeclarationRef]
, efImports :: [ExternsImport]
, efFixities :: [ExternsFixity]
, efTypeFixities :: [ExternsTypeFixity]
, efDeclarations :: [ExternsDeclaration]
, efSourceSpan :: SourceSpan
} deriving (Show)
data ExternsImport = ExternsImport
{
eiModule :: ModuleName
, eiImportType :: ImportDeclarationType
, eiImportedAs :: Maybe ModuleName
} deriving (Show)
data ExternsFixity = ExternsFixity
{
efAssociativity :: Associativity
, efPrecedence :: Precedence
, efOperator :: OpName 'ValueOpName
, efAlias :: Qualified (Either Ident (ProperName 'ConstructorName))
} deriving (Show)
data ExternsTypeFixity = ExternsTypeFixity
{
efTypeAssociativity :: Associativity
, efTypePrecedence :: Precedence
, efTypeOperator :: OpName 'TypeOpName
, efTypeAlias :: Qualified (ProperName 'TypeName)
} deriving (Show)
data ExternsDeclaration =
EDType
{ edTypeName :: ProperName 'TypeName
, edTypeKind :: SourceKind
, edTypeDeclarationKind :: TypeKind
}
| EDTypeSynonym
{ edTypeSynonymName :: ProperName 'TypeName
, edTypeSynonymArguments :: [(Text, Maybe SourceKind)]
, edTypeSynonymType :: SourceType
}
| EDDataConstructor
{ edDataCtorName :: ProperName 'ConstructorName
, edDataCtorOrigin :: DataDeclType
, edDataCtorTypeCtor :: ProperName 'TypeName
, edDataCtorType :: SourceType
, edDataCtorFields :: [Ident]
}
| EDValue
{ edValueName :: Ident
, edValueType :: SourceType
}
| EDClass
{ edClassName :: ProperName 'ClassName
, edClassTypeArguments :: [(Text, Maybe SourceKind)]
, edClassMembers :: [(Ident, SourceType)]
, edClassConstraints :: [SourceConstraint]
, edFunctionalDependencies :: [FunctionalDependency]
}
| EDInstance
{ edInstanceClassName :: Qualified (ProperName 'ClassName)
, edInstanceName :: Ident
, edInstanceTypes :: [SourceType]
, edInstanceConstraints :: Maybe [SourceConstraint]
, edInstanceChain :: [Qualified Ident]
, edInstanceChainIndex :: Integer
}
| EDKind
{ edKindName :: ProperName 'KindName
}
deriving Show
applyExternsFileToEnvironment :: ExternsFile -> Environment -> Environment
applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclarations
where
applyDecl :: Environment -> ExternsDeclaration -> Environment
applyDecl env (EDType pn kind tyKind) = env { types = M.insert (qual pn) (kind, tyKind) (types env) }
applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) }
applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) }
applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (Just efModuleName) ident) (ty, External, Defined) (names env) }
applyDecl env (EDClass pn args members cs deps) = env { typeClasses = M.insert (qual pn) (makeTypeClassData args members cs deps) (typeClasses env) }
applyDecl env (EDKind pn) = env { kinds = S.insert (qual pn) (kinds env) }
applyDecl env (EDInstance className ident tys cs ch idx) =
env { typeClassDictionaries =
updateMap
(updateMap (M.insertWith (<>) (qual ident) (pure dict)) className)
(Just efModuleName) (typeClassDictionaries env) }
where
dict :: NamedDict
dict = TypeClassDictionaryInScope ch idx (qual ident) [] className tys cs
updateMap :: (Ord k, Monoid a) => (a -> a) -> k -> M.Map k a -> M.Map k a
updateMap f = M.alter (Just . f . fold)
qual :: a -> Qualified a
qual = Qualified (Just efModuleName)
moduleToExternsFile :: Module -> Environment -> ExternsFile
moduleToExternsFile (Module _ _ _ _ Nothing) _ = internalError "moduleToExternsFile: module exports were not elaborated"
moduleToExternsFile (Module ss _ mn ds (Just exps)) env = ExternsFile{..}
where
efVersion = T.pack (showVersion Paths.version)
efModuleName = mn
efExports = exps
efImports = mapMaybe importDecl ds
efFixities = mapMaybe fixityDecl ds
efTypeFixities = mapMaybe typeFixityDecl ds
efDeclarations = concatMap toExternsDeclaration efExports
efSourceSpan = ss
fixityDecl :: Declaration -> Maybe ExternsFixity
fixityDecl (ValueFixityDeclaration _ (Fixity assoc prec) name op) =
fmap (const (ExternsFixity assoc prec op name)) (find (findOp getValueOpRef op) exps)
fixityDecl _ = Nothing
typeFixityDecl :: Declaration -> Maybe ExternsTypeFixity
typeFixityDecl (TypeFixityDeclaration _ (Fixity assoc prec) name op) =
fmap (const (ExternsTypeFixity assoc prec op name)) (find (findOp getTypeOpRef op) exps)
typeFixityDecl _ = Nothing
findOp :: (DeclarationRef -> Maybe (OpName a)) -> OpName a -> DeclarationRef -> Bool
findOp g op = maybe False (== op) . g
importDecl :: Declaration -> Maybe ExternsImport
importDecl (ImportDeclaration _ m mt qmn) = Just (ExternsImport m mt qmn)
importDecl _ = Nothing
toExternsDeclaration :: DeclarationRef -> [ExternsDeclaration]
toExternsDeclaration (TypeRef _ pn dctors) =
case Qualified (Just mn) pn `M.lookup` types env of
Nothing -> internalError "toExternsDeclaration: no kind in toExternsDeclaration"
Just (kind, TypeSynonym)
| Just (args, synTy) <- Qualified (Just mn) pn `M.lookup` typeSynonyms env -> [ EDType pn kind TypeSynonym, EDTypeSynonym pn args synTy ]
Just (kind, ExternData) -> [ EDType pn kind ExternData ]
Just (kind, tk@(DataType _ tys)) ->
EDType pn kind tk : [ EDDataConstructor dctor dty pn ty args
| dctor <- fromMaybe (map fst tys) dctors
, (dty, _, ty, args) <- maybeToList (Qualified (Just mn) dctor `M.lookup` dataConstructors env)
]
_ -> internalError "toExternsDeclaration: Invalid input"
toExternsDeclaration (ValueRef _ ident)
| Just (ty, _, _) <- Qualified (Just mn) ident `M.lookup` names env
= [ EDValue ident ty ]
toExternsDeclaration (TypeClassRef _ className)
| Just TypeClassData{..} <- Qualified (Just mn) className `M.lookup` typeClasses env
, Just (kind, TypeSynonym) <- Qualified (Just mn) (coerceProperName className) `M.lookup` types env
, Just (_, synTy) <- Qualified (Just mn) (coerceProperName className) `M.lookup` typeSynonyms env
= [ EDType (coerceProperName className) kind TypeSynonym
, EDTypeSynonym (coerceProperName className) typeClassArguments synTy
, EDClass className typeClassArguments typeClassMembers typeClassSuperclasses typeClassDependencies
]
toExternsDeclaration (TypeInstanceRef _ ident)
= [ EDInstance tcdClassName ident tcdInstanceTypes tcdDependencies tcdChain tcdIndex
| m1 <- maybeToList (M.lookup (Just mn) (typeClassDictionaries env))
, m2 <- M.elems m1
, nel <- maybeToList (M.lookup (Qualified (Just mn) ident) m2)
, TypeClassDictionaryInScope{..} <- NEL.toList nel
]
toExternsDeclaration (KindRef _ pn)
| Qualified (Just mn) pn `S.member` kinds env
= [ EDKind pn ]
toExternsDeclaration _ = []
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsImport)
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFixity)
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsTypeFixity)
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsDeclaration)
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFile)
decodeExterns :: ByteString -> Maybe ExternsFile
decodeExterns bs = do
externs <- decode bs
guard $ T.unpack (efVersion externs) == showVersion Paths.version
return externs