1-- | 2-- This module generates code for \"externs\" files, i.e. files containing only 3-- foreign import declarations. 4-- 5module Language.PureScript.Externs 6 ( ExternsFile(..) 7 , ExternsImport(..) 8 , ExternsFixity(..) 9 , ExternsTypeFixity(..) 10 , ExternsDeclaration(..) 11 , externsIsCurrentVersion 12 , moduleToExternsFile 13 , applyExternsFileToEnvironment 14 , externsFileName 15 ) where 16 17import Prelude.Compat 18 19import Codec.Serialise (Serialise) 20import Control.Monad (join) 21import GHC.Generics (Generic) 22import Data.Maybe (fromMaybe, mapMaybe, maybeToList) 23import Data.List (foldl', find) 24import Data.Foldable (fold) 25import Data.Text (Text) 26import qualified Data.Text as T 27import Data.Version (showVersion) 28import qualified Data.Map as M 29import qualified Data.List.NonEmpty as NEL 30 31import Language.PureScript.AST 32import Language.PureScript.AST.Declarations.ChainId (ChainId) 33import Language.PureScript.Crash 34import Language.PureScript.Environment 35import Language.PureScript.Names 36import Language.PureScript.TypeClassDictionaries 37import Language.PureScript.Types 38 39import Paths_purescript as Paths 40 41-- | The data which will be serialized to an externs file 42data ExternsFile = ExternsFile 43 -- NOTE: Make sure to keep `efVersion` as the first field in this 44 -- record, so the derived Serialise instance produces CBOR that can 45 -- be checked for its version independent of the remaining format 46 { efVersion :: Text 47 -- ^ The externs version 48 , efModuleName :: ModuleName 49 -- ^ Module name 50 , efExports :: [DeclarationRef] 51 -- ^ List of module exports 52 , efImports :: [ExternsImport] 53 -- ^ List of module imports 54 , efFixities :: [ExternsFixity] 55 -- ^ List of operators and their fixities 56 , efTypeFixities :: [ExternsTypeFixity] 57 -- ^ List of type operators and their fixities 58 , efDeclarations :: [ExternsDeclaration] 59 -- ^ List of type and value declaration 60 , efSourceSpan :: SourceSpan 61 -- ^ Source span for error reporting 62 } deriving (Show, Generic) 63 64instance Serialise ExternsFile 65 66-- | A module import in an externs file 67data ExternsImport = ExternsImport 68 { 69 -- | The imported module 70 eiModule :: ModuleName 71 -- | The import type: regular, qualified or hiding 72 , eiImportType :: ImportDeclarationType 73 -- | The imported-as name, for qualified imports 74 , eiImportedAs :: Maybe ModuleName 75 } deriving (Show, Generic) 76 77instance Serialise ExternsImport 78 79-- | A fixity declaration in an externs file 80data ExternsFixity = ExternsFixity 81 { 82 -- | The associativity of the operator 83 efAssociativity :: Associativity 84 -- | The precedence level of the operator 85 , efPrecedence :: Precedence 86 -- | The operator symbol 87 , efOperator :: OpName 'ValueOpName 88 -- | The value the operator is an alias for 89 , efAlias :: Qualified (Either Ident (ProperName 'ConstructorName)) 90 } deriving (Show, Generic) 91 92instance Serialise ExternsFixity 93 94-- | A type fixity declaration in an externs file 95data ExternsTypeFixity = ExternsTypeFixity 96 { 97 -- | The associativity of the operator 98 efTypeAssociativity :: Associativity 99 -- | The precedence level of the operator 100 , efTypePrecedence :: Precedence 101 -- | The operator symbol 102 , efTypeOperator :: OpName 'TypeOpName 103 -- | The value the operator is an alias for 104 , efTypeAlias :: Qualified (ProperName 'TypeName) 105 } deriving (Show, Generic) 106 107instance Serialise ExternsTypeFixity 108 109-- | A type or value declaration appearing in an externs file 110data ExternsDeclaration = 111 -- | A type declaration 112 EDType 113 { edTypeName :: ProperName 'TypeName 114 , edTypeKind :: SourceType 115 , edTypeDeclarationKind :: TypeKind 116 } 117 -- | A type synonym 118 | EDTypeSynonym 119 { edTypeSynonymName :: ProperName 'TypeName 120 , edTypeSynonymArguments :: [(Text, Maybe SourceType)] 121 , edTypeSynonymType :: SourceType 122 } 123 -- | A data constructor 124 | EDDataConstructor 125 { edDataCtorName :: ProperName 'ConstructorName 126 , edDataCtorOrigin :: DataDeclType 127 , edDataCtorTypeCtor :: ProperName 'TypeName 128 , edDataCtorType :: SourceType 129 , edDataCtorFields :: [Ident] 130 } 131 -- | A value declaration 132 | EDValue 133 { edValueName :: Ident 134 , edValueType :: SourceType 135 } 136 -- | A type class declaration 137 | EDClass 138 { edClassName :: ProperName 'ClassName 139 , edClassTypeArguments :: [(Text, Maybe SourceType)] 140 , edClassMembers :: [(Ident, SourceType)] 141 , edClassConstraints :: [SourceConstraint] 142 , edFunctionalDependencies :: [FunctionalDependency] 143 , edIsEmpty :: Bool 144 } 145 -- | An instance declaration 146 | EDInstance 147 { edInstanceClassName :: Qualified (ProperName 'ClassName) 148 , edInstanceName :: Ident 149 , edInstanceForAll :: [(Text, SourceType)] 150 , edInstanceKinds :: [SourceType] 151 , edInstanceTypes :: [SourceType] 152 , edInstanceConstraints :: Maybe [SourceConstraint] 153 , edInstanceChain :: Maybe ChainId 154 , edInstanceChainIndex :: Integer 155 , edInstanceNameSource :: NameSource 156 , edInstanceSourceSpan :: SourceSpan 157 } 158 deriving (Show, Generic) 159 160instance Serialise ExternsDeclaration 161 162-- | Check whether the version in an externs file matches the currently running 163-- version. 164externsIsCurrentVersion :: ExternsFile -> Bool 165externsIsCurrentVersion ef = 166 T.unpack (efVersion ef) == showVersion Paths.version 167 168-- | Convert an externs file back into a module 169applyExternsFileToEnvironment :: ExternsFile -> Environment -> Environment 170applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclarations 171 where 172 applyDecl :: Environment -> ExternsDeclaration -> Environment 173 applyDecl env (EDType pn kind tyKind) = env { types = M.insert (qual pn) (kind, tyKind) (types env) } 174 applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) } 175 applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) } 176 applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (Just efModuleName) ident) (ty, External, Defined) (names env) } 177 applyDecl env (EDClass pn args members cs deps tcIsEmpty) = env { typeClasses = M.insert (qual pn) (makeTypeClassData args members cs deps tcIsEmpty) (typeClasses env) } 178 applyDecl env (EDInstance className ident vars kinds tys cs ch idx ns ss) = 179 env { typeClassDictionaries = 180 updateMap 181 (updateMap (M.insertWith (<>) (qual ident) (pure dict)) className) 182 (Just efModuleName) (typeClassDictionaries env) } 183 where 184 dict :: NamedDict 185 dict = TypeClassDictionaryInScope ch idx (qual ident) [] className vars kinds tys cs instTy 186 187 updateMap :: (Ord k, Monoid a) => (a -> a) -> k -> M.Map k a -> M.Map k a 188 updateMap f = M.alter (Just . f . fold) 189 190 instTy :: Maybe SourceType 191 instTy = case ns of 192 CompilerNamed -> Just $ srcInstanceType ss vars className tys 193 UserNamed -> Nothing 194 195 qual :: a -> Qualified a 196 qual = Qualified (Just efModuleName) 197 198-- | Generate an externs file for all declarations in a module. 199-- 200-- The `Map Ident Ident` argument should contain any top-level `GenIdent`s that 201-- were rewritten to `Ident`s when the module was compiled; this rewrite only 202-- happens in the CoreFn, not the original module AST, so it needs to be 203-- applied to the exported names here also. (The appropriate map is returned by 204-- `L.P.Renamer.renameInModule`.) 205moduleToExternsFile :: Module -> Environment -> M.Map Ident Ident -> ExternsFile 206moduleToExternsFile (Module _ _ _ _ Nothing) _ _ = internalError "moduleToExternsFile: module exports were not elaborated" 207moduleToExternsFile (Module ss _ mn ds (Just exps)) env renamedIdents = ExternsFile{..} 208 where 209 efVersion = T.pack (showVersion Paths.version) 210 efModuleName = mn 211 efExports = map renameRef exps 212 efImports = mapMaybe importDecl ds 213 efFixities = mapMaybe fixityDecl ds 214 efTypeFixities = mapMaybe typeFixityDecl ds 215 efDeclarations = concatMap toExternsDeclaration exps 216 efSourceSpan = ss 217 218 fixityDecl :: Declaration -> Maybe ExternsFixity 219 fixityDecl (ValueFixityDeclaration _ (Fixity assoc prec) name op) = 220 fmap (const (ExternsFixity assoc prec op name)) (find ((== Just op) . getValueOpRef) exps) 221 fixityDecl _ = Nothing 222 223 typeFixityDecl :: Declaration -> Maybe ExternsTypeFixity 224 typeFixityDecl (TypeFixityDeclaration _ (Fixity assoc prec) name op) = 225 fmap (const (ExternsTypeFixity assoc prec op name)) (find ((== Just op) . getTypeOpRef) exps) 226 typeFixityDecl _ = Nothing 227 228 importDecl :: Declaration -> Maybe ExternsImport 229 importDecl (ImportDeclaration _ m mt qmn) = Just (ExternsImport m mt qmn) 230 importDecl _ = Nothing 231 232 toExternsDeclaration :: DeclarationRef -> [ExternsDeclaration] 233 toExternsDeclaration (TypeRef _ pn dctors) = 234 case Qualified (Just mn) pn `M.lookup` types env of 235 Nothing -> internalError "toExternsDeclaration: no kind in toExternsDeclaration" 236 Just (kind, TypeSynonym) 237 | Just (args, synTy) <- Qualified (Just mn) pn `M.lookup` typeSynonyms env -> [ EDType pn kind TypeSynonym, EDTypeSynonym pn args synTy ] 238 Just (kind, ExternData rs) -> [ EDType pn kind (ExternData rs) ] 239 Just (kind, tk@(DataType _ _ tys)) -> 240 EDType pn kind tk : [ EDDataConstructor dctor dty pn ty args 241 | dctor <- fromMaybe (map fst tys) dctors 242 , (dty, _, ty, args) <- maybeToList (Qualified (Just mn) dctor `M.lookup` dataConstructors env) 243 ] 244 _ -> internalError "toExternsDeclaration: Invalid input" 245 toExternsDeclaration (ValueRef _ ident) 246 | Just (ty, _, _) <- Qualified (Just mn) ident `M.lookup` names env 247 = [ EDValue (lookupRenamedIdent ident) ty ] 248 toExternsDeclaration (TypeClassRef _ className) 249 | let dictName = dictTypeName . coerceProperName $ className 250 , Just TypeClassData{..} <- Qualified (Just mn) className `M.lookup` typeClasses env 251 , Just (kind, tk) <- Qualified (Just mn) (coerceProperName className) `M.lookup` types env 252 , Just (dictKind, dictData@(DataType _ _ [(dctor, _)])) <- Qualified (Just mn) dictName `M.lookup` types env 253 , Just (dty, _, ty, args) <- Qualified (Just mn) dctor `M.lookup` dataConstructors env 254 = [ EDType (coerceProperName className) kind tk 255 , EDType dictName dictKind dictData 256 , EDDataConstructor dctor dty dictName ty args 257 , EDClass className typeClassArguments typeClassMembers typeClassSuperclasses typeClassDependencies typeClassIsEmpty 258 ] 259 toExternsDeclaration (TypeInstanceRef ss' ident ns) 260 = [ EDInstance tcdClassName (lookupRenamedIdent ident) tcdForAll tcdInstanceKinds tcdInstanceTypes tcdDependencies tcdChain tcdIndex ns ss' 261 | m1 <- maybeToList (M.lookup (Just mn) (typeClassDictionaries env)) 262 , m2 <- M.elems m1 263 , nel <- maybeToList (M.lookup (Qualified (Just mn) ident) m2) 264 , TypeClassDictionaryInScope{..} <- NEL.toList nel 265 ] 266 toExternsDeclaration _ = [] 267 268 renameRef :: DeclarationRef -> DeclarationRef 269 renameRef = \case 270 ValueRef ss' ident -> ValueRef ss' $ lookupRenamedIdent ident 271 TypeInstanceRef ss' ident _ | not $ isPlainIdent ident -> TypeInstanceRef ss' (lookupRenamedIdent ident) CompilerNamed 272 other -> other 273 274 lookupRenamedIdent :: Ident -> Ident 275 lookupRenamedIdent = flip (join M.findWithDefault) renamedIdents 276 277externsFileName :: FilePath 278externsFileName = "externs.cbor" 279