Clean up importer types (#11, #251)

Pinafore/pinafore-app/app/main/Run.hs

@@ -8,12 +8,7 @@ import Pinafore
 import Shapes
 import System.Environment
 
-runFiles ::
-       Foldable t
-    => (StorageModelOptions, ModuleOptions, ImportTranslatorOptions)
-    -> Bool
-    -> t (FilePath, [String])
-    -> IO ()
+runFiles :: Foldable t => (StorageModelOptions, ModuleOptions, [Importer]) -> Bool -> t (FilePath, [String]) -> IO ()
 runFiles (smopts, modopts, itopts) fNoRun scripts =
     runLifecycle $
     runView $
@@ -31,7 +26,7 @@ runFiles (smopts, modopts, itopts) fNoRun scripts =
             then return ()
             else action
 
-runInteractive :: (StorageModelOptions, ModuleOptions, ImportTranslatorOptions) -> IO ()
+runInteractive :: (StorageModelOptions, ModuleOptions, [Importer]) -> IO ()
 runInteractive (smopts, modopts, itopts) =
     runLifecycle $
     runView $ do

Pinafore/pinafore-app/lib/Pinafore/Libs.hs

@@ -20,5 +20,5 @@ getPinaforeDir mdirpath = do
 extraLibrary :: [LibraryModule ()]
 extraLibrary = mediaLibrary <> gnomeLibrary
 
-importTranslatorOptions :: ImportTranslatorOptions
-importTranslatorOptions = webAPIImportTranslators
+importers :: [Importer]
+importers = webAPIImporters

Pinafore/pinafore-app/lib/Pinafore/Options.hs

@@ -15,12 +15,12 @@ data RunOptions = MkRunOptions
     , roDataDir :: Maybe FilePath
     } deriving (Eq, Show)
 
-getApplicationOptions :: MonadIO m => RunOptions -> m (StorageModelOptions, ModuleOptions, ImportTranslatorOptions)
+getApplicationOptions :: MonadIO m => RunOptions -> m (StorageModelOptions, ModuleOptions, [Importer])
 getApplicationOptions MkRunOptions {..} = do
     smoDataDir <- getPinaforeDir roDataDir
     sysIncludeDirs <- liftIO $ getSystemDataDirs "pinafore/lib"
     let
         smoCache = roCache
         moExtraLibrary = extraLibrary
         moModuleDirs = roIncludeDirs <> [smoDataDir </> "lib"] <> sysIncludeDirs
-    return (MkStorageModelOptions {..}, MkModuleOptions {..}, importTranslatorOptions)
+    return (MkStorageModelOptions {..}, MkModuleOptions {..}, importers)

Pinafore/pinafore-language/lib/Pinafore/Documentation.hs

@@ -29,7 +29,11 @@ allOperatorNames test = let
         | test $ docItem dd
         , nameIsInfix name = Just name
     getDocName _ = Nothing
-    in sort $ nub $ mapMaybe getDocName $ builtInLibrary >>= libraryModuleEntries
+    in sort $
+       nub $
+       mapMaybe getDocName $ do
+           lmod <- builtInLibrary
+           libraryContentsEntries $ lmContents lmod
 
 bindDocTypeName :: BindDoc a -> [Name]
 bindDocTypeName bd =

Pinafore/pinafore-language/lib/Pinafore/Language.hs

@@ -6,9 +6,8 @@ module Pinafore.Language
     , textFetchModule
     , libraryFetchModule
     , QModule(..)
-    , ImportTranslator
+    , Importer(..)
     , LibraryContext(..)
-    , ImportTranslatorOptions
     , mkLibraryContext
     , QSpecialVals(..)
     , QError
@@ -51,7 +50,7 @@ import Shapes
 runPinaforeScoped :: (?library :: LibraryContext) => String -> QInterpreter a -> InterpretResult a
 runPinaforeScoped sourcename ma =
     runInterpreter (initialPos sourcename) ?library spvals $ do
-        sd <- interpretImportPinaforeDeclaration builtInModuleName
+        sd <- interpretImportDeclaration $ PlainModuleSpec builtInModuleName
         withScopeDocs sd ma
 
 spvals :: (?library :: LibraryContext) => QSpecialVals

Pinafore/pinafore-language/lib/Pinafore/Language/Error.hs

@@ -82,8 +82,8 @@ data QErrorType
     | InterpretTypeDeclTypeStorableRecord
     | InterpretSubtypeInconsistent NamedText
                                    NamedText
-    | ImportTranslatorUnknown Name
-    | ImportTranslatorError NamedText
+    | ImporterUnknown Name
+    | ImporterError NamedText
     | ModuleNotFoundError ModuleName
     | ModuleCycleError (NonEmpty ModuleName)
 
@@ -214,8 +214,8 @@ instance ShowNamedText QErrorType where
         "subtype relation is inconsistent with existing subtype relation " <> ta <> " <: " <> tb
     showNamedText (ModuleNotFoundError mname) = "can't find module " <> showNamedText mname
     showNamedText (ModuleCycleError nn) = "cycle in modules: " <> (intercalate ", " $ fmap showNamedText $ toList nn)
-    showNamedText (ImportTranslatorUnknown tname) = "unknown import translator: " <> showNamedText tname
-    showNamedText (ImportTranslatorError t) = "import translator error: " <> t
+    showNamedText (ImporterUnknown tname) = "unknown importer: " <> showNamedText tname
+    showNamedText (ImporterError t) = "importer error: " <> t
 
 data QError =
     MkQError SourcePos

Pinafore/pinafore-language/lib/Pinafore/Language/Grammar.hs

@@ -6,7 +6,7 @@ module Pinafore.Language.Grammar
     ) where
 
 import Pinafore.Language.Grammar.Docs as I (Docs)
-import Pinafore.Language.Grammar.Interpret as I (interpretImportPinaforeDeclaration)
+import Pinafore.Language.Grammar.Interpret as I (interpretImportDeclaration)
 import Pinafore.Language.Grammar.Interpret
 import Pinafore.Language.Grammar.Read as I
 import Pinafore.Language.Grammar.Read.Expression as I (operatorFixity)

Pinafore/pinafore-language/lib/Pinafore/Language/Grammar/Interpret.hs

@@ -3,7 +3,7 @@ module Pinafore.Language.Grammar.Interpret
     , interpretModule
     , interpretDeclarationWith
     , interpretType
-    , interpretImportPinaforeDeclaration
+    , interpretImportDeclaration
     , runInteract
     ) where
 

Pinafore/pinafore-language/lib/Pinafore/Language/Grammar/Interpret/Expression.hs

@@ -3,7 +3,7 @@ module Pinafore.Language.Grammar.Interpret.Expression
     , interpretModule
     , interpretDeclarationWith
     , interpretType
-    , interpretImportPinaforeDeclaration
+    , interpretImportDeclaration
     , interpretPattern
     ) where
 
@@ -271,17 +271,11 @@ interpretRecursiveDocDeclarations ddecls = do
     subtypeSB
     interpretRecursiveLetBindings bindingDecls
 
-interpretImportPinaforeDeclaration :: ModuleName -> QInterpreter QScopeDocs
-interpretImportPinaforeDeclaration modname = do
-    newmod <- getModule modname
+interpretImportDeclaration :: ModuleSpec -> QInterpreter QScopeDocs
+interpretImportDeclaration mspec = do
+    newmod <- getModule mspec
     return $ MkQScopeDocs [moduleScope newmod] $ moduleDoc newmod
 
-interpretImportDeclaration :: Maybe Name -> Text -> QInterpreter QScopeDocs
-interpretImportDeclaration Nothing mname = interpretImportPinaforeDeclaration $ MkModuleName mname
-interpretImportDeclaration (Just tname) t = do
-    mname <- translateImport tname t
-    interpretImportPinaforeDeclaration mname
-
 interpretDeclaration :: SyntaxDeclaration -> QScopeBuilder ()
 interpretDeclaration (MkSyntaxWithDoc doc (MkWithSourcePos spos decl)) = do
     scopeSetSourcePos spos
@@ -499,8 +493,13 @@ interpretDeclarator (SDLetRec sdecls) = runScopeBuilder $ interpretRecursiveDocD
 interpretDeclarator (SDWith swns) = do
     scopes <- for swns interpretNamespaceWith
     return $ MkQScopeDocs scopes mempty
-interpretDeclarator (SDImport imptype simps) = do
-    scopedocs <- for simps $ \modname -> interpretImportDeclaration imptype modname
+interpretDeclarator (SDImport mimportername tt) = do
+    let
+        mkspec t =
+            case mimportername of
+                Just importername -> SpecialModuleSpec importername t
+                Nothing -> PlainModuleSpec $ MkModuleName t
+    scopedocs <- for tt $ \t -> interpretImportDeclaration $ mkspec t
     return $ mconcat scopedocs
 
 interpretDeclaratorWith :: SyntaxDeclarator -> QInterpreter --> QInterpreter

Pinafore/pinafore-language/lib/Pinafore/Language/Interpreter/Interpreter.hs

@@ -9,15 +9,13 @@ module Pinafore.Language.Interpreter.Interpreter
     , currentNamespaceParam
     , appNotationVarRef
     , appNotationBindsProd
-    , ImportTranslator
     , LibraryContext(..)
     , runInterpreter
     , getRenderFullName
     , getBindingInfoLookup
     , getNamespaceWithScope
     , getSpecialVals
     , exportScope
-    , translateImport
     , getModule
     , getSubtypeScope
     , newTypeID
@@ -38,22 +36,20 @@ import Pinafore.Language.VarID
 import Shapes
 import Text.Parsec.Pos (SourcePos, initialPos)
 
-type ImportTranslator = Text -> ResultT Text IO ModuleName
-
 data InterpretContext = MkInterpretContext
     { icSourcePos :: SourcePos
     , icVarIDState :: VarIDState
     , icScope :: QScope
     , icCurrentNamespace :: Namespace
     , icSpecialVals :: QSpecialVals
     , icModulePath :: [ModuleName]
-    , icImportTranslators :: Map Name ImportTranslator
+    , icImporters :: Map Name (Text -> QInterpreter QModule)
     , icLoadModule :: ModuleName -> QInterpreter (Maybe QModule)
     }
 
 data InterpretState = MkInterpretState
     { isTypeID :: TypeID
-    , isModules :: Map ModuleName QModule
+    , isModules :: Map ModuleSpec QModule
     , isAppNotationVar :: VarIDState
     }
 
@@ -143,9 +139,8 @@ specialValsParam = lensMapParam (\bfb a -> fmap (\b -> a {icSpecialVals = b}) $
 modulePathParam :: Param QInterpreter [ModuleName]
 modulePathParam = lensMapParam (\bfb a -> fmap (\b -> a {icModulePath = b}) $ bfb $ icModulePath a) contextParam
 
-importTranslatorsParam :: Param QInterpreter (Map Name ImportTranslator)
-importTranslatorsParam =
-    lensMapParam (\bfb a -> fmap (\b -> a {icImportTranslators = b}) $ bfb $ icImportTranslators a) contextParam
+importersParam :: Param QInterpreter (Map Name (Text -> QInterpreter QModule))
+importersParam = lensMapParam (\bfb a -> fmap (\b -> a {icImporters = b}) $ bfb $ icImporters a) contextParam
 
 loadModuleParam :: Param QInterpreter (ModuleName -> QInterpreter (Maybe QModule))
 loadModuleParam = lensMapParam (\bfb a -> fmap (\b -> a {icLoadModule = b}) $ bfb $ icLoadModule a) contextParam
@@ -163,15 +158,15 @@ appNotationBindsProd = let
 typeIDRef :: Ref QInterpreter TypeID
 typeIDRef = lensMapRef (\bfb a -> fmap (\b -> a {isTypeID = b}) $ bfb $ isTypeID a) interpretStateRef
 
-modulesRef :: Ref QInterpreter (Map ModuleName QModule)
+modulesRef :: Ref QInterpreter (Map ModuleSpec QModule)
 modulesRef = lensMapRef (\bfb a -> fmap (\b -> a {isModules = b}) $ bfb $ isModules a) interpretStateRef
 
 appNotationVarRef :: Ref QInterpreter VarIDState
 appNotationVarRef =
     lensMapRef (\bfb a -> fmap (\b -> a {isAppNotationVar = b}) $ bfb $ isAppNotationVar a) interpretStateRef
 
 data LibraryContext = MkLibraryContext
-    { lcImportTranslators :: Map Name ImportTranslator
+    { lcImporters :: Map Name (Text -> QInterpreter QModule)
     , lcLoadModule :: ModuleName -> QInterpreter (Maybe QModule)
     }
 
@@ -181,7 +176,7 @@ runInterpreter icSourcePos MkLibraryContext {..} icSpecialVals qa = let
     icScope = emptyScope
     icModulePath = []
     icCurrentNamespace = RootNamespace
-    icImportTranslators = lcImportTranslators
+    icImporters = lcImporters
     icLoadModule = lcLoadModule
     in evalStateT (evalWriterT $ runReaderT (unInterpreter qa) $ MkInterpretContext {..}) emptyInterpretState
 
@@ -261,23 +256,12 @@ exportScope nsns names = do
         docs = fmap (biDocumentation . snd) binds
     return (scope, docs)
 
-getCycle :: ModuleName -> [ModuleName] -> Maybe (NonEmpty ModuleName)
+getCycle :: Eq t => t -> [t] -> Maybe (NonEmpty t)
 getCycle _ [] = Nothing
 getCycle mn (n:nn)
     | mn == n = Just $ n :| nn
 getCycle mn (_:nn) = getCycle mn nn
 
-translateImport :: Name -> Text -> QInterpreter ModuleName
-translateImport transname t = do
-    importTranslators <- paramAsk importTranslatorsParam
-    case lookup transname importTranslators of
-        Nothing -> throw $ ImportTranslatorUnknown transname
-        Just tl -> do
-            ren <- liftIO $ runResultT $ tl t
-            case ren of
-                FailureResult err -> throw $ ImportTranslatorError $ toNamedText err
-                SuccessResult mn -> return mn
-
 loadModuleInScope :: ModuleName -> QInterpreter (Maybe QModule)
 loadModuleInScope mname =
     paramWith sourcePosParam (initialPos "<unknown>") $
@@ -286,22 +270,30 @@ loadModuleInScope mname =
         loadModule <- paramAsk loadModuleParam
         loadModule mname
 
-getModule :: ModuleName -> QInterpreter QModule
-getModule mname = do
+getModule :: ModuleSpec -> QInterpreter QModule
+getModule mspec = do
     mods <- refGet modulesRef
-    case lookup mname mods of
+    case lookup mspec mods of
         Just m -> return m
         Nothing -> do
-            mpath <- paramAsk modulePathParam
-            case getCycle mname mpath of
-                Just mnames -> throw $ ModuleCycleError mnames
-                Nothing -> do
-                    mm <- loadModuleInScope mname
-                    case mm of
-                        Just m -> do
-                            refModify modulesRef $ insertMap mname m
-                            return m
-                        Nothing -> throw $ ModuleNotFoundError mname
+            m <-
+                case mspec of
+                    PlainModuleSpec mname -> do
+                        mpath <- paramAsk modulePathParam
+                        case getCycle mname mpath of
+                            Just mnames -> throw $ ModuleCycleError mnames
+                            Nothing -> do
+                                mm <- loadModuleInScope mname
+                                case mm of
+                                    Just m -> return m
+                                    Nothing -> throw $ ModuleNotFoundError mname
+                    SpecialModuleSpec impname uri -> do
+                        importers <- paramAsk importersParam
+                        case lookup impname importers of
+                            Nothing -> throw $ ImporterUnknown impname
+                            Just importer -> importer uri
+            refModify modulesRef $ insertMap mspec m
+            return m
 
 getSubtypeScope :: QSubtypeConversionEntry -> QInterpreter QScope
 getSubtypeScope sce = do

Pinafore/pinafore-language/lib/Pinafore/Language/Library.hs

@@ -6,7 +6,7 @@ module Pinafore.Language.Library
     , directoryFetchModule
     , textFetchModule
     , libraryFetchModule
-    , ImportTranslatorOptions
+    , Importer(..)
     , mkLibraryContext
     , nameIsInfix
     ) where
@@ -56,10 +56,8 @@ builtInLibrary =
     , debugLibSection
     ]
 
-type ImportTranslatorOptions = [(Name, ImportTranslator)]
-
-mkLibraryContext :: InvocationInfo -> FetchModule -> ImportTranslatorOptions -> LibraryContext
-mkLibraryContext context fetchModule itranss = let
-    lcImportTranslators = mapFromList itranss
+mkLibraryContext :: InvocationInfo -> FetchModule -> [Importer] -> LibraryContext
+mkLibraryContext context fetchModule imps = let
+    lcImporters = getImporters imps
     lcLoadModule = runFetchModule $ libraryFetchModule context builtInLibrary <> fetchModule
     in MkLibraryContext {..}

Pinafore/pinafore-language/lib/Pinafore/Language/Library/Defs.hs

@@ -5,9 +5,10 @@ module Pinafore.Language.Library.Defs
     ( ScopeEntry(..)
     , BindDoc(..)
     , BindDocStuff
+    , LibraryContents
+    , libraryContentsEntries
+    , libraryContentsDocumentation
     , LibraryModule(..)
-    , libraryModuleEntries
-    , libraryModuleDocumentation
     , EnA
     , qPositiveTypeDescription
     , qNegativeTypeDescription
@@ -78,20 +79,22 @@ type BindDocStuff context = Forest (BindDoc context)
 singleBindDoc :: BindDoc context -> [BindDocStuff context] -> BindDocStuff context
 singleBindDoc bd tt = pureForest $ MkTree bd $ mconcat tt
 
+type LibraryContents context = Forest (BindDoc context)
+
+libraryContentsEntries :: LibraryContents context -> [BindDoc context]
+libraryContentsEntries = toList
+
+libraryContentsDocumentation :: LibraryContents context -> Forest DefDoc
+libraryContentsDocumentation = fmap bdDoc
+
 data LibraryModule context = MkLibraryModule
     { lmName :: ModuleName
-    , lmContents :: Forest (BindDoc context)
+    , lmContents :: LibraryContents context
     }
 
 instance Contravariant LibraryModule where
     contramap ab (MkLibraryModule n c) = MkLibraryModule n $ fmap (contramap ab) c
 
-libraryModuleEntries :: LibraryModule context -> [BindDoc context]
-libraryModuleEntries (MkLibraryModule _ lmod) = toList lmod
-
-libraryModuleDocumentation :: LibraryModule context -> Forest DefDoc
-libraryModuleDocumentation (MkLibraryModule _ lmod) = fmap bdDoc lmod
-
 type EnA = MeetType Entity A
 
 qPositiveTypeDescription ::