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-11-26 05:12:10 +00:00
|
|
|
import System.IO
|
2013-09-05 00:40:05 +00:00
|
|
|
|
2014-01-13 08:23:23 +00:00
|
|
|
import Control.Applicative ((<$>))
|
2013-09-05 00:40:05 +00:00
|
|
|
import Data.Aeson
|
2013-09-05 17:48:37 +00:00
|
|
|
import Data.Aeson.Encode.Pretty
|
2013-09-05 00:40:05 +00:00
|
|
|
import qualified Data.List as List
|
|
|
|
import qualified Data.Map as Map
|
|
|
|
import qualified Data.ByteString.Lazy as BS
|
2013-09-05 22:33:03 +00:00
|
|
|
import qualified Data.Text as Text
|
2013-09-05 00:40:05 +00:00
|
|
|
|
|
|
|
import SourceSyntax.Helpers (isSymbol)
|
2013-09-05 22:33:03 +00:00
|
|
|
import SourceSyntax.Type (Type(..))
|
2014-01-03 07:45:10 +00:00
|
|
|
import qualified SourceSyntax.Expression as E
|
|
|
|
import qualified SourceSyntax.Declaration as D
|
2013-09-05 00:40:05 +00:00
|
|
|
|
|
|
|
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)
|
|
|
|
|
2013-09-05 22:44:40 +00:00
|
|
|
config = Config { confIndent = 2, confCompare = keyOrder keys }
|
|
|
|
where
|
|
|
|
keys = ["name","document","comment","raw","aliases","datatypes"
|
|
|
|
,"values","typeVariables","type","constructors"]
|
|
|
|
|
2013-09-05 00:40:05 +00:00
|
|
|
parseFile path = do
|
|
|
|
source <- readFile path
|
2013-09-15 20:42:19 +00:00
|
|
|
case iParse docs source of
|
2013-09-05 00:40:05 +00:00
|
|
|
Right json -> do
|
|
|
|
putStrLn $ "Documenting " ++ path
|
2013-09-05 17:55:30 +00:00
|
|
|
let docPath = "docs" </> replaceExtension path ".json"
|
|
|
|
createDirectoryIfMissing True (dropFileName docPath)
|
2013-09-05 22:44:40 +00:00
|
|
|
BS.writeFile docPath (encodePretty' config json)
|
2013-09-05 00:40:05 +00:00
|
|
|
Left err -> do
|
2013-11-26 05:12:10 +00:00
|
|
|
hPutStrLn stderr $ "Parse error in " ++ path ++ " at " ++ show err
|
2013-09-05 00:40:05 +00:00
|
|
|
exitFailure
|
|
|
|
|
|
|
|
docs :: IParser Value
|
|
|
|
docs = do
|
2013-09-05 17:48:37 +00:00
|
|
|
(name, exports, structure) <- moduleDocs
|
2013-09-05 00:40:05 +00:00
|
|
|
things <- document
|
2013-09-05 22:33:03 +00:00
|
|
|
return $ documentToJson name exports structure things
|
2013-09-05 00:40:05 +00:00
|
|
|
|
|
|
|
docComment :: IParser String
|
|
|
|
docComment = do
|
|
|
|
try (string "{-|")
|
|
|
|
contents <- closeComment
|
2013-09-09 22:58:43 +00:00
|
|
|
let reversed = dropWhile (`elem` " \n\r") . drop 2 $ reverse contents
|
|
|
|
return $ dropWhile (==' ') (reverse reversed)
|
2013-09-05 17:48:37 +00:00
|
|
|
|
|
|
|
moduleDocs = do
|
2013-10-14 18:59:54 +00:00
|
|
|
optional freshLine
|
|
|
|
(names,exports) <- moduleDef
|
|
|
|
manyTill (string " " <|> newline <?> "more whitespace")
|
|
|
|
(lookAhead (string "{-|") <?> "module documentation comment")
|
2013-09-05 17:48:37 +00:00
|
|
|
structure <- docComment
|
|
|
|
return (List.intercalate "." names, exports, structure)
|
2013-09-05 00:40:05 +00:00
|
|
|
|
2014-01-03 07:45:10 +00:00
|
|
|
document :: IParser [(String, D.ParseDeclaration, String)]
|
2013-10-17 17:40:25 +00:00
|
|
|
document = onFreshLines (\t ts -> ts ++ [t]) [] docThing
|
2013-05-16 20:11:40 +00:00
|
|
|
|
2014-01-03 07:45:10 +00:00
|
|
|
docThing :: IParser (String, D.ParseDeclaration, 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
|
2014-01-03 07:45:10 +00:00
|
|
|
(src,def) <- withSource $ choice [ alias, datatype, D.Definition <$> typeAnnotation ]
|
2013-09-05 00:40:05 +00:00
|
|
|
return (comment, def, src)
|
|
|
|
|
|
|
|
|
2013-09-05 22:33:03 +00:00
|
|
|
documentToJson name exports structure things =
|
2013-09-05 00:40:05 +00:00
|
|
|
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
|
2014-01-03 07:45:10 +00:00
|
|
|
| all isSymbol name = addInfix (D.L, 9 :: Int) pairs
|
2013-09-05 00:40:05 +00:00
|
|
|
| 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
|
2014-01-03 07:45:10 +00:00
|
|
|
D.Fixity assoc prec name ->
|
2013-09-05 00:40:05 +00:00
|
|
|
collect (Map.insert name (assoc,prec) infixes) types aliases adts rest
|
2014-01-03 07:45:10 +00:00
|
|
|
D.Definition (E.TypeAnnotation name tipe) ->
|
2013-09-05 22:33:03 +00:00
|
|
|
collect infixes (insert name [ "type" .= tipe ] types) aliases adts rest
|
2014-01-03 07:45:10 +00:00
|
|
|
D.TypeAlias name vars tipe derivations ->
|
2013-12-24 00:51:15 +00:00
|
|
|
let fields = ["typeVariables" .= vars, "type" .= tipe, "deriving" .= derivations ]
|
2013-09-05 22:33:03 +00:00
|
|
|
in collect infixes types (insert name fields aliases) adts rest
|
2014-01-03 07:45:10 +00:00
|
|
|
D.Datatype name vars ctors derivations ->
|
2013-09-05 22:33:03 +00:00
|
|
|
let tipe = Data name (map Var vars)
|
2013-12-24 00:51:15 +00:00
|
|
|
fields = ["typeVariables" .= vars
|
|
|
|
, "constructors" .= map (ctorToJson tipe) ctors
|
|
|
|
, "deriving" .= derivations ]
|
2013-09-05 22:33:03 +00:00
|
|
|
in collect infixes types aliases (insert name fields adts) rest
|
2013-09-05 00:40:05 +00:00
|
|
|
where
|
|
|
|
insert name fields dict = Map.insert name (obj name fields) dict
|
|
|
|
obj name fields =
|
2013-09-05 22:33:03 +00:00
|
|
|
[ "name" .= name, "raw" .= source, "comment" .= comment ] ++ fields
|
|
|
|
|
|
|
|
instance ToJSON Type where
|
|
|
|
toJSON tipe =
|
|
|
|
case tipe of
|
|
|
|
Lambda t1 t2 -> toJSON [ "->", toJSON t1, toJSON t2 ]
|
|
|
|
Var x -> toJSON x
|
|
|
|
Data name ts -> toJSON (toJSON name : map toJSON ts)
|
|
|
|
Record fields ext -> object $ map (\(n,t) -> Text.pack n .= toJSON t) fields'
|
|
|
|
where fields' = case ext of
|
2014-01-13 08:23:23 +00:00
|
|
|
Nothing -> fields
|
|
|
|
Just x -> ("_", Var x) : fields
|
2013-09-05 22:33:03 +00:00
|
|
|
|
|
|
|
ctorToJson tipe (ctor, tipes) =
|
|
|
|
object [ "name" .= ctor
|
2013-12-24 00:51:15 +00:00
|
|
|
, "type" .= foldr Lambda tipe tipes ]
|
|
|
|
|
2014-01-03 07:45:10 +00:00
|
|
|
instance ToJSON D.Derivation where
|
2013-12-24 00:51:15 +00:00
|
|
|
toJSON = toJSON . show
|