1{-# OPTIONS_GHC -Wall #-} 2{-# LANGUAGE BangPatterns, MultiWayIf, OverloadedStrings, UnboxedTuples #-} 3module Elm.Docs 4 ( Documentation 5 , Module(..) 6 , fromModule 7 , Union(..) 8 , Alias(..) 9 , Value(..) 10 , Binop(..) 11 , Binop.Associativity(..) 12 , Binop.Precedence(..) 13 , Error(..) 14 , decoder 15 , encode 16 ) 17 where 18 19 20import qualified Data.Coerce as Coerce 21import qualified Data.List as List 22import Data.Map ((!)) 23import qualified Data.Map as Map 24import qualified Data.Map.Merge.Strict as Map 25import qualified Data.Name as Name 26import qualified Data.NonEmptyList as NE 27import qualified Data.OneOrMore as OneOrMore 28import Data.Word (Word8) 29import Foreign.Ptr (Ptr, plusPtr) 30 31import qualified AST.Canonical as Can 32import qualified AST.Source as Src 33import qualified AST.Utils.Binop as Binop 34import qualified Elm.Compiler.Type as Type 35import qualified Elm.Compiler.Type.Extract as Extract 36import qualified Elm.ModuleName as ModuleName 37import qualified Json.Decode as D 38import qualified Json.Encode as E 39import Json.Encode ((==>)) 40import qualified Json.String as Json 41import Parse.Primitives (Row, Col, word1) 42import qualified Parse.Primitives as P 43import qualified Parse.Space as Space 44import qualified Parse.Symbol as Symbol 45import qualified Parse.Variable as Var 46import qualified Reporting.Annotation as A 47import qualified Reporting.Error.Docs as E 48import qualified Reporting.Result as Result 49 50 51 52-- DOCUMENTATION 53 54 55type Documentation = 56 Map.Map Name.Name Module 57 58 59data Module = 60 Module 61 { _name :: Name.Name 62 , _comment :: Comment 63 , _unions :: Map.Map Name.Name Union 64 , _aliases :: Map.Map Name.Name Alias 65 , _values :: Map.Map Name.Name Value 66 , _binops :: Map.Map Name.Name Binop 67 } 68 69type Comment = Json.String 70 71data Alias = Alias Comment [Name.Name] Type.Type 72data Union = Union Comment [Name.Name] [(Name.Name, [Type.Type])] 73data Value = Value Comment Type.Type 74data Binop = Binop Comment Type.Type Binop.Associativity Binop.Precedence 75 76 77 78-- JSON 79 80 81encode :: Documentation -> E.Value 82encode docs = 83 E.list encodeModule (Map.elems docs) 84 85 86encodeModule :: Module -> E.Value 87encodeModule (Module name comment unions aliases values binops) = 88 E.object $ 89 [ "name" ==> ModuleName.encode name 90 , "comment" ==> E.string comment 91 , "unions" ==> E.list encodeUnion (Map.toList unions) 92 , "aliases" ==> E.list encodeAlias (Map.toList aliases) 93 , "values" ==> E.list encodeValue (Map.toList values) 94 , "binops" ==> E.list encodeBinop (Map.toList binops) 95 ] 96 97 98data Error 99 = BadAssociativity 100 | BadModuleName 101 | BadType 102 103 104decoder :: D.Decoder Error Documentation 105decoder = 106 toDict <$> D.list moduleDecoder 107 108 109toDict :: [Module] -> Documentation 110toDict modules = 111 Map.fromList (map toDictHelp modules) 112 113 114toDictHelp :: Module -> (Name.Name, Module) 115toDictHelp modul@(Module name _ _ _ _ _) = 116 (name, modul) 117 118 119moduleDecoder :: D.Decoder Error Module 120moduleDecoder = 121 Module 122 <$> D.field "name" moduleNameDecoder 123 <*> D.field "comment" D.string 124 <*> D.field "unions" (dictDecoder union) 125 <*> D.field "aliases" (dictDecoder alias) 126 <*> D.field "values" (dictDecoder value) 127 <*> D.field "binops" (dictDecoder binop) 128 129 130dictDecoder :: D.Decoder Error a -> D.Decoder Error (Map.Map Name.Name a) 131dictDecoder entryDecoder = 132 Map.fromList <$> D.list (named entryDecoder) 133 134 135named :: D.Decoder Error a -> D.Decoder Error (Name.Name, a) 136named entryDecoder = 137 (,) 138 <$> D.field "name" nameDecoder 139 <*> entryDecoder 140 141 142nameDecoder :: D.Decoder e Name.Name 143nameDecoder = 144 fmap Coerce.coerce D.string 145 146 147moduleNameDecoder :: D.Decoder Error ModuleName.Raw 148moduleNameDecoder = 149 D.mapError (const BadModuleName) ModuleName.decoder 150 151 152typeDecoder :: D.Decoder Error Type.Type 153typeDecoder = 154 D.mapError (const BadType) Type.decoder 155 156 157 158-- UNION JSON 159 160 161encodeUnion :: (Name.Name, Union) -> E.Value 162encodeUnion (name, Union comment args cases) = 163 E.object 164 [ "name" ==> E.name name 165 , "comment" ==> E.string comment 166 , "args" ==> E.list E.name args 167 , "cases" ==> E.list encodeCase cases 168 ] 169 170 171union :: D.Decoder Error Union 172union = 173 Union 174 <$> D.field "comment" D.string 175 <*> D.field "args" (D.list nameDecoder) 176 <*> D.field "cases" (D.list caseDecoder) 177 178 179encodeCase :: ( Name.Name, [Type.Type] ) -> E.Value 180encodeCase ( tag, args ) = 181 E.list id [ E.name tag, E.list Type.encode args ] 182 183 184caseDecoder :: D.Decoder Error ( Name.Name, [Type.Type] ) 185caseDecoder = 186 D.pair nameDecoder (D.list typeDecoder) 187 188 189 190-- ALIAS JSON 191 192 193encodeAlias :: (Name.Name, Alias) -> E.Value 194encodeAlias ( name, Alias comment args tipe) = 195 E.object 196 [ "name" ==> E.name name 197 , "comment" ==> E.string comment 198 , "args" ==> E.list E.name args 199 , "type" ==> Type.encode tipe 200 ] 201 202 203alias :: D.Decoder Error Alias 204alias = 205 Alias 206 <$> D.field "comment" D.string 207 <*> D.field "args" (D.list nameDecoder) 208 <*> D.field "type" typeDecoder 209 210 211 212-- VALUE JSON 213 214 215encodeValue :: (Name.Name, Value) -> E.Value 216encodeValue (name, Value comment tipe) = 217 E.object 218 [ "name" ==> E.name name 219 , "comment" ==> E.string comment 220 , "type" ==> Type.encode tipe 221 ] 222 223 224value :: D.Decoder Error Value 225value = 226 Value 227 <$> D.field "comment" D.string 228 <*> D.field "type" typeDecoder 229 230 231 232-- BINOP JSON 233 234 235encodeBinop :: (Name.Name, Binop) -> E.Value 236encodeBinop (name, Binop comment tipe assoc prec) = 237 E.object 238 [ "name" ==> E.name name 239 , "comment" ==> E.string comment 240 , "type" ==> Type.encode tipe 241 , "associativity" ==> encodeAssoc assoc 242 , "precedence" ==> encodePrec prec 243 ] 244 245 246binop :: D.Decoder Error Binop 247binop = 248 Binop 249 <$> D.field "comment" D.string 250 <*> D.field "type" typeDecoder 251 <*> D.field "associativity" assocDecoder 252 <*> D.field "precedence" precDecoder 253 254 255 256-- ASSOCIATIVITY JSON 257 258 259encodeAssoc :: Binop.Associativity -> E.Value 260encodeAssoc assoc = 261 case assoc of 262 Binop.Left -> E.chars "left" 263 Binop.Non -> E.chars "non" 264 Binop.Right -> E.chars "right" 265 266 267assocDecoder :: D.Decoder Error Binop.Associativity 268assocDecoder = 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 279 280 281 282-- PRECEDENCE JSON 283 284 285encodePrec :: Binop.Precedence -> E.Value 286encodePrec (Binop.Precedence n) = 287 E.int n 288 289 290precDecoder :: D.Decoder Error Binop.Precedence 291precDecoder = 292 Binop.Precedence <$> D.int 293 294 295 296-- FROM MODULE 297 298 299fromModule :: Can.Module -> Either E.Error Module 300fromModule modul@(Can.Module _ exports docs _ _ _ _ _) = 301 case exports of 302 Can.ExportEverything region -> 303 Left (E.ImplicitExposing region) 304 305 Can.Export exportDict -> 306 case docs of 307 Src.NoDocs region -> 308 Left (E.NoDocs region) 309 310 Src.YesDocs overview comments -> 311 do names <- parseOverview overview 312 checkNames exportDict names 313 checkDefs exportDict overview (Map.fromList comments) modul 314 315 316 317-- PARSE OVERVIEW 318 319 320parseOverview :: Src.Comment -> Either E.Error [A.Located Name.Name] 321parseOverview (Src.Comment snippet) = 322 case P.fromSnippet (chompOverview []) E.BadEnd snippet of 323 Left err -> 324 Left (E.SyntaxProblem err) 325 326 Right names -> 327 Right names 328 329 330type Parser a = 331 P.Parser E.SyntaxProblem a 332 333 334chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name] 335chompOverview names = 336 do isDocs <- chompUntilDocs 337 if isDocs 338 then 339 do Space.chomp E.Space 340 chompOverview =<< chompDocs names 341 else 342 return names 343 344 345chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name] 346chompDocs names = 347 do name <- 348 P.addLocation $ 349 P.oneOf E.Name 350 [ Var.lower E.Name 351 , Var.upper E.Name 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 362 chompDocs (name:names) 363 ] 364 (name:names) 365 366 367chompOperator :: Parser Name.Name 368chompOperator = 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-- 377chompUntilDocs :: Parser Bool 378chompUntilDocs = 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 387untilDocs :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Bool, Ptr Word8, Row, Col #) 388untilDocs 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 word) in 408 untilDocs newPos end row (col + 1) 409 410 411 412-- CHECK NAMES 413 414 415checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Either E.Error () 416checkNames 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)) 426 427 428type DocNameRegions = 429 Map.Map Name.Name (OneOrMore.OneOrMore A.Region) 430 431 432addName :: DocNameRegions -> A.Located Name.Name -> DocNameRegions 433addName dict (A.At region name) = 434 Map.insertWith OneOrMore.more name (OneOrMore.one region) dict 435 436 437isUnique :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result.Result i w E.NameProblem A.Region 438isUnique name regions = 439 case regions of 440 OneOrMore.One region -> 441 Result.ok region 442 443 OneOrMore.More left right -> 444 let (r1, r2) = OneOrMore.getFirstTwo left right in 445 Result.throw (E.NameDuplicate name r1 r2) 446 447 448onlyInDocs :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result.Result i w E.NameProblem a 449onlyInDocs name regions = 450 do region <- isUnique name regions 451 Result.throw $ E.NameOnlyInDocs name region 452 453 454onlyInExports :: Name.Name -> A.Located Can.Export -> Result.Result i w E.NameProblem a 455onlyInExports name (A.At region _) = 456 Result.throw $ E.NameOnlyInExports name region 457 458 459 460-- CHECK DEFS 461 462 463checkDefs :: Map.Map Name.Name (A.Located Can.Export) -> Src.Comment -> Map.Map Name.Name Src.Comment -> Can.Module -> Either E.Error Module 464checkDefs 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 472 473 474emptyModule :: ModuleName.Canonical -> Src.Comment -> Module 475emptyModule (ModuleName.Canonical _ name) (Src.Comment overview) = 476 Module name (Json.fromComment overview) Map.empty Map.empty Map.empty Map.empty 477 478 479data Info = 480 Info 481 { _iComments :: Map.Map Name.Name Src.Comment 482 , _iValues :: Map.Map Name.Name (Either A.Region Can.Type) 483 , _iUnions :: Map.Map Name.Name Can.Union 484 , _iAliases :: Map.Map Name.Name Can.Alias 485 , _iBinops :: Map.Map Name.Name Can.Binop 486 , _iEffects :: Can.Effects 487 } 488 489 490checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result.Result i w E.DefProblem (Module -> Module) 491checkExport info name (A.At region export) = 492 case export of 493 Can.ExportValue -> 494 do tipe <- getType name info 495 comment <- getComment region name info 496 Result.ok $ \m -> 497 m { _values = Map.insert name (Value comment tipe) (_values m) } 498 499 Can.ExportBinop -> 500 do let (Can.Binop_ assoc prec realName) = _iBinops info ! name 501 tipe <- getType realName info 502 comment <- getComment region realName info 503 Result.ok $ \m -> 504 m { _binops = Map.insert name (Binop comment tipe assoc prec) (_binops m) } 505 506 Can.ExportAlias -> 507 do let (Can.Alias tvars tipe) = _iAliases info ! name 508 comment <- getComment region name info 509 Result.ok $ \m -> 510 m { _aliases = Map.insert name (Alias comment tvars (Extract.fromType tipe)) (_aliases m) } 511 512 Can.ExportUnionOpen -> 513 do let (Can.Union tvars ctors _ _) = _iUnions info ! name 514 comment <- getComment region name info 515 Result.ok $ \m -> 516 m { _unions = Map.insert name (Union comment tvars (map dector ctors)) (_unions m) } 517 518 Can.ExportUnionClosed -> 519 do let (Can.Union tvars _ _ _) = _iUnions info ! name 520 comment <- getComment region name info 521 Result.ok $ \m -> 522 m { _unions = Map.insert name (Union comment tvars []) (_unions m) } 523 524 Can.ExportPort -> 525 do tipe <- getType name info 526 comment <- getComment region name info 527 Result.ok $ \m -> 528 m { _values = Map.insert name (Value comment tipe) (_values m) } 529 530 531getComment :: A.Region -> Name.Name -> Info -> Result.Result i w E.DefProblem Comment 532getComment region name info = 533 case Map.lookup name (_iComments info) of 534 Nothing -> 535 Result.throw (E.NoComment name region) 536 537 Just (Src.Comment snippet) -> 538 Result.ok (Json.fromComment snippet) 539 540 541getType :: Name.Name -> Info -> Result.Result i w E.DefProblem Type.Type 542getType name info = 543 case _iValues info ! name of 544 Left region -> 545 Result.throw (E.NoAnnotation name region) 546 547 Right tipe -> 548 Result.ok (Extract.fromType tipe) 549 550 551dector :: Can.Ctor -> (Name.Name, [Type.Type]) 552dector (Can.Ctor name _ _ args) = 553 ( name, map Extract.fromType args ) 554 555 556 557-- GATHER TYPES 558 559 560type Types = 561 Map.Map Name.Name (Either A.Region Can.Type) 562 563 564gatherTypes :: Can.Decls -> Types -> Types 565gatherTypes decls types = 566 case decls of 567 Can.Declare def subDecls -> 568 gatherTypes subDecls (addDef types def) 569 570 Can.DeclareRec def defs subDecls -> 571 gatherTypes subDecls (List.foldl' addDef (addDef types def) defs) 572 573 Can.SaveTheEnvironment -> 574 types 575 576 577addDef :: Types -> Can.Def -> Types 578addDef types def = 579 case def of 580 Can.Def (A.At region name) _ _ -> 581 Map.insert name (Left region) types 582 583 Can.TypedDef (A.At _ name) _ typedArgs _ resultType -> 584 let 585 tipe = foldr Can.TLambda resultType (map snd typedArgs) 586 in 587 Map.insert name (Right tipe) types 588