2013-09-05 00:40:05 +00:00
|
|
|
{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}
|
2013-03-14 08:04:51 +00:00
|
|
|
module Main where
|
|
|
|
|
2013-09-05 00:40:05 +00:00
|
|
|
import System.Console.CmdArgs
|
2013-09-05 17:09:45 +00:00
|
|
|
import System.Directory
|
2013-09-05 00:40:05 +00:00
|
|
|
import System.FilePath
|
|
|
|
import System.Exit
|
|
|
|
|
2013-03-14 08:04:51 +00:00
|
|
|
import Control.Applicative ((<$>), (<*>))
|
2013-09-05 00:40:05 +00:00
|
|
|
import Data.Aeson
|
|
|
|
import qualified Data.List as List
|
|
|
|
import qualified Data.Map as Map
|
|
|
|
import qualified Data.ByteString.Lazy as BS
|
|
|
|
|
|
|
|
import SourceSyntax.Helpers (isSymbol)
|
|
|
|
import SourceSyntax.Declaration (Declaration(..), Assoc(..))
|
|
|
|
import SourceSyntax.Expression (Def(..))
|
|
|
|
|
|
|
|
import Text.Parsec hiding (newline,spaces)
|
|
|
|
import Parse.Declaration (alias,datatype,infixDecl)
|
|
|
|
import Parse.Expression (typeAnnotation)
|
2013-06-14 05:59:14 +00:00
|
|
|
import Parse.Helpers
|
|
|
|
import Parse.Module (moduleDef)
|
2013-09-05 00:40:05 +00:00
|
|
|
|
|
|
|
data Flags = Flags
|
|
|
|
{ files :: [FilePath] }
|
|
|
|
deriving (Data,Typeable,Show,Eq)
|
|
|
|
|
|
|
|
defaultFlags = Flags
|
|
|
|
{ files = def &= args &= typ "FILES"
|
|
|
|
} &= help "Generate documentation for Elm"
|
|
|
|
&= summary ("Generate documentation for Elm, (c) Evan Czaplicki")
|
2013-03-14 08:04:51 +00:00
|
|
|
|
|
|
|
main = do
|
2013-09-05 00:40:05 +00:00
|
|
|
flags <- cmdArgs defaultFlags
|
|
|
|
mapM parseFile (files flags)
|
|
|
|
|
|
|
|
parseFile path = do
|
|
|
|
source <- readFile path
|
|
|
|
case iParse docs "" source of
|
|
|
|
Right json -> do
|
|
|
|
putStrLn $ "Documenting " ++ path
|
2013-09-05 17:09:45 +00:00
|
|
|
createDirectoryIfMissing True "docs"
|
2013-09-05 00:40:05 +00:00
|
|
|
BS.writeFile ("docs" </> replaceExtension path ".json") (encode json)
|
|
|
|
Left err -> do
|
|
|
|
putStrLn $ "Parse error in " ++ path ++ " at " ++ show err
|
|
|
|
exitFailure
|
|
|
|
|
|
|
|
docs :: IParser Value
|
|
|
|
docs = do
|
2013-05-05 01:19:54 +00:00
|
|
|
optional freshLine
|
2013-05-16 20:11:40 +00:00
|
|
|
(names, exports) <- option (["Main"],[]) moduleDef
|
2013-09-05 17:09:45 +00:00
|
|
|
optional freshLine
|
|
|
|
structure <- option "" docComment
|
2013-09-05 00:40:05 +00:00
|
|
|
things <- document
|
|
|
|
return $ toJson (List.intercalate "." names) exports structure things
|
|
|
|
|
|
|
|
docComment :: IParser String
|
|
|
|
docComment = do
|
|
|
|
try (string "{-|")
|
|
|
|
contents <- closeComment
|
|
|
|
return (init (init contents))
|
|
|
|
|
|
|
|
document :: IParser [(String, Declaration t v, String)]
|
|
|
|
document = go []
|
2013-03-21 13:27:04 +00:00
|
|
|
where
|
2013-09-05 00:40:05 +00:00
|
|
|
go things = do
|
|
|
|
thing <- optionMaybe docThing
|
|
|
|
let things' = case thing of
|
|
|
|
Nothing -> things
|
|
|
|
Just t -> things ++ [t]
|
|
|
|
done <- chompUntilFreshLine
|
|
|
|
case done of
|
|
|
|
True -> return things'
|
|
|
|
False -> go things'
|
2013-05-05 01:19:54 +00:00
|
|
|
|
2013-09-05 00:40:05 +00:00
|
|
|
-- returns whether the end of file has been reached
|
|
|
|
chompUntilFreshLine :: IParser Bool
|
|
|
|
chompUntilFreshLine =
|
|
|
|
anyThen . choice $
|
|
|
|
[ try (simpleNewline >> notFollowedBy (string " ")) >> return False
|
|
|
|
, eof >> return True ]
|
2013-05-16 20:11:40 +00:00
|
|
|
|
2013-09-05 00:40:05 +00:00
|
|
|
docThing :: IParser (String, Declaration t v, String)
|
2013-09-05 17:09:45 +00:00
|
|
|
docThing = uncommentable <|> commented <|> uncommented ""
|
2013-09-05 00:40:05 +00:00
|
|
|
where
|
2013-09-05 17:09:45 +00:00
|
|
|
uncommentable = do
|
2013-09-05 00:40:05 +00:00
|
|
|
ifx <- infixDecl
|
|
|
|
return ("", ifx, "")
|
|
|
|
|
|
|
|
commented = do
|
2013-09-05 17:09:45 +00:00
|
|
|
comment <- docComment
|
2013-09-05 00:40:05 +00:00
|
|
|
freshLine
|
2013-09-05 17:09:45 +00:00
|
|
|
uncommented comment
|
|
|
|
|
|
|
|
uncommented comment = do
|
2013-09-05 00:40:05 +00:00
|
|
|
(src,def) <- withSource $ choice [ alias, datatype, Definition <$> typeAnnotation ]
|
|
|
|
return (comment, def, src)
|
|
|
|
|
|
|
|
|
|
|
|
toJson name exports structure things =
|
|
|
|
object $ [ "name" .= name
|
|
|
|
, "document" .= structure
|
|
|
|
, "values" .= toList values
|
|
|
|
, "aliases" .= toList aliases
|
|
|
|
, "datatypes" .= toList adts
|
|
|
|
]
|
|
|
|
where
|
|
|
|
(values, aliases, adts) = collect Map.empty Map.empty Map.empty Map.empty things
|
|
|
|
|
|
|
|
toList dict = map object . Map.elems $ filterPublics dict
|
2013-05-05 01:19:54 +00:00
|
|
|
|
2013-09-05 00:40:05 +00:00
|
|
|
exportMap = Map.fromList (zip exports exports)
|
|
|
|
filterPublics dict =
|
|
|
|
case Map.null exportMap of
|
|
|
|
True -> dict
|
|
|
|
False -> Map.filterWithKey (\k _ -> Map.member k exportMap) dict
|
2013-05-05 01:19:54 +00:00
|
|
|
|
2013-09-05 00:40:05 +00:00
|
|
|
collect infixes types aliases adts things =
|
|
|
|
case things of
|
|
|
|
[] -> (Map.union customOps nonCustomOps, aliases, adts)
|
|
|
|
where
|
|
|
|
nonCustomOps = Map.mapWithKey addDefaultInfix $ Map.difference types infixes
|
|
|
|
addDefaultInfix name pairs
|
|
|
|
| all isSymbol name = addInfix (L, 9 :: Int) pairs
|
|
|
|
| otherwise = pairs
|
2013-03-21 09:29:23 +00:00
|
|
|
|
2013-09-05 00:40:05 +00:00
|
|
|
customOps = Map.intersectionWith addInfix infixes types
|
|
|
|
addInfix (assoc,prec) pairs =
|
|
|
|
[ "associativity" .= show assoc, "precedence" .= prec ] ++ pairs
|
2013-03-21 09:29:23 +00:00
|
|
|
|
2013-09-05 00:40:05 +00:00
|
|
|
(comment, decl, source) : rest ->
|
|
|
|
case decl of
|
|
|
|
Fixity assoc prec name ->
|
|
|
|
collect (Map.insert name (assoc,prec) infixes) types aliases adts rest
|
|
|
|
Definition (TypeAnnotation name tipe) ->
|
|
|
|
collect infixes (insert name [] types) aliases adts rest
|
|
|
|
TypeAlias name vars tipe ->
|
|
|
|
collect infixes types (insert name ["vars" .= vars] aliases) adts rest
|
|
|
|
Datatype name vars ctors ->
|
|
|
|
collect infixes types aliases (insert name ["vars" .= vars] adts) rest
|
|
|
|
where
|
|
|
|
insert name fields dict = Map.insert name (obj name fields) dict
|
|
|
|
obj name fields =
|
|
|
|
[ "name" .= name, "raw" .= source, "comment" .= comment ] ++ fields
|