pinadoc: allow module importers (#11, #251)

AshleyYakeley · Apr 23, 2024 · 1f099ed · 1f099ed
1 parent b347d78
commit 1f099ed
Show file tree

Hide file tree

Showing 3 changed files with 22 additions and 17 deletions.
diff --git a/Pinafore/pinafore-app/app/doc/Main.hs b/Pinafore/pinafore-app/app/doc/Main.hs
@@ -27,13 +27,11 @@ trimDocChildren children = bindForest children trimDocL
 trimDoc :: Tree DefDoc -> Tree DefDoc
 trimDoc (MkTree n children) = MkTree n $ trimDocChildren children
 
-printModuleDoc :: ModuleOptions -> Text -> IO ()
-printModuleDoc modopts tmodname = do
+printModuleDoc :: ModuleOptions -> ModuleSpec -> IO ()
+printModuleDoc modopts modspec = do
     let fmodule = standardFetchModule modopts
     let ?library = mkLibraryContext nullInvocationInfo fmodule mempty
-    let modname = MkModuleName tmodname
-    mmod <- fromInterpretResult $ runPinaforeScoped (unpack tmodname) $ lcLoadModule ?library modname
-    pmodule <- maybeToM (unpack $ tmodname <> ": not found") mmod
+    qmodule <- fromInterpretResult $ runPinaforeScoped "<doc>" $ getModule modspec
     let
         runDocTree :: Int -> Int -> Tree DefDoc -> IO ()
         runDocTree hlevel ilevel (MkTree MkDefDoc {..} (MkForest children)) = do
@@ -105,19 +103,20 @@ printModuleDoc modopts tmodname = do
             for_ children $ runDocTree hlevel' ilevel'
         headingTitle :: MarkdownText
         headingTitle =
-            case tmodname of
-                "pinafore" -> plainText "Built In"
-                _ -> plainText $ "import \\\"" <> tmodname <> "\\\""
+            case modspec of
+                PlainModuleSpec "pinafore" -> plainText "Built In"
+                PlainModuleSpec modname -> plainText $ "import \\\"" <> showText modname <> "\\\""
+                SpecialModuleSpec iname uri -> plainText $ "import " <> showText iname <> " \\\"" <> uri <> "\\\""
         headingItem :: DefDoc
         headingItem = MkDefDoc (HeadingDocItem headingTitle) ""
         tree :: Tree DefDoc
-        tree = MkTree headingItem $ moduleDoc pmodule
+        tree = MkTree headingItem $ moduleDoc qmodule
     runDocTree 1 0 $ trimDoc $ deepMergeTree (eqMergeOn docItem) tree
 
 main :: IO ()
 main =
     getOptions >>= \case
         ShowVersionOption -> printVersion
-        ModuleDocOption ropts modname -> do
+        ModuleDocOption ropts modspec -> do
             (_, modopts, _) <- getApplicationOptions ropts
-            printModuleDoc modopts modname
+            printModuleDoc modopts modspec
diff --git a/Pinafore/pinafore-app/app/doc/Options.hs b/Pinafore/pinafore-app/app/doc/Options.hs
@@ -6,14 +6,14 @@ module Options
     ) where
 
 import Options.Applicative as OA
+import Pinafore.Language.API
 import Pinafore.Options
 import Shapes
 
 data Options
     = ShowVersionOption
     | ModuleDocOption RunOptions
-                      Text
-    deriving (Eq, Show)
+                      ModuleSpec
 
 optIncludes :: Parser [FilePath]
 optIncludes = many $ strOption $ long "include" <> short 'I' <> metavar "PATH"
@@ -27,12 +27,17 @@ optCache = pure False
 optRunOptions :: Parser RunOptions
 optRunOptions = MkRunOptions <$> optCache <*> optIncludes <*> optDataPath
 
+toModuleSpec :: Maybe Text -> Text -> ModuleSpec
+toModuleSpec Nothing n = PlainModuleSpec $ MkModuleName n
+toModuleSpec (Just t) n = SpecialModuleSpec (MkName t) n
+
+optModuleSpec :: Parser ModuleSpec
+optModuleSpec =
+    toModuleSpec <$> (optional $ strOption $ long "type" <> metavar "TYPE") <*> (strArgument $ metavar "MODULENAME")
+
 optParser :: Parser Options
 optParser =
-    choice
-        [ flag' ShowVersionOption $ long "version" <> short 'v'
-        , ModuleDocOption <$> optRunOptions <*> (strArgument $ metavar "MODULENAME")
-        ]
+    choice [flag' ShowVersionOption $ long "version" <> short 'v', ModuleDocOption <$> optRunOptions <*> optModuleSpec]
 
 optParserInfo :: ParserInfo Options
 optParserInfo = info optParser mempty

diff --git a/Pinafore/pinafore-language/lib/Pinafore/Language.hs b/Pinafore/pinafore-language/lib/Pinafore/Language.hs
@@ -7,6 +7,7 @@ module Pinafore.Language
     , textFetchModule
     , libraryFetchModule
     , QModule(..)
+    , getModule
     , Importer(..)
     , LibraryContext(..)
     , mkLibraryContext