git.iko.soy/elk
on 00a3069 help sign in
elk/src/Elm/Docs.hs
525 lines 13 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Elm.Docs
4 ( Documentation
5 , toDict
6 , Module(..)
7 , fromModule
8 , Union(..)
9 , Alias(..)
10 , Value(..)
11 , Binop(..)
12 , Binop.Associativity(..)
13 , Binop.Precedence(..)
14 , decoder
15 , encode
16 )
17 where
20import Control.Monad (foldM)
21import qualified Data.ByteString as B
22import qualified Data.List as List
23import Data.Map ((!))
24import qualified Data.Map as Map
25import qualified Data.Text as Text
26import qualified Data.Text.Encoding as Text
28import qualified AST.Canonical as Can
29import qualified AST.Module.Name as ModuleName
30import qualified AST.Utils.Binop as Binop
31import qualified Data.OneOrMore as OneOrMore
32import qualified Elm.Compiler.Module as Module
33import qualified Elm.Compiler.Type as Type
34import qualified Elm.Compiler.Type.Extract as Extract
35import qualified Elm.Name as N
36import qualified Json.Decode as D
37import qualified Json.Encode as E
38import Json.Encode ((==>))
39import qualified Reporting.Annotation as A
40import qualified Reporting.Error as Error
41import qualified Reporting.Error.Docs as E
42import qualified Reporting.Region as R
43import qualified Reporting.Result as Result
44import Parse.Primitives (Parser)
45import qualified Parse.Primitives as P
46import qualified Parse.Primitives.Symbol as Symbol
47import qualified Parse.Primitives.Variable as Var
48import qualified Parse.Primitives.Whitespace as W
52-- DOCUMENTATION
55type Documentation =
56 Map.Map N.Name Module
59toDict :: [Module] -> Documentation
60toDict modules =
61 Map.fromList (map toPair modules)
65toPair :: Module -> (N.Name, Module)
66toPair modul@(Module name _ _ _ _ _) =
67 (name, modul)
71-- MODULES
74data Module =
75 Module
76 { _name :: N.Name
77 , _comment :: Comment
78 , _unions :: Map.Map N.Name Union
79 , _aliases :: Map.Map N.Name Alias
80 , _values :: Map.Map N.Name Value
81 , _binops :: Map.Map N.Name Binop
82 }
85type Comment = Text.Text
88data Alias = Alias Comment [N.Name] Type.Type
89data Union = Union Comment [N.Name] [(N.Name, [Type.Type])]
90data Value = Value Comment Type.Type
91data Binop = Binop Comment Type.Type Binop.Associativity Binop.Precedence
95-- JSON ENCODE / DECODE
98encode :: Module -> E.Value
99encode (Module name comment unions aliases values binops) =
100 E.object $
101 [ "name" ==> Module.encode name
102 , "comment" ==> E.text comment
103 , "unions" ==> E.list encodeUnion (Map.toList unions)
104 , "aliases" ==> E.list encodeAlias (Map.toList aliases)
105 , "values" ==> E.list encodeValue (Map.toList values)
106 , "binops" ==> E.list encodeBinop (Map.toList binops)
107 ]
110decoder :: D.Decoder Error Module
111decoder =
112 Module
113 <$> D.field "name" Module.decoder
114 <*> D.field "comment" D.text
115 <*> D.field "unions" (dictDecoder union)
116 <*> D.field "aliases" (dictDecoder alias)
117 <*> D.field "values" (dictDecoder value)
118 <*> D.field "binops" (dictDecoder binop)
121dictDecoder :: D.Decoder Error a -> D.Decoder Error (Map.Map N.Name a)
122dictDecoder entryDecoder =
123 Map.fromList <$> D.list (named entryDecoder)
126named :: D.Decoder Error a -> D.Decoder Error (N.Name, a)
127named entryDecoder =
128 (,)
129 <$> D.field "name" D.text
130 <*> entryDecoder
133data Error
134 = BadAssociativity
135 | BadType
139-- UNION JSON
142encodeUnion :: (N.Name, Union) -> E.Value
143encodeUnion (name, Union comment args cases) =
144 E.object
145 [ "name" ==> E.text name
146 , "comment" ==> E.text comment
147 , "args" ==> E.list E.text args
148 , "cases" ==> E.list encodeCase cases
149 ]
152union :: D.Decoder Error Union
153union =
154 Union
155 <$> D.field "comment" D.text
156 <*> D.field "args" (D.list D.text)
157 <*> D.field "cases" (D.list caseDecoder)
160encodeCase :: ( N.Name, [Type.Type] ) -> E.Value
161encodeCase ( tag, args ) =
162 E.list id [ E.text tag, E.list Type.encode args ]
165caseDecoder :: D.Decoder Error ( N.Name, [Type.Type] )
166caseDecoder =
167 (,)
168 <$> D.index 0 D.text
169 <*> D.index 1 (D.list typeDecoder)
173-- ALIAS JSON
176encodeAlias :: (N.Name, Alias) -> E.Value
177encodeAlias ( name, Alias comment args tipe) =
178 E.object
179 [ "name" ==> E.text name
180 , "comment" ==> E.text comment
181 , "args" ==> E.list E.text args
182 , "type" ==> Type.encode tipe
183 ]
186alias :: D.Decoder Error Alias
187alias =
188 Alias
189 <$> D.field "comment" D.text
190 <*> D.field "args" (D.list D.text)
191 <*> D.field "type" typeDecoder
195-- VALUE JSON
198encodeValue :: (N.Name, Value) -> E.Value
199encodeValue (name, Value comment tipe) =
200 E.object
201 [ "name" ==> E.text name
202 , "comment" ==> E.text comment
203 , "type" ==> Type.encode tipe
204 ]
207value :: D.Decoder Error Value
208value =
209 Value
210 <$> D.field "comment" D.text
211 <*> D.field "type" typeDecoder
215-- BINOP JSON
218encodeBinop :: (N.Name, Binop) -> E.Value
219encodeBinop (name, Binop comment tipe assoc prec) =
220 E.object
221 [ "name" ==> E.text name
222 , "comment" ==> E.text comment
223 , "type" ==> Type.encode tipe
224 , "associativity" ==> encodeAssoc assoc
225 , "precedence" ==> encodePrec prec
226 ]
229binop :: D.Decoder Error Binop
230binop =
231 Binop
232 <$> D.field "comment" D.text
233 <*> D.field "type" typeDecoder
234 <*> D.field "associativity" assocDecoder
235 <*> D.field "precedence" precDecoder
239-- ASSOCIATIVITY JSON
242encodeAssoc :: Binop.Associativity -> E.Value
243encodeAssoc assoc =
244 case assoc of
245 Binop.Left -> E.text "left"
246 Binop.Non -> E.text "non"
247 Binop.Right -> E.text "right"
250assocDecoder :: D.Decoder Error Binop.Associativity
251assocDecoder =
252 do txt <- D.text
253 case txt of
254 "left" -> D.succeed Binop.Left
255 "non" -> D.succeed Binop.Non
256 "right" -> D.succeed Binop.Right
257 _ -> D.fail BadAssociativity
261-- PRECEDENCE JSON
264encodePrec :: Binop.Precedence -> E.Value
265encodePrec (Binop.Precedence n) =
266 E.int n
269precDecoder :: D.Decoder Error Binop.Precedence
270precDecoder =
271 Binop.Precedence <$> D.int
275-- FROM MODULE
278fromModule :: Can.Module -> Result.Result i w Error.Error Module
279fromModule (Can.Module name docs exports decls unions aliases binops effects) =
280 case exports of
281 Can.ExportEverything ->
282 Result.throw $ Error.Docs $ E.ImplicitExposing
284 Can.Export exportDict ->
285 case docs of
286 Nothing ->
287 Result.throw $ Error.Docs $ E.NoDocs
289 Just (A.At region (Can.Docs overview comments)) ->
290 do names <- parseOverview region overview
291 Result.mapError Error.Docs $
292 do checkNames exportDict names
293 let types = gatherTypes decls Map.empty
294 foldM
295 (addExport (Info comments types unions aliases binops effects))
296 (emptyModule name overview)
297 (Map.toList exportDict)
300emptyModule :: ModuleName.Canonical -> B.ByteString -> Module
301emptyModule (ModuleName.Canonical _ name) overview =
302 Module name (Text.decodeUtf8 overview) Map.empty Map.empty Map.empty Map.empty
306-- PARSE OVERVIEW
309type LName = A.Located N.Name
312parseOverview :: R.Region -> B.ByteString -> Result.Result i w Error.Error [LName]
313parseOverview (R.Region (R.Position row col) _) overview =
314 case P.runAt row (col + 3) (chompOverview []) overview of
315 Left err ->
316 Result.throw (Error.Syntax err)
318 Right names ->
319 Result.ok names
322chompOverview :: [LName] -> Parser [LName]
323chompOverview names =
324 do isDocs <- W.chompUntilDocs
325 if isDocs
326 then chompOverviewHelp names
327 else return names
330chompOverviewHelp :: [LName] -> Parser [LName]
331chompOverviewHelp names =
332 do pos <- P.getPosition
333 (W.SPos spos) <- W.whitespace
334 if pos == spos
335 then chompOverview names
336 else chompOverview =<< chompDocs names
339chompDocs :: [LName] -> Parser [LName]
340chompDocs names =
341 do name <- P.addLocation (P.oneOf [ Var.lower, Var.upper, chompBinop ])
342 spos <- W.whitespace
343 P.oneOf
344 [ do P.checkSpace spos
345 Symbol.comma
346 P.spaces
347 chompDocs (name:names)
348 , return (name:names)
349 ]
352chompBinop :: Parser N.Name
353chompBinop =
354 do Symbol.leftParen
355 name <- Symbol.binop
356 Symbol.rightParen
357 return name
361-- CHECK NAMES
364type Result i w a =
365 Result.Result i w E.Error a
368type Dups =
369 Map.Map N.Name (OneOrMore.OneOrMore R.Region)
372checkNames :: Map.Map N.Name (A.Located Can.Export) -> [LName] -> Result i w ()
373checkNames exports names =
374 do docs <- Map.traverseWithKey isUnique (List.foldl' addName Map.empty names)
375 let overlap = Map.size (Map.intersection docs exports)
376 if Map.size exports == overlap && overlap == Map.size docs
377 then Result.ok ()
378 else
379 do _ <- Map.traverseWithKey onlyInDocs (Map.difference docs exports)
380 _ <- Map.traverseWithKey onlyInExports (Map.difference exports docs)
381 Result.ok ()
384addName :: Dups -> LName -> Dups
385addName dict (A.At region name) =
386 Map.insertWith OneOrMore.more name (OneOrMore.one region) dict
389isUnique :: N.Name -> OneOrMore.OneOrMore R.Region -> Result i w R.Region
390isUnique name regions =
391 case regions of
392 OneOrMore.One region ->
393 Result.ok region
395 OneOrMore.More _ _ ->
396 let (r1:r2:_) = OneOrMore.toList regions in
397 Result.throw (E.Duplicate name r1 r2)
400onlyInDocs :: N.Name -> R.Region -> Result i w a
401onlyInDocs name region =
402 Result.throw $ E.OnlyInDocs name region
405onlyInExports :: N.Name -> A.Located Can.Export -> Result i w a
406onlyInExports name (A.At region _) =
407 Result.throw $ E.OnlyInExports name region
411-- CHECK EXPORTS
414data Info =
415 Info
416 { _iComments :: Map.Map N.Name Comment
417 , _iValues :: Types
418 , _iUnions :: Map.Map N.Name Can.Union
419 , _iAliases :: Map.Map N.Name Can.Alias
420 , _iBinops :: Map.Map N.Name Can.Binop
421 , _iEffects :: Can.Effects
422 }
425addExport :: Info -> Module -> (N.Name, A.Located Can.Export) -> Result i w Module
426addExport info (Module n c us as_ vs bs) (name, A.At region export) =
427 case export of
428 Can.ExportValue ->
429 do tipe <- getType name info
430 comment <- getComment region name info
432 let newValues = Map.insert name (Value comment tipe) vs
433 Result.ok $ Module n c us as_ newValues bs
435 Can.ExportBinop ->
436 do let (Can.Binop_ assoc prec realName) = _iBinops info ! name
437 tipe <- getType realName info
438 comment <- getComment region realName info
440 let newBinops = Map.insert name (Binop comment tipe assoc prec) bs
441 Result.ok $ Module n c us as_ vs newBinops
443 Can.ExportAlias ->
444 do let (Can.Alias tvars tipe _) = _iAliases info ! name
445 comment <- getComment region name info
447 let newAliases = Map.insert name (Alias comment tvars (Extract.fromType tipe)) as_
448 Result.ok $ Module n c us newAliases vs bs
450 Can.ExportUnionOpen ->
451 do let (Can.Union tvars ctors _ _) = _iUnions info ! name
452 comment <- getComment region name info
454 let newUnions = Map.insert name (Union comment tvars (map dector ctors)) us
455 Result.ok $ Module n c newUnions as_ vs bs
457 Can.ExportUnionClosed ->
458 do let (Can.Union tvars _ _ _) = _iUnions info ! name
459 comment <- getComment region name info
461 let newUnions = Map.insert name (Union comment tvars []) us
462 Result.ok $ Module n c newUnions as_ vs bs
464 Can.ExportPort ->
465 error "TODO"
468getComment :: R.Region -> N.Name -> Info -> Result i w Comment
469getComment region name info =
470 case Map.lookup name (_iComments info) of
471 Nothing ->
472 Result.throw (E.NoComment name region)
474 Just comment ->
475 Result.ok comment
478getType :: N.Name -> Info -> Result i w Type.Type
479getType name info =
480 case _iValues info ! name of
481 A.At defRegion Nothing ->
482 Result.throw (E.NoAnnotation name defRegion)
484 A.At _ (Just tipe) ->
485 Result.ok (Extract.fromType tipe)
488dector :: Can.Ctor -> (N.Name, [Type.Type])
489dector (Can.Ctor name _ _ args) =
490 ( name, map Extract.fromType args )
494-- GATHER TYPES
497type Types =
498 Map.Map N.Name (A.Located (Maybe Can.Type))
501gatherTypes :: Can.Decls -> Types -> Types
502gatherTypes decls types =
503 case decls of
504 Can.Declare def subDecls ->
505 gatherTypes subDecls (addDef types def)
507 Can.DeclareRec defs subDecls ->
508 gatherTypes subDecls (List.foldl' addDef types defs)
510 Can.SaveTheEnvironment ->
511 types
514addDef :: Types -> Can.Def -> Types
515addDef types def =
516 case def of
517 Can.Def (A.At region name) _ _ ->
518 Map.insert name (A.At region Nothing) types
520 Can.TypedDef (A.At region name) _ typedArgs _ resultType ->
521 let
522 tipe =
523 foldr Can.TLambda resultType (map snd typedArgs)
524 in
525 Map.insert name (A.At region (Just tipe)) types