From 1f099ed92addfcfce52f401e503389cde5b4f3a0 Mon Sep 17 00:00:00 2001
From: Ashley Yakeley <ashley@semantic.org>
Date: Tue, 23 Apr 2024 02:01:29 -0700
Subject: [PATCH] pinadoc: allow module importers (#11, #251)

---
 Pinafore/pinafore-app/app/doc/Main.hs         | 21 +++++++++----------
 Pinafore/pinafore-app/app/doc/Options.hs      | 17 +++++++++------
 .../lib/Pinafore/Language.hs                  |  1 +
 3 files changed, 22 insertions(+), 17 deletions(-)

diff --git a/Pinafore/pinafore-app/app/doc/Main.hs b/Pinafore/pinafore-app/app/doc/Main.hs
index 569b20495..1c20936f0 100644
--- 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
index d1bd69058..79177d2cc 100644
--- 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
index 39df47f2d..75dbc4c05 100644
--- 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