@@ -1,8 +1,7 @@
11{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns, MultiWayIf, OverloadedStrings, UnboxedTuples #-}
33module Elm.Docs
44 ( Documentation
5− , toDict
65 , Module(..)
76 , fromModule
87 , Union(..)
@@ -18,33 +17,35 @@ module Elm.Docs
1817 where
1918
2019
21−import qualified Data.ByteString as B
20+import qualified Data.Coerce as Coerce
2221import qualified Data.List as List
2322import Data.Map ((!))
2423import qualified Data.Map as Map
24+import qualified Data.Map.Merge.Strict as Map
2525import qualified Data.Name as Name
26−import qualified Data.Text as Text
27−import qualified Data.Text.Encoding as Text
26+import qualified Data.NonEmptyList as NE
27+import qualified Data.OneOrMore as OneOrMore
28+import Data.Word (Word8)
29+import Foreign.Ptr (Ptr, plusPtr)
2830
2931import qualified AST.Canonical as Can
32+import qualified AST.Source as Src
3033import qualified AST.Utils.Binop as Binop
31−import qualified Data.OneOrMore as OneOrMore
3234import qualified Elm.Compiler.Type as Type
3335import qualified Elm.Compiler.Type.Extract as Extract
3436import qualified Elm.ModuleName as ModuleName
3537import qualified Json.Decode as D
3638import qualified Json.Encode as E
3739import Json.Encode ((==>))
40+import qualified Json.String as Json
41+import Parse.Primitives (Row, Col, word1)
42+import qualified Parse.Primitives as P
43+import qualified Parse.Space as Space
44+import qualified Parse.Symbol as Symbol
45+import qualified Parse.Variable as Var
3846import qualified Reporting.Annotation as A
39−import qualified Reporting.Error as Error
4047import qualified Reporting.Error.Docs as E
41−import qualified Reporting.Region as R
4248import qualified Reporting.Result as Result
43−import Parse.Primitives (Parser)
44−import qualified Parse.Primitives as P
45−import qualified Parse.Primitives.Symbol as Symbol
46−import qualified Parse.Primitives.Variable as Var
47−import qualified Parse.Primitives.Whitespace as W
4849
4950
5051
@@ -55,21 +56,6 @@ type Documentation =
5556 Map.Map Name.Name Module
5657
5758
58−toDict :: [Module] -> Documentation
59−toDict modules =
60− Map.fromList (map toPair modules)
61−
62−
63−
64−toPair :: Module -> (Name.Name, Module)
65−toPair modul@(Module name _ _ _ _ _) =
66− (name, modul)
67−
68−
69−
70−-- MODULES
71−
72−
7359data Module =
7460 Module
7561 { _name :: Name.Name
@@ -80,9 +66,7 @@ data Module =
8066 , _binops :: Map.Map Name.Name Binop
8167 }
8268
83−
84−type Comment = Text.Text
85−
69+type Comment = Json.String
8670
8771data Alias = Alias Comment [Name.Name] Type.Type
8872data Union = Union Comment [Name.Name] [(Name.Name, [Type.Type])]
@@ -91,14 +75,19 @@ data Binop = Binop Comment Type.Type Binop.Associativity Binop.Precedence
9175
9276
9377
94−-- JSON ENCODE / DECODE
78+-- JSON
79+
80+
81+encode :: Documentation -> E.Value
82+encode docs =
83+ E.list encodeModule (Map.elems docs)
9584
9685
97−encode :: Module -> E.Value
98−encode (Module name comment unions aliases values binops) =
86+encodeModule :: Module -> E.Value
87+encodeModule (Module name comment unions aliases values binops) =
9988 E.object $
10089 [ "name" ==> ModuleName.encode name
101− , "comment" ==> E.text comment
90+ , "comment" ==> E.string comment
10291 , "unions" ==> E.list encodeUnion (Map.toList unions)
10392 , "aliases" ==> E.list encodeAlias (Map.toList aliases)
10493 , "values" ==> E.list encodeValue (Map.toList values)
@@ -107,16 +96,31 @@ encode (Module name comment unions aliases values binops) =
10796
10897
10998data Error
110− = BadAssociativity Text.Text
111− | BadName
99+ = BadAssociativity
100+ | BadModuleName
112101 | BadType
113102
114103
115−decoder :: D.Decoder Error Module
104+decoder :: D.Decoder Error Documentation
116105decoder =
106+ toDict <$> D.list moduleDecoder
107+
108+
109+toDict :: [Module] -> Documentation
110+toDict modules =
111+ Map.fromList (map toDictHelp modules)
112+
113+
114+toDictHelp :: Module -> (Name.Name, Module)
115+toDictHelp modul@(Module name _ _ _ _ _) =
116+ (name, modul)
117+
118+
119+moduleDecoder :: D.Decoder Error Module
120+moduleDecoder =
117121 Module
118− <$> D.field "name" nameDecoder
119− <*> D.field "comment" D.text
122+ <$> D.field "name" moduleNameDecoder
123+ <*> D.field "comment" D.string
120124 <*> D.field "unions" (dictDecoder union)
121125 <*> D.field "aliases" (dictDecoder alias)
122126 <*> D.field "values" (dictDecoder value)
@@ -131,13 +135,18 @@ dictDecoder entryDecoder =
131135named :: D.Decoder Error a -> D.Decoder Error (Name.Name, a)
132136named entryDecoder =
133137 (,)
134− <$> D.field "name" D.name
138+ <$> D.field "name" nameDecoder
135139 <*> entryDecoder
136140
137141
138−nameDecoder :: D.Decoder Error Name.Name
142+nameDecoder :: D.Decoder e Name.Name
139143nameDecoder =
140− D.mapError (const BadName) ModuleName.decoder
144+ fmap Coerce.coerce D.string
145+
146+
147+moduleNameDecoder :: D.Decoder Error ModuleName.Raw
148+moduleNameDecoder =
149+ D.mapError (const BadModuleName) ModuleName.decoder
141150
142151
143152typeDecoder :: D.Decoder Error Type.Type
@@ -153,7 +162,7 @@ encodeUnion :: (Name.Name, Union) -> E.Value
153162encodeUnion (name, Union comment args cases) =
154163 E.object
155164 [ "name" ==> E.name name
156− , "comment" ==> E.text comment
165+ , "comment" ==> E.string comment
157166 , "args" ==> E.list E.name args
158167 , "cases" ==> E.list encodeCase cases
159168 ]
@@ -162,8 +171,8 @@ encodeUnion (name, Union comment args cases) =
162171union :: D.Decoder Error Union
163172union =
164173 Union
165− <$> D.field "comment" D.text
166− <*> D.field "args" (D.list D.name)
174+ <$> D.field "comment" D.string
175+ <*> D.field "args" (D.list nameDecoder)
167176 <*> D.field "cases" (D.list caseDecoder)
168177
169178
@@ -174,7 +183,7 @@ encodeCase ( tag, args ) =
174183
175184caseDecoder :: D.Decoder Error ( Name.Name, [Type.Type] )
176185caseDecoder =
177− D.pair D.name (D.list typeDecoder)
186+ D.pair nameDecoder (D.list typeDecoder)
178187
179188
180189
@@ -185,7 +194,7 @@ encodeAlias :: (Name.Name, Alias) -> E.Value
185194encodeAlias ( name, Alias comment args tipe) =
186195 E.object
187196 [ "name" ==> E.name name
188− , "comment" ==> E.text comment
197+ , "comment" ==> E.string comment
189198 , "args" ==> E.list E.name args
190199 , "type" ==> Type.encode tipe
191200 ]
@@ -194,8 +203,8 @@ encodeAlias ( name, Alias comment args tipe) =
194203alias :: D.Decoder Error Alias
195204alias =
196205 Alias
197− <$> D.field "comment" D.text
198− <*> D.field "args" (D.list D.name)
206+ <$> D.field "comment" D.string
207+ <*> D.field "args" (D.list nameDecoder)
199208 <*> D.field "type" typeDecoder
200209
201210
@@ -207,7 +216,7 @@ encodeValue :: (Name.Name, Value) -> E.Value
207216encodeValue (name, Value comment tipe) =
208217 E.object
209218 [ "name" ==> E.name name
210− , "comment" ==> E.text comment
219+ , "comment" ==> E.string comment
211220 , "type" ==> Type.encode tipe
212221 ]
213222
@@ -215,7 +224,7 @@ encodeValue (name, Value comment tipe) =
215224value :: D.Decoder Error Value
216225value =
217226 Value
218− <$> D.field "comment" D.text
227+ <$> D.field "comment" D.string
219228 <*> D.field "type" typeDecoder
220229
221230
@@ -227,7 +236,7 @@ encodeBinop :: (Name.Name, Binop) -> E.Value
227236encodeBinop (name, Binop comment tipe assoc prec) =
228237 E.object
229238 [ "name" ==> E.name name
230− , "comment" ==> E.text comment
239+ , "comment" ==> E.string comment
231240 , "type" ==> Type.encode tipe
232241 , "associativity" ==> encodeAssoc assoc
233242 , "precedence" ==> encodePrec prec
@@ -237,7 +246,7 @@ encodeBinop (name, Binop comment tipe assoc prec) =
237246binop :: D.Decoder Error Binop
238247binop =
239248 Binop
240− <$> D.field "comment" D.text
249+ <$> D.field "comment" D.string
241250 <*> D.field "type" typeDecoder
242251 <*> D.field "associativity" assocDecoder
243252 <*> D.field "precedence" precDecoder
@@ -250,19 +259,23 @@ binop =
250259encodeAssoc :: Binop.Associativity -> E.Value
251260encodeAssoc assoc =
252261 case assoc of
253− Binop.Left -> E.text "left"
254− Binop.Non -> E.text "non"
255− Binop.Right -> E.text "right"
262+ Binop.Left -> E.chars "left"
263+ Binop.Non -> E.chars "non"
264+ Binop.Right -> E.chars "right"
256265
257266
258267assocDecoder :: D.Decoder Error Binop.Associativity
259268assocDecoder =
260− do txt <- D.text
261− case txt of
262− "left" -> D.succeed Binop.Left
263− "non" -> D.succeed Binop.Non
264− "right" -> D.succeed Binop.Right
265− _ -> D.fail (BadAssociativity txt)
269+ let
270+ left = Json.fromChars "left"
271+ non = Json.fromChars "non"
272+ right = Json.fromChars "right"
273+ in
274+ do str <- D.string
275+ if | str == left -> return Binop.Left
276+ | str == non -> return Binop.Non
277+ | str == right -> return Binop.Right
278+ | otherwise -> D.failure BadAssociativity
266279
267280
268281
@@ -283,142 +296,190 @@ precDecoder =
283296-- FROM MODULE
284297
285298
286−fromModule :: Can.Module -> Result.Result i w Error.Error Module
287−fromModule (Can.Module name docs exports decls unions aliases binops effects) =
299+fromModule :: Can.Module -> Either E.Error Module
300+fromModule modul@(Can.Module _ exports docs _ _ _ _ _) =
288301 case exports of
289302 Can.ExportEverything region ->
290− Result.throw $ Error.Docs $ E.ImplicitExposing region
303+ Left (E.ImplicitExposing region)
291304
292305 Can.Export exportDict ->
293306 case docs of
294− Can.NoDocs region ->
295− Result.throw $ Error.Docs $ E.NoDocs region
307+ Src.NoDocs region ->
308+ Left (E.NoDocs region)
296309
297− Can.YesDocs region overview comments ->
298− do names <- parseOverview region overview
299− Result.mapError Error.Docs $
300− do checkNames exportDict names
301− let types = gatherTypes decls Map.empty
302− let info = Info comments types unions aliases binops effects
303− inserters <- Map.traverseWithKey (checkExport info) exportDict
304− return $ foldr ($) (emptyModule name overview) inserters
305−
306−
307−emptyModule :: ModuleName.Canonical -> B.ByteString -> Module
308−emptyModule (ModuleName.Canonical _ name) overview =
309− Module name (Text.decodeUtf8 overview) Map.empty Map.empty Map.empty Map.empty
310+ Src.YesDocs overview comments ->
311+ do names <- parseOverview overview
312+ checkNames exportDict names
313+ checkDefs exportDict overview (Map.fromList comments) modul
310314
311315
312316
313317-- PARSE OVERVIEW
314318
315319
316−parseOverview :: R.Region -> B.ByteString -> Result.Result i w Error.Error [A.Located Name.Name]
317−parseOverview (R.Region (R.Position row col) _) overview =
318− case P.runAt row (col + 3) (chompOverview []) overview of
320+parseOverview :: Src.Comment -> Either E.Error [A.Located Name.Name]
321+parseOverview (Src.Comment snippet) =
322+ case P.fromSnippet (chompOverview []) E.BadEnd snippet of
319323 Left err ->
320− Result.throw (Error.Syntax err)
324+ Left (E.SyntaxProblem err)
321325
322326 Right names ->
323− Result.ok names
327+ Right names
328+
329+
330+type Parser a =
331+ P.Parser E.SyntaxProblem a
324332
325333
326334chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
327335chompOverview names =
328− do isDocs <- W.chompUntilDocs
336+ do isDocs <- chompUntilDocs
329337 if isDocs
330− then chompOverviewHelp names
331− else return names
332−
333−
334−chompOverviewHelp :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
335−chompOverviewHelp names =
336− do pos <- P.getPosition
337− (W.SPos spos) <- W.whitespace
338− if pos == spos
339− then chompOverview names
340− else chompOverview =<< chompDocs names
338+ then
339+ do Space.chomp E.Space
340+ chompOverview =<< chompDocs names
341+ else
342+ return names
341343
342344
343345chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
344346chompDocs names =
345− do name <- P.addLocation (P.oneOf [ Var.lower, Var.upper, chompBinop ])
346− spos <- W.whitespace
347− P.oneOf
348− [ do P.checkSpace spos
349− Symbol.comma
350− P.spaces
347+ do name <-
348+ P.addLocation $
349+ P.oneOf E.Export
350+ [ Var.lower E.Export
351+ , Var.upper E.Export
352+ , chompOperator
353+ ]
354+
355+ Space.chomp E.Space
356+
357+ P.oneOfWithFallback
358+ [ do pos <- P.getPosition
359+ Space.checkIndent pos E.Comma
360+ word1 0x2C {-,-} E.Comma
361+ Space.chomp E.Space
351362 chompDocs (name:names)
352− , return (name:names)
353363 ]
354−
355−
356−chompBinop :: Parser Name.Name
357−chompBinop =
358− do Symbol.leftParen
359− name <- Symbol.binop
360− Symbol.rightParen
361− return name
364+ (name:names)
365+
366+
367+chompOperator :: Parser Name.Name
368+chompOperator =
369+ do word1 0x28 {-(-} E.Op
370+ op <- Symbol.operator E.Op E.OpBad
371+ word1 0x29 {-)-} E.Op
372+ return op
373+
374+
375+-- TODO add rule that @docs must be after newline in 0.20
376+--
377+chompUntilDocs :: Parser Bool
378+chompUntilDocs =
379+ P.Parser $ \(P.State src pos end indent row col) cok _ _ _ ->
380+ let
381+ (# isDocs, newPos, newRow, newCol #) = untilDocs pos end row col
382+ !newState = P.State src newPos end indent newRow newCol
383+ in
384+ cok isDocs newState
385+
386+
387+untilDocs :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Bool, Ptr Word8, Row, Col #)
388+untilDocs pos end row col =
389+ if pos >= end then
390+ (# False, pos, row, col #)
391+ else
392+ let !word = P.unsafeIndex pos in
393+ if word == 0x0A {-\n-} then
394+ untilDocs (plusPtr pos 1) end (row + 1) 1
395+ else
396+ let !pos5 = plusPtr pos 5 in
397+ if pos5 <= end
398+ && P.unsafeIndex ( pos ) == 0x40 {-@-}
399+ && P.unsafeIndex (plusPtr pos 1) == 0x64 {-d-}
400+ && P.unsafeIndex (plusPtr pos 2) == 0x6F {-o-}
401+ && P.unsafeIndex (plusPtr pos 3) == 0x63 {-c-}
402+ && P.unsafeIndex (plusPtr pos 4) == 0x73 {-s-}
403+ && Var.getInnerWidth pos5 end == 0
404+ then
405+ (# True, pos5, row, col + 5 #)
406+ else
407+ let !newPos = plusPtr pos (P.getCharWidth pos end word) in
408+ untilDocs newPos end row (col + 1)
362409
363410
364411
365412-- CHECK NAMES
366413
367414
368−type Result i w a =
369− Result.Result i w E.Error a
370−
371−
372−type Dups =
373− Map.Map Name.Name (OneOrMore.OneOrMore R.Region)
415+checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Either E.Error ()
416+checkNames exports names =
417+ let
418+ docs = List.foldl' addName Map.empty names
419+ loneDoc = Map.traverseMissing onlyInDocs
420+ loneExport = Map.traverseMissing onlyInExports
421+ checkBoth = Map.zipWithAMatched (\n _ r -> isUnique n r)
422+ in
423+ case Result.run (Map.mergeA loneExport loneDoc checkBoth exports docs) of
424+ (_, Right _) -> Right ()
425+ (_, Left es) -> Left (E.NameProblems (OneOrMore.destruct NE.List es))
374426
375427
376−checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Result i w ()
377−checkNames exports names =
378− do docs <- Map.traverseWithKey isUnique (List.foldl' addName Map.empty names)
379− let overlap = Map.size (Map.intersection docs exports)
380− if Map.size exports == overlap && overlap == Map.size docs
381− then Result.ok ()
382− else
383− do _ <- Map.traverseWithKey onlyInDocs (Map.difference docs exports)
384− _ <- Map.traverseWithKey onlyInExports (Map.difference exports docs)
385− Result.ok ()
428+type DocNameRegions =
429+ Map.Map Name.Name (OneOrMore.OneOrMore A.Region)
386430
387431
388−addName :: Dups -> A.Located Name.Name -> Dups
432+addName :: DocNameRegions -> A.Located Name.Name -> DocNameRegions
389433addName dict (A.At region name) =
390434 Map.insertWith OneOrMore.more name (OneOrMore.one region) dict
391435
392436
393−isUnique :: Name.Name -> OneOrMore.OneOrMore R.Region -> Result i w R.Region
437+isUnique :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result.Result i w E.NameProblem A.Region
394438isUnique name regions =
395439 case regions of
396440 OneOrMore.One region ->
397441 Result.ok region
398442
399− OneOrMore.More _ _ ->
400− let (r1:r2:_) = OneOrMore.toList regions in
401− Result.throw (E.Duplicate name r1 r2)
443+ OneOrMore.More left right ->
444+ let (r1, r2) = OneOrMore.getFirstTwo left right in
445+ Result.throw (E.NameDuplicate name r1 r2)
402446
403447
404−onlyInDocs :: Name.Name -> R.Region -> Result i w a
405−onlyInDocs name region =
406− Result.throw $ E.OnlyInDocs name region
448+onlyInDocs :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result.Result i w E.NameProblem a
449+onlyInDocs name regions =
450+ do region <- isUnique name regions
451+ Result.throw $ E.NameOnlyInDocs name region
407452
408453
409−onlyInExports :: Name.Name -> A.Located Can.Export -> Result i w a
454+onlyInExports :: Name.Name -> A.Located Can.Export -> Result.Result i w E.NameProblem a
410455onlyInExports name (A.At region _) =
411− Result.throw $ E.OnlyInExports name region
456+ Result.throw $ E.NameOnlyInExports name region
457+
458+
459+
460+-- CHECK DEFS
461+
412462
463+checkDefs :: Map.Map Name.Name (A.Located Can.Export) -> Src.Comment -> Map.Map Name.Name Src.Comment -> Can.Module -> Either E.Error Module
464+checkDefs exportDict overview comments (Can.Module name _ _ decls unions aliases infixes effects) =
465+ let
466+ types = gatherTypes decls Map.empty
467+ info = Info comments types unions aliases infixes effects
468+ in
469+ case Result.run (Map.traverseWithKey (checkExport info) exportDict) of
470+ (_, Left problems ) -> Left $ E.DefProblems (OneOrMore.destruct NE.List problems)
471+ (_, Right inserters) -> Right $ foldr ($) (emptyModule name overview) inserters
413472
414473
415−-- CHECK EXPORTS
474+emptyModule :: ModuleName.Canonical -> Src.Comment -> Module
475+emptyModule (ModuleName.Canonical _ name) (Src.Comment overview) =
476+ Module name (Json.fromComment overview) Map.empty Map.empty Map.empty Map.empty
416477
417478
418479data Info =
419480 Info
420− { _iComments :: Map.Map Name.Name Comment
421− , _iValues :: Types
481+ { _iComments :: Map.Map Name.Name Src.Comment
482+ , _iValues :: Map.Map Name.Name (Either A.Region Can.Type)
422483 , _iUnions :: Map.Map Name.Name Can.Union
423484 , _iAliases :: Map.Map Name.Name Can.Alias
424485 , _iBinops :: Map.Map Name.Name Can.Binop
@@ -426,7 +487,7 @@ data Info =
426487 }
427488
428489
429−checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result i w (Module -> Module)
490+checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result.Result i w E.DefProblem (Module -> Module)
430491checkExport info name (A.At region export) =
431492 case export of
432493 Can.ExportValue ->
@@ -467,23 +528,23 @@ checkExport info name (A.At region export) =
467528 m { _values = Map.insert name (Value comment tipe) (_values m) }
468529
469530
470−getComment :: R.Region -> Name.Name -> Info -> Result i w Comment
531+getComment :: A.Region -> Name.Name -> Info -> Result.Result i w E.DefProblem Comment
471532getComment region name info =
472533 case Map.lookup name (_iComments info) of
473534 Nothing ->
474535 Result.throw (E.NoComment name region)
475536
476− Just comment ->
477− Result.ok comment
537+ Just (Src.Comment snippet) ->
538+ Result.ok (Json.fromComment snippet)
478539
479540
480−getType :: Name.Name -> Info -> Result i w Type.Type
541+getType :: Name.Name -> Info -> Result.Result i w E.DefProblem Type.Type
481542getType name info =
482543 case _iValues info ! name of
483− A.At defRegion Nothing ->
484− Result.throw (E.NoAnnotation name defRegion)
544+ Left region ->
545+ Result.throw (E.NoAnnotation name region)
485546
486− A.At _ (Just tipe) ->
547+ Right tipe ->
487548 Result.ok (Extract.fromType tipe)
488549
489550
@@ -497,7 +558,7 @@ dector (Can.Ctor name _ _ args) =
497558
498559
499560type Types =
500− Map.Map Name.Name (A.Located (Maybe Can.Type))
561+ Map.Map Name.Name (Either A.Region Can.Type)
501562
502563
503564gatherTypes :: Can.Decls -> Types -> Types
@@ -506,8 +567,8 @@ gatherTypes decls types =
506567 Can.Declare def subDecls ->
507568 gatherTypes subDecls (addDef types def)
508569
509− Can.DeclareRec defs subDecls ->
510− gatherTypes subDecls (List.foldl' addDef types defs)
570+ Can.DeclareRec def defs subDecls ->
571+ gatherTypes subDecls (List.foldl' addDef (addDef types def) defs)
511572
512573 Can.SaveTheEnvironment ->
513574 types
@@ -517,11 +578,10 @@ addDef :: Types -> Can.Def -> Types
517578addDef types def =
518579 case def of
519580 Can.Def (A.At region name) _ _ ->
520− Map.insert name (A.At region Nothing) types
581+ Map.insert name (Left region) types
521582
522− Can.TypedDef (A.At region name) _ typedArgs _ resultType ->
583+ Can.TypedDef (A.At _ name) _ typedArgs _ resultType ->
523584 let
524− tipe =
525− foldr Can.TLambda resultType (map snd typedArgs)
585+ tipe = foldr Can.TLambda resultType (map snd typedArgs)
526586 in
527− Map.insert name (A.At region (Just tipe)) types
587+ Map.insert name (Right tipe) types