Create a new docs command, and remove the --docs flag from make.

This commit is contained in:
Robin Heggelund Hansen 2022-09-09 13:08:41 +02:00
parent 7d07060bd2
commit bb4af7a90d
4 changed files with 188 additions and 24 deletions

View File

@ -57,6 +57,7 @@ Common gren-common
Init
Install
Make
Docs
Publish
Repl

152
terminal/src/Docs.hs Normal file
View File

@ -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"

View File

@ -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 =

View File

@ -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