git.iko.soy/elk
on master help sign in
Clean up elm-doc Main module
6336b9aEvan Czaplicki
src/Docs.hs+201−195
compare with master
unifiedsplit
@@ -10,215 +10,221 @@ import System.IO
10
10
11import Control.Applicative ((<$>))
11import Control.Applicative ((<$>))
12import Control.Arrow (second)
12import Control.Arrow (second)
13−import Data.Aeson
14−import Data.Aeson.Encode.Pretty
13+import qualified Data.Aeson.Encode.Pretty as Json
15−import Data.Aeson.Types (Pair)
16−import qualified Data.List as List
17import qualified Data.Map as Map
14import qualified Data.Map as Map
18−import qualified Data.ByteString.Lazy as BS
15+import qualified Data.ByteString.Lazy.Char8 as BS
19−import qualified Data.Text as Text
20
16
21−import qualified AST.Helpers as Help
17+import qualified AST.Type as Type
22−import qualified AST.Type as T
23−import qualified AST.Declaration as D
18+import qualified AST.Declaration as Decl
24−import qualified AST.Expression.Source as Src
19+import qualified AST.Expression.Source as Source
25import qualified AST.Variable as Var
20import qualified AST.Variable as Var
26
21
27−import Text.Parsec hiding (newline,spaces)
22+import Text.Parsec hiding (newline, spaces)
28−import Parse.Declaration (typeDecl,infixDecl)
23+import qualified Parse.Declaration as Parse (typeDecl, infixDecl)
29−import Parse.Expression (typeAnnotation)
24+import qualified Parse.Expression as Parse (typeAnnotation)
30−import Parse.Helpers
25+import qualified Parse.Helpers as Parse
31−import qualified Parse.Module as Module
26+import qualified Parse.Module as Parse (header)
27+import qualified Elm.Compiler.Module as Module
28+import qualified Elm.Docs as Docs
29+
30+
31+-- FLAGS
32
32
33data Flags = Flags
33data Flags = Flags
34− { files :: [FilePath] }
34+ { input :: FilePath
35+ , output :: Maybe FilePath
36+ }
35 deriving (Data,Typeable,Show,Eq)
37 deriving (Data,Typeable,Show,Eq)
36
38
39+
37defaultFlags :: Flags
40defaultFlags :: Flags
38defaultFlags = Flags
41defaultFlags = Flags
39− { files = def &= args &= typ "FILES"
42+ { input = def &= args &= typ "FILE"
43+
44+ , output = Nothing &= typFile
45+ &= help "file name for generated JSON documentation"
46+
40 } &= help "Generate documentation for Elm"
47 } &= help "Generate documentation for Elm"
41− &= summary ("Generate documentation for Elm, (c) Evan Czaplicki")
48+ &= summary "Generate documentation for Elm, (c) Evan Czaplicki"
42
49
43−main :: IO ()
44−main = do
45− flags <- cmdArgs defaultFlags
46− mapM_ parseFile (files flags)
47
50
51+-- GENERATE DOCUMENTATION
52+
53+main :: IO ()
54+main =
55+ do flags <- cmdArgs defaultFlags
56+ source <- readFile (input flags)
57+ case Parse.iParse documentation source of
58+ Right docs ->
59+ let json = Json.encodePretty' config docs in
60+ case output flags of
61+ Nothing -> BS.putStrLn json
62+ Just docPath ->
63+ do createDirectoryIfMissing True (dropFileName docPath)
64+ BS.writeFile docPath json
65+
66+ Left err ->
67+ do hPutStrLn stderr (show err)
68+ exitFailure
69+
70+
48−config :: Config
71+config :: Json.Config
72+config =
73+ Json.Config
74+ { Json.confIndent = 2
49−config = Config { confIndent = 2, confCompare = keyOrder keys }
75+ , Json.confCompare = Json.keyOrder keys
76+ }
50 where
77 where
51− keys = ["tag","name","document","comment","raw","aliases","datatypes"
78+ keys =
52− ,"values","typeVariables","type","constructors"]
79+ [ "tag", "name", "comment", "aliases", "types"
53−
80+ , "values", "func", "args", "type", "cases"
54−parseFile :: FilePath -> IO ()
55−parseFile path = do
56− source <- readFile path
57− case iParse docs source of
58− Right json -> do
59− putStrLn $ "Documenting " ++ path
60− let docPath = "docs" </> replaceExtension path ".json"
61− createDirectoryIfMissing True (dropFileName docPath)
62− BS.writeFile docPath (encodePretty' config json)
63− Left err -> do
64− hPutStrLn stderr $ "Parse error in " ++ path ++ " at " ++ show err
65− exitFailure
66−
67−docs :: IParser Value
68−docs = do
69− (name, _exports, structure) <- moduleDocs
70− things <- document
71− return $ documentToJson name structure things
72−
73−docComment :: IParser String
74−docComment = do
75− try (string "{-|")
76− contents <- closeComment
77− let reversed = dropWhile (`elem` " \n\r") . drop 2 $ reverse contents
78− return $ dropWhile (==' ') (reverse reversed)
79−
80−moduleDocs :: IParser (String, Var.Listing Var.Value, String)
81−moduleDocs = do
82− optional freshLine
83− (names,exports) <- Module.header
84− manyTill (string " " <|> newline <?> "more whitespace")
85− (lookAhead (string "{-|") <?> "module documentation comment")
86− structure <- docComment
87− return (List.intercalate "." names, exports, structure)
88−
89−document :: IParser [(String, D.SourceDecl, String)]
90−document = onFreshLines (\t ts -> ts ++ [t]) [] docThing
91−
92−docThing :: IParser (String, D.SourceDecl, String)
93−docThing = uncommentable <|> commented <|> uncommented ""
94− where
95− uncommentable = do
96− ifx <- infixDecl
97− return ("", ifx, "")
98−
99− commented = do
100− comment <- docComment
101− freshLine
102− uncommented comment
103−
104− uncommented comment = do
105− (src,def) <- withSource $ choice [ typeDecl, D.Definition <$> typeAnnotation ]
106− return (comment, def, src)
107−
108−
109−documentToJson :: String -> String -> [(String, D.SourceDecl, String)] -> Value
110−documentToJson name structure things =
111− object
112− [ "name" .= name
113− , "document" .= structure
114− , "values" .= toList values
115− , "aliases" .= toList aliases
116− , "datatypes" .= toList adts
117 ]
81 ]
82+
83+
84+-- PARSE DOCUMENTATION
85+
86+documentation :: Parse.IParser Docs.Documentation
87+documentation =
88+ do optional Parse.freshLine
89+ (names, _exports) <- Parse.header
90+
91+ manyTill (string " " <|> Parse.newline <?> "more whitespace")
92+ (lookAhead (string "{-|") <?> "module documentation comment")
93+
94+ overview <- docComment
95+
96+ decls <- allDeclarations
97+
98+ let (aliases, unions, values) = categorizeDeclarations decls
99+
100+ return (Docs.Documentation (Module.Name names) overview aliases unions values)
101+
102+
103+docComment :: Parse.IParser String
104+docComment =
105+ do try (string "{-|")
106+ contents <- Parse.closeComment
107+
108+ let reversed =
109+ dropWhile (`elem` " \n\r") . drop 2 $ reverse contents
110+
111+ return $ dropWhile (==' ') (reverse reversed)
112+
113+
114+allDeclarations :: Parse.IParser [(String, Decl.SourceDecl)]
115+allDeclarations =
116+ Parse.onFreshLines (:) [] declaration
117+
118+
119+declaration :: Parse.IParser (String, Decl.SourceDecl)
120+declaration =
121+ uncommentable <|> commented <|> uncommented ""
122+ where
123+ uncommentable =
124+ (,) "" <$> Parse.infixDecl
125+
126+ commented =
127+ do comment <- docComment
128+ Parse.freshLine
129+ uncommented comment
130+
131+ uncommented comment =
132+ (,) comment
133+ <$> choice [ Parse.typeDecl, Decl.Definition <$> Parse.typeAnnotation ]
134+
135+
136+-- CATEGORIZE DECLARATIONS
137+
138+data CategoryInfo = CategoryInfo
139+ { aliases :: [Docs.Alias]
140+ , unions :: [Docs.Union]
141+ , values :: Map.Map String Docs.Value
142+ , infixes :: Map.Map String (String, Int)
143+ }
144+
145+
146+emptyInfo :: CategoryInfo
147+emptyInfo =
148+ CategoryInfo [] [] Map.empty Map.empty
149+
150+
151+categorizeDeclarations :: [(String, Decl.SourceDecl)] -> ([Docs.Alias], [Docs.Union], [Docs.Value])
152+categorizeDeclarations decls =
153+ (aliases, unions, Map.elems values)
118 where
154 where
119− (values, aliases, adts) =
155+ (CategoryInfo aliases unions rawValues infixes) =
120− collect Map.empty Map.empty Map.empty Map.empty things
156+ foldr collectInfo emptyInfo decls
121−
157+
122− toList :: Map.Map String [Pair] -> [Value]
158+ values =
123− toList dict =
159+ Map.union
124− map object (Map.elems dict)
125−
126−type Pairs = Map.Map String [Pair]
127−
128−collect :: Map.Map String (D.Assoc, Int) -> Pairs -> Pairs -> Pairs
129− -> [(String, D.SourceDecl, String)]
130− -> (Pairs, Pairs, Pairs)
131−collect infixes types aliases adts things =
132− case things of
133− [] -> (Map.union customOps nonCustomOps, aliases, adts)
134− where
135− nonCustomOps = Map.mapWithKey addDefaultInfix $ Map.difference types infixes
136− addDefaultInfix name pairs
137− | all Help.isSymbol name = addInfix (D.L, 9 :: Int) pairs
138− | otherwise = pairs
139−
140− customOps = Map.intersectionWith addInfix infixes types
160+ (Map.intersectionWith addInfixInfo rawValues infixes)
141− addInfix (assoc,prec) pairs =
161+ rawValues
142− [ "associativity" .= show assoc, "precedence" .= prec ] ++ pairs
162+
143−
163+
144− (comment, decl, source) : rest ->
164+addInfixInfo :: Docs.Value -> (String, Int) -> Docs.Value
145− let insert name fields dict = Map.insert name (obj name fields) dict
165+addInfixInfo value infixInfo =
146− obj name fields =
166+ value { Docs.valueAssocPrec = Just infixInfo }
147− [ "name" .= name
167+
148− , "raw" .= source
168+
149− , "comment" .= comment
169+collectInfo :: (String, Decl.SourceDecl) -> CategoryInfo -> CategoryInfo
150− ] ++ fields
170+collectInfo (comment, decl) info =
171+ case decl of
172+ Decl.Definition def ->
173+ case def of
174+ Source.Definition _ _ -> error errorMessage
175+ Source.TypeAnnotation name tipe ->
176+ let value = Docs.Value name comment (toDocType tipe) Nothing
177+ in
178+ info { values = Map.insert name value (values info) }
179+
180+ Decl.Datatype name args cases ->
181+ let cases' = map (second (map toDocType)) cases
182+ union = Docs.Union name comment args cases'
183+ in
184+ info { unions = union : unions info }
185+
186+ Decl.TypeAlias name args tipe ->
187+ let alias = Docs.Alias name comment args (toDocType tipe)
151 in
188 in
152− case decl of
189+ info { aliases = alias : aliases info }
153− D.Definition def ->
190+
154− case def of
155− Src.TypeAnnotation name tipe ->
156− collect infixes (insert name [ "type" .= tipe ] types) aliases adts rest
157−
158− Src.Definition _ _ ->
159− collect infixes types aliases adts rest
160−
161− D.Datatype name vars ctors ->
162− let tipe = T.App (T.Type (Var.Raw name)) (map T.Var vars)
163− fields = [ "typeVariables" .= vars
164− , "constructors" .= map (ctorToJson tipe) ctors
165− ]
166− in collect infixes types aliases (insert name fields adts) rest
167−
168− D.TypeAlias name vars tipe ->
169− let fields = [ "typeVariables" .= vars, "type" .= tipe ]
170− in collect infixes types (insert name fields aliases) adts rest
171−
172− D.Port _ ->
173− collect infixes types aliases adts rest
174−
175− D.Fixity assoc prec name ->
191+ Decl.Fixity assoc prec name ->
176− collect (Map.insert name (assoc,prec) infixes) types aliases adts rest
192+ let infixInfo = (Decl.assocToString assoc, prec)
177−
193+ in
178−
194+ info { infixes = Map.insert name infixInfo (infixes info) }
179−instance Var.ToString var => ToJSON (T.Type var) where
195+
180− toJSON tipe =
196+ Decl.Port _ ->
181− object (getFields tipe)
197+ error errorMessage
182− where
198+
183− getFields tipe =
199+
184− case tipe of
200+errorMessage :: String
185− T.Lambda _ _ ->
201+errorMessage =
186− let tipes = T.collectLambdas tipe in
202+ "there appears to be a bug in this tool.\n" ++
187− [ "tag" .= ("function" :: Text.Text)
188− , "args" .= toJSON (init tipes)
189− , "result" .= toJSON (last tipes)
190− ]
191−
192− T.Var x ->
193− [ "tag" .= ("var" :: Text.Text)
194− , "name" .= toJSON x
195− ]
196−
197− T.Type name ->
198− [ "tag" .= ("adt" :: Text.Text)
199− , "name" .= toJSON (Var.toString name)
200− , "args" .= ([] :: [()])
201− ]
202−
203− T.App (T.Type name) ts ->
204− [ "tag" .= ("adt" :: Text.Text)
205− , "name" .= toJSON (Var.toString name)
206− , "args" .= map toJSON ts
207− ]
208−
209− T.App _ _ -> error "This is an unexpected error with elm-doc, please report it at <https://github.com/elm-lang/Elm/issues>"
203+ "Please report it to <https://github.com/elm-lang/Elm/issues>"
210−
204+
211− T.Record fields ext ->
205+
212− [ "tag" .= ("record" :: Text.Text)
206+-- AST TYPE TO DOC TYPE
213− , "fields" .= toJSON (map (toJSON . second toJSON) fields)
207+
214− , "extension" .= toJSON ext
208+toDocType :: Type.Type Var.Raw -> Docs.Type
215− ]
209+toDocType astType =
216−
210+ case astType of
211+ Type.Lambda t1 t2 ->
212+ Docs.Lambda (toDocType t1) (toDocType t2)
213+
214+ Type.Var x ->
215+ Docs.Var x
216+
217+ Type.Type (Var.Raw name) ->
218+ Docs.Type name
219+
220+ Type.App t ts ->
221+ Docs.App (toDocType t) (map toDocType ts)
222+
223+ Type.Record fields ext ->
224+ Docs.Record (map (second toDocType) fields) (fmap toDocType ext)
225+
217− T.Aliased _ t ->
226+ Type.Aliased _ t ->
218− getFields t
227+ toDocType t
219−
228+
220−ctorToJson :: T.RawType -> (String, [T.RawType]) -> Value
229+
221−ctorToJson tipe (ctor, tipes) =
230+
222− object [ "name" .= ctor
223− , "type" .= foldr T.Lambda tipe tipes
224− ]