{-# LANGUAGE TupleSections #-}

-- |

module Main where

import Control.Applicative

import Control.Arrow (first, second)

import Control.Category ((>>>))

import Control.Monad.Writer

import Data.Function (on)

import Data.List

import Data.Maybe (fromMaybe)

import Data.Tuple (swap)

import Data.Version (showVersion)

import Options.Applicative

import qualified Text.PrettyPrint.ANSI.Leijen as PP

import qualified Language.PureScript as P

import qualified Paths_purescript as Paths

import System.Exit (exitFailure)

import System.IO (hPutStrLn, stderr)

import System.Directory (createDirectoryIfMissing)

import System.FilePath (takeDirectory)

import Etags

import Ctags

import qualified Language.PureScript.Docs as D

import qualified Language.PureScript.Docs.AsMarkdown as D

data Format = Markdown -- Output documentation in Markdown format

| Ctags -- Output ctags symbol index suitable for use with vi

| Etags -- Output etags symbol index suitable for use with emacs

deriving (Show, Eq, Ord)

-- | Available methods of outputting Markdown documentation

data DocgenOutput

= EverythingToStdOut

| ToStdOut [P.ModuleName]

| ToFiles [(P.ModuleName, FilePath)]

deriving (Show)

data PSCDocsOptions = PSCDocsOptions

{ pscdFormat :: Format

, pscdInputFiles :: [FilePath]

, pscdDocgen :: DocgenOutput

}

deriving (Show)

docgen :: PSCDocsOptions -> IO ()

docgen (PSCDocsOptions fmt input output) =

case fmt of

Etags -> dumpTags input dumpEtags

Ctags -> dumpTags input dumpCtags

Markdown -> do

e <- D.parseAndDesugar input [] (\_ ms -> return ms)

case e of

Left (D.ParseError err) -> do

hPutStrLn stderr $ show err

exitFailure

Left (D.SortModulesError err) -> do

hPutStrLn stderr $ P.prettyPrintMultipleErrors False err

exitFailure

Left (D.DesugarError err) -> do

hPutStrLn stderr $ P.prettyPrintMultipleErrors False err

exitFailure

Right ms' ->

case output of

EverythingToStdOut ->

putStrLn (D.renderModulesAsMarkdown ms')

ToStdOut names -> do

let (ms, missing) = takeModulesByName ms' names

guardMissing missing

putStrLn (D.renderModulesAsMarkdown ms)

ToFiles names -> do

let (ms, missing) = takeModulesByName' ms' names

guardMissing missing

let ms'' = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ map swap ms

forM_ ms'' $ \grp -> do

let fp = fst (head grp)

createDirectoryIfMissing True (takeDirectory fp)

writeFile fp (D.renderModulesAsMarkdown $ snd `map` grp)

where

guardMissing [] = return ()

guardMissing [mn] = do

hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ show mn ++ "\"")

exitFailure

guardMissing mns = do

hPutStrLn stderr "psc-docs: error: unknown modules:"

forM_ mns $ \mn ->

hPutStrLn stderr (" * " ++ show mn)

exitFailure

-- |

takeModulesByName :: [P.Module] -> [P.ModuleName] -> ([P.Module], [P.ModuleName])

takeModulesByName modules names =

first (map fst) (takeModulesByName' modules (map (,()) names))

-- |

takeModulesByName' :: [P.Module] -> [(P.ModuleName, a)] -> ([(P.Module, a)], [P.ModuleName])

takeModulesByName' modules = foldl go ([], [])

where

go (ms, missing) (name, x) =

case find ((== name) . P.getModuleName) modules of

Just m -> ((m, x) : ms, missing)

Nothing -> (ms, name : missing)

dumpTags :: [FilePath] -> ([(String, P.Module)] -> [String]) -> IO ()

dumpTags input renderTags = do

e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (nub input)

case e of

Left err -> do

hPutStrLn stderr (show err)

exitFailure

Right ms ->

ldump (renderTags (pairs ms))

where

pairs :: [(Maybe String, m)] -> [(String, m)]

pairs = map (first (fromMaybe ""))

ldump :: [String] -> IO ()

ldump = mapM_ putStrLn

parseFile :: FilePath -> IO (FilePath, String)

parseFile input = (,) input <$> readFile input

inputFile :: Parser FilePath

inputFile = strArgument $

metavar "FILE"

<> help "The input .purs file(s)"

instance Read Format where

readsPrec _ "etags" = [(Etags, "")]

readsPrec _ "ctags" = [(Ctags, "")]

readsPrec _ "markdown" = [(Markdown, "")]

readsPrec _ _ = []

format :: Parser Format

format = option auto $ value Markdown

<> long "format"

<> metavar "FORMAT"

<> help "Set output FORMAT (markdown | etags | ctags)"

docgenModule :: Parser String

docgenModule = strOption $

long "docgen"

<> help "A list of module names which should appear in the output. This can optionally include file paths to write individual modules to, by separating with a colon ':'. For example, Prelude:docs/Prelude.md. This option may be specified multiple times."

pscDocsOptions :: Parser (Format, [FilePath], [String])

pscDocsOptions = (,,) <$> format <*> many inputFile <*> many docgenModule

parseDocgen :: [String] -> Either String DocgenOutput

parseDocgen [] = Right EverythingToStdOut

parseDocgen xs = go xs

where

go = intersperse " "

>>> concat

>>> words

>>> map parseItem

>>> combine

data DocgenOutputItem

= IToStdOut P.ModuleName

| IToFile (P.ModuleName, FilePath)

parseItem :: String -> DocgenOutputItem

parseItem s = case elemIndex ':' s of

Just i ->

s # splitAt i

>>> first P.moduleNameFromString

>>> second (drop 1)

>>> IToFile

Nothing ->

IToStdOut (P.moduleNameFromString s)

where

infixr 1 #

(#) = flip ($)

combine :: [DocgenOutputItem] -> Either String DocgenOutput

combine [] = Right EverythingToStdOut

combine (x:xs) = foldM go (initial x) xs

where

initial (IToStdOut m) = ToStdOut [m]

initial (IToFile m) = ToFiles [m]

go (ToStdOut ms) (IToStdOut m) = Right (ToStdOut (m:ms))

go (ToFiles ms) (IToFile m) = Right (ToFiles (m:ms))

go _ _ = Left "Can't mix module names and module name/file path pairs in the same invocation."

buildOptions :: (Format, [FilePath], [String]) -> IO PSCDocsOptions

buildOptions (fmt, input, mapping) =

case parseDocgen mapping of

Right mapping' -> return (PSCDocsOptions fmt input mapping')

Left err -> do

hPutStrLn stderr "psc-docs: error in --docgen option:"

hPutStrLn stderr (" " ++ err)

exitFailure

main :: IO ()

main = execParser opts >>= buildOptions >>= docgen

where

opts = info (version <*> helper <*> pscDocsOptions) infoModList

infoModList = fullDesc <> headerInfo <> footerInfo

headerInfo = header "psc-docs - Generate Markdown documentation from PureScript source files"

footerInfo = footerDoc $ Just $ PP.vcat

[ examples, PP.empty, PP.text ("psc-docs " ++ showVersion Paths.version) ]

version :: Parser (a -> a)

version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden

examples :: PP.Doc

examples =

PP.vcat $ map PP.text

[ "Examples:"

, " print documentation for Data.List to stdout:"

, " psc-docs src/**/*.purs bower_components/*/src/**/*.purs \\"

, " --docgen Data.List"

, ""

, " write documentation for Data.List to docs/Data.List.md:"

, " psc-docs src/**/*.purs bower_components/*/src/**/*.purs \\"

, " --docgen Data.List:docs/Data.List.md"

, ""

, " write documentation for Data.List to docs/Data.List.md, and"

, " documentation for Data.List.Lazy to docs/Data.List.Lazy.md:"

, " psc-docs src/**/*.purs bower_components/*/src/**/*.purs \\"

, " --docgen Data.List:docs/Data.List.md \\"

, " --docgen Data.List.Lazy:docs/Data.List.Lazy.md"

]