diff --git a/gren.cabal b/gren.cabal index 0e0b838c..7bda8948 100644 --- a/gren.cabal +++ b/gren.cabal @@ -57,6 +57,7 @@ Common gren-common Init Install Make + Docs Publish Repl diff --git a/terminal/src/Docs.hs b/terminal/src/Docs.hs new file mode 100644 index 00000000..f1c7ee4e --- /dev/null +++ b/terminal/src/Docs.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Docs + ( Flags (..), + Output (..), + ReportType (..), + run, + reportType, + output, + docsFile, + ) +where + +import BackgroundWriter qualified as BW +import Build qualified +import Data.ByteString.Builder qualified as B +import Data.NonEmptyList qualified as NE +import Directories qualified as Dirs +import Gren.Details qualified as Details +import Gren.Docs qualified as Docs +import Gren.ModuleName qualified as ModuleName +import Json.Encode qualified as Json +import Reporting qualified +import Reporting.Exit qualified as Exit +import Reporting.Task qualified as Task +import System.FilePath qualified as FP +import System.IO qualified as IO +import Terminal (Parser (..)) + +-- FLAGS + +data Flags = Flags + { _output :: Maybe Output, + _report :: Maybe ReportType + } + +data Output + = JSON FilePath + | DevNull + | DevStdOut + +data ReportType + = Json + +-- RUN + +type Task a = Task.Task Exit.Make a + +run :: () -> Flags -> IO () +run () flags@(Flags _ report) = + do + style <- getStyle report + maybeRoot <- Dirs.findRoot + Reporting.attemptWithStyle style Exit.makeToReport $ + case maybeRoot of + Just root -> runHelp root style flags + Nothing -> return $ Left $ Exit.MakeNoOutline + +runHelp :: FilePath -> Reporting.Style -> Flags -> IO (Either Exit.Make ()) +runHelp root style (Flags maybeOutput _) = + BW.withScope $ \scope -> + Dirs.withRootLock root $ + Task.run $ + do + details <- Task.eio Exit.MakeBadDetails (Details.load style scope root) + exposed <- getExposed details + case maybeOutput of + Just DevNull -> + do + buildExposed style root details Build.IgnoreDocs exposed + return () + Just DevStdOut -> + do + docs <- buildExposed style root details Build.KeepDocs exposed + let builder = Json.encodeUgly $ Docs.encode docs + Task.io $ B.hPutBuilder IO.stdout builder + Nothing -> + buildExposed style root details (Build.WriteDocs "docs.json") exposed + Just (JSON target) -> + buildExposed style root details (Build.WriteDocs target) exposed + +-- GET INFORMATION + +getStyle :: Maybe ReportType -> IO Reporting.Style +getStyle report = + case report of + Nothing -> Reporting.terminal + Just Json -> return Reporting.json + +getExposed :: Details.Details -> Task (NE.List ModuleName.Raw) +getExposed (Details.Details _ validOutline _ _ _ _) = + case validOutline of + Details.ValidApp _ _ -> + Task.throw Exit.MakeAppNeedsFileNames + Details.ValidPkg _ _ exposed -> + case exposed of + [] -> Task.throw Exit.MakePkgNeedsExposing + m : ms -> return (NE.List m ms) + +-- BUILD PROJECTS + +buildExposed :: Reporting.Style -> FilePath -> Details.Details -> Build.DocsGoal a -> NE.List ModuleName.Raw -> Task a +buildExposed style root details docsGoal exposed = + Task.eio Exit.MakeCannotBuild $ + Build.fromExposed style root details docsGoal exposed + +-- PARSERS + +reportType :: Parser ReportType +reportType = + Parser + { _singular = "report type", + _plural = "report types", + _parser = \string -> if string == "json" then Just Json else Nothing, + _suggest = \_ -> return ["json"], + _examples = \_ -> return ["json"] + } + +output :: Parser Output +output = + Parser + { _singular = "output file", + _plural = "output files", + _parser = parseOutput, + _suggest = \_ -> return [], + _examples = \_ -> return ["gren.js", "index.html", "/dev/null", "/dev/stdout"] + } + +parseOutput :: String -> Maybe Output +parseOutput name + | name == "/dev/stdout" = Just DevStdOut + | isDevNull name = Just DevNull + | hasExt ".json" name = Just (JSON name) + | otherwise = Nothing + +docsFile :: Parser FilePath +docsFile = + Parser + { _singular = "json file", + _plural = "json files", + _parser = \name -> if hasExt ".json" name then Just name else Nothing, + _suggest = \_ -> return [], + _examples = \_ -> return ["docs.json", "documentation.json"] + } + +hasExt :: String -> String -> Bool +hasExt ext path = + FP.takeExtension path == ext && length path > length ext + +isDevNull :: String -> Bool +isDevNull name = + name == "/dev/null" || name == "NUL" || name == "$null" diff --git a/terminal/src/Main.hs b/terminal/src/Main.hs index 44c7f717..1b22509b 100644 --- a/terminal/src/Main.hs +++ b/terminal/src/Main.hs @@ -8,6 +8,7 @@ where import Bump qualified import Data.List qualified as List import Diff qualified +import Docs qualified import Format qualified import Gren.Platform qualified as Platform import Gren.Version qualified as V @@ -31,6 +32,7 @@ main = [ repl, init, make, + docs, install, format, bump, @@ -155,9 +157,31 @@ make = |-- onOff "optimize" "Turn on optimizations to make code smaller and faster. For example, the compiler renames record fields to be as short as possible and unboxes values to reduce allocation." |-- flag "output" Make.output "Specify the name of the resulting JS file. For example --output=assets/gren.js to generate the JS at assets/gren.js. You can also use --output=/dev/stdout to output the JS to the terminal, or --output=/dev/null to generate no output at all!" |-- flag "report" Make.reportType "You can say --report=json to get error messages as JSON. This is only really useful if you are an editor plugin. Humans should avoid it!" - |-- flag "docs" Make.docsFile "Generate a JSON file of documentation for a package." in Terminal.Command "make" Uncommon details example (zeroOrMore grenFile) makeFlags Make.run +-- DOCS + +docs :: Terminal.Command +docs = + let details = + "The `docs` command collects all documentation for a package in a JSON file:" + + example = + stack + [ reflow + "For example:", + P.indent 4 $ P.green "gren docs", + reflow + "This collects all documentation for the current package and writes it to a\ + \ docs.json file, if possible" + ] + + docsFlags = + flags Docs.Flags + |-- flag "output" Docs.output "Specify the name of the resulting JSON file. For example --output=assets/docs.json to generate the JSON at assets/docs.json. You can also use --output=/dev/stdout to output the JSON to the terminal, or --output=/dev/null to verify that generating the documentation would work." + |-- flag "report" Docs.reportType "You can say --report=json to get error messages as JSON. This is only really useful if you are an editor plugin. Humans should avoid it!" + in Terminal.Command "docs" Uncommon details example noArgs docsFlags Docs.run + -- INSTALL install :: Terminal.Command @@ -284,8 +308,8 @@ format = -- HELPERS stack :: [P.Doc] -> P.Doc -stack docs = - P.vcat $ List.intersperse "" docs +stack docList = + P.vcat $ List.intersperse "" docList reflow :: String -> P.Doc reflow string = diff --git a/terminal/src/Make.hs b/terminal/src/Make.hs index c051da95..32a8e3d0 100644 --- a/terminal/src/Make.hs +++ b/terminal/src/Make.hs @@ -7,7 +7,6 @@ module Make run, reportType, output, - docsFile, ) where @@ -39,8 +38,7 @@ data Flags = Flags { _debug :: Bool, _optimize :: Bool, _output :: Maybe Output, - _report :: Maybe ReportType, - _docs :: Maybe FilePath + _report :: Maybe ReportType } data Output @@ -58,7 +56,7 @@ data ReportType type Task a = Task.Task Exit.Make a run :: [FilePath] -> Flags -> IO () -run paths flags@(Flags _ _ _ report _) = +run paths flags@(Flags _ _ _ report) = do style <- getStyle report maybeRoot <- Dirs.findRoot @@ -68,7 +66,7 @@ run paths flags@(Flags _ _ _ report _) = Nothing -> return $ Left $ Exit.MakeNoOutline runHelp :: FilePath -> [FilePath] -> Reporting.Style -> Flags -> IO (Either Exit.Make ()) -runHelp root paths style (Flags debug optimize maybeOutput _ maybeDocs) = +runHelp root paths style (Flags debug optimize maybeOutput _) = BW.withScope $ \scope -> Dirs.withRootLock root $ Task.run $ @@ -80,7 +78,7 @@ runHelp root paths style (Flags debug optimize maybeOutput _ maybeDocs) = [] -> do exposed <- getExposed details - buildExposed style root details maybeDocs exposed + buildExposed style root details exposed p : ps -> do artifacts <- buildPaths style root details (NE.List p ps) @@ -171,11 +169,10 @@ getPlatform (Details.Details _ validOutline _ _ _ _) = do -- BUILD PROJECTS -buildExposed :: Reporting.Style -> FilePath -> Details.Details -> Maybe FilePath -> NE.List ModuleName.Raw -> Task () -buildExposed style root details maybeDocs exposed = - let docsGoal = maybe Build.IgnoreDocs Build.WriteDocs maybeDocs - in Task.eio Exit.MakeCannotBuild $ - Build.fromExposed style root details docsGoal exposed +buildExposed :: Reporting.Style -> FilePath -> Details.Details -> NE.List ModuleName.Raw -> Task () +buildExposed style root details exposed = + Task.eio Exit.MakeCannotBuild $ + Build.fromExposed style root details Build.IgnoreDocs exposed buildPaths :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> Task Build.Artifacts buildPaths style root details paths = @@ -287,16 +284,6 @@ parseOutput name | noExt name = Just (Exe name) | otherwise = Nothing -docsFile :: Parser FilePath -docsFile = - Parser - { _singular = "json file", - _plural = "json files", - _parser = \name -> if hasExt ".json" name then Just name else Nothing, - _suggest = \_ -> return [], - _examples = \_ -> return ["docs.json", "documentation.json"] - } - hasExt :: String -> String -> Bool hasExt ext path = FP.takeExtension path == ext && length path > length ext