177 lines
No EOL
6 KiB
Haskell
177 lines
No EOL
6 KiB
Haskell
{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}
|
|
module Main where
|
|
|
|
import System.Console.CmdArgs
|
|
import System.Directory
|
|
import System.FilePath
|
|
import System.Exit
|
|
|
|
import Control.Applicative ((<$>), (<*>))
|
|
import Data.Aeson
|
|
import Data.Aeson.Encode.Pretty
|
|
import qualified Data.List as List
|
|
import qualified Data.Map as Map
|
|
import qualified Data.ByteString.Lazy as BS
|
|
import qualified Data.Text as Text
|
|
|
|
import SourceSyntax.Helpers (isSymbol)
|
|
import SourceSyntax.Type (Type(..))
|
|
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)
|
|
import Parse.Helpers
|
|
import Parse.Module (moduleDef)
|
|
|
|
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")
|
|
|
|
main = do
|
|
flags <- cmdArgs defaultFlags
|
|
mapM parseFile (files flags)
|
|
|
|
config = Config { confIndent = 2, confCompare = keyOrder keys }
|
|
where
|
|
keys = ["name","document","comment","raw","aliases","datatypes"
|
|
,"values","typeVariables","type","constructors"]
|
|
|
|
parseFile path = do
|
|
source <- readFile path
|
|
case iParse docs source of
|
|
Right json -> do
|
|
putStrLn $ "Documenting " ++ path
|
|
let docPath = "docs" </> replaceExtension path ".json"
|
|
createDirectoryIfMissing True (dropFileName docPath)
|
|
BS.writeFile docPath (encodePretty' config json)
|
|
Left err -> do
|
|
putStrLn $ "Parse error in " ++ path ++ " at " ++ show err
|
|
exitFailure
|
|
|
|
docs :: IParser Value
|
|
docs = do
|
|
(name, exports, structure) <- moduleDocs
|
|
things <- document
|
|
return $ documentToJson name exports structure things
|
|
|
|
docComment :: IParser String
|
|
docComment = do
|
|
try (string "{-|")
|
|
contents <- closeComment
|
|
let reversed = dropWhile (`elem` " \n\r") . drop 2 $ reverse contents
|
|
return $ dropWhile (==' ') (reverse reversed)
|
|
|
|
moduleDocs = do
|
|
(names,exports) <- anyThen moduleDef
|
|
anyThen (lookAhead (string "{-|"))
|
|
structure <- docComment
|
|
return (List.intercalate "." names, exports, structure)
|
|
|
|
document :: IParser [(String, Declaration t v, String)]
|
|
document = go []
|
|
where
|
|
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'
|
|
|
|
-- returns whether the end of file has been reached
|
|
chompUntilFreshLine :: IParser Bool
|
|
chompUntilFreshLine =
|
|
anyThen . choice $
|
|
[ try (simpleNewline >> notFollowedBy (string " ")) >> return False
|
|
, eof >> return True ]
|
|
|
|
docThing :: IParser (String, Declaration t v, String)
|
|
docThing = uncommentable <|> commented <|> uncommented ""
|
|
where
|
|
uncommentable = do
|
|
ifx <- infixDecl
|
|
return ("", ifx, "")
|
|
|
|
commented = do
|
|
comment <- docComment
|
|
freshLine
|
|
uncommented comment
|
|
|
|
uncommented comment = do
|
|
(src,def) <- withSource $ choice [ alias, datatype, Definition <$> typeAnnotation ]
|
|
return (comment, def, src)
|
|
|
|
|
|
documentToJson 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
|
|
|
|
exportMap = Map.fromList (zip exports exports)
|
|
filterPublics dict =
|
|
case Map.null exportMap of
|
|
True -> dict
|
|
False -> Map.filterWithKey (\k _ -> Map.member k exportMap) dict
|
|
|
|
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
|
|
|
|
customOps = Map.intersectionWith addInfix infixes types
|
|
addInfix (assoc,prec) pairs =
|
|
[ "associativity" .= show assoc, "precedence" .= prec ] ++ pairs
|
|
|
|
(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 [ "type" .= tipe ] types) aliases adts rest
|
|
TypeAlias name vars tipe ->
|
|
let fields = ["typeVariables" .= vars, "type" .= tipe ]
|
|
in collect infixes types (insert name fields aliases) adts rest
|
|
Datatype name vars ctors ->
|
|
let tipe = Data name (map Var vars)
|
|
fields = ["typeVariables" .= vars, "constructors" .= map (ctorToJson tipe) ctors ]
|
|
in collect infixes types aliases (insert name fields adts) rest
|
|
where
|
|
insert name fields dict = Map.insert name (obj name fields) dict
|
|
obj name fields =
|
|
[ "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)
|
|
EmptyRecord -> object []
|
|
Record fields ext -> object $ map (\(n,t) -> Text.pack n .= toJSON t) fields'
|
|
where fields' = case ext of
|
|
EmptyRecord -> fields
|
|
_ -> ("_",ext) : fields
|
|
|
|
ctorToJson tipe (ctor, tipes) =
|
|
object [ "name" .= ctor
|
|
, "type" .= foldr Lambda tipe tipes ] |