@@ -1,8 +1,7 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns, MultiWayIf, OverloadedStrings, UnboxedTuples #-}
3module Elm.Docs
3module Elm.Docs
4 ( Documentation
4 ( Documentation
6 , Module(..)
5 , Module(..)
7 , fromModule
6 , fromModule
8 , Union(..)
7 , Union(..)
@@ -18,33 +17,35 @@ module Elm.Docs
21−import qualified Data.ByteString as B
20+import qualified Data.Coerce as Coerce
22import qualified Data.List as List
21import qualified Data.List as List
23import Data.Map ((!))
22import Data.Map ((!))
24import qualified Data.Map as Map
23import qualified Data.Map as Map
24+import qualified Data.Map.Merge.Strict as Map
25import qualified Data.Name as Name
25import qualified Data.Name as Name
26−import qualified Data.Text as Text
26+import qualified Data.NonEmptyList as NE
27−import qualified Data.Text.Encoding as Text
27+import qualified Data.OneOrMore as OneOrMore
28+import Data.Word (Word8)
29+import Foreign.Ptr (Ptr, plusPtr)
29import qualified AST.Canonical as Can
31import qualified AST.Canonical as Can
32+import qualified AST.Source as Src
30import qualified AST.Utils.Binop as Binop
33import qualified AST.Utils.Binop as Binop
31−import qualified Data.OneOrMore as OneOrMore
32import qualified Elm.Compiler.Type as Type
34import qualified Elm.Compiler.Type as Type
33import qualified Elm.Compiler.Type.Extract as Extract
35import qualified Elm.Compiler.Type.Extract as Extract
34import qualified Elm.ModuleName as ModuleName
36import qualified Elm.ModuleName as ModuleName
35import qualified Json.Decode as D
37import qualified Json.Decode as D
36import qualified Json.Encode as E
38import qualified Json.Encode as E
37import Json.Encode ((==>))
39import 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
38import qualified Reporting.Annotation as A
46import qualified Reporting.Annotation as A
39−import qualified Reporting.Error as Error
40import qualified Reporting.Error.Docs as E
47import qualified Reporting.Error.Docs as E
41−import qualified Reporting.Region as R
42import qualified Reporting.Result as Result
48import 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
@@ -55,21 +56,6 @@ type Documentation =
55 Map.Map Name.Name Module
56 Map.Map Name.Name Module
58−toDict :: [Module] -> Documentation
60− Map.fromList (map toPair modules)
64−toPair :: Module -> (Name.Name, Module)
65−toPair modul@(Module name _ _ _ _ _) =
73data Module =
59data Module =
75 { _name :: Name.Name
61 { _name :: Name.Name
@@ -80,9 +66,7 @@ data Module =
80 , _binops :: Map.Map Name.Name Binop
66 , _binops :: Map.Map Name.Name Binop
84−type Comment = Text.Text
69+type Comment = Json.String
87data Alias = Alias Comment [Name.Name] Type.Type
71data Alias = Alias Comment [Name.Name] Type.Type
88data Union = Union Comment [Name.Name] [(Name.Name, [Type.Type])]
72data Union = Union Comment [Name.Name] [(Name.Name, [Type.Type])]
@@ -91,14 +75,19 @@ data Binop = Binop Comment Type.Type Binop.Associativity Binop.Precedence
94−-- JSON ENCODE / DECODE
78+-- JSON
81+encode :: Documentation -> E.Value
83+ E.list encodeModule (Map.elems docs)
97−encode :: Module -> E.Value
86+encodeModule :: Module -> E.Value
98−encode (Module name comment unions aliases values binops) =
87+encodeModule (Module name comment unions aliases values binops) =
99 E.object $
88 E.object $
100 [ "name" ==> ModuleName.encode name
89 [ "name" ==> ModuleName.encode name
101− , "comment" ==> E.text comment
90+ , "comment" ==> E.string comment
102 , "unions" ==> E.list encodeUnion (Map.toList unions)
91 , "unions" ==> E.list encodeUnion (Map.toList unions)
103 , "aliases" ==> E.list encodeAlias (Map.toList aliases)
92 , "aliases" ==> E.list encodeAlias (Map.toList aliases)
104 , "values" ==> E.list encodeValue (Map.toList values)
93 , "values" ==> E.list encodeValue (Map.toList values)
@@ -107,16 +96,31 @@ encode (Module name comment unions aliases values binops) =
109data Error
98data Error
110− = BadAssociativity Text.Text
99+ = BadAssociativity
111− | BadName
100+ | BadModuleName
112 | BadType
101 | BadType
115−decoder :: D.Decoder Error Module
104+decoder :: D.Decoder Error Documentation
106+ toDict <$> D.list moduleDecoder
109+toDict :: [Module] -> Documentation
111+ Map.fromList (map toDictHelp modules)
114+toDictHelp :: Module -> (Name.Name, Module)
115+toDictHelp modul@(Module name _ _ _ _ _) =
119+moduleDecoder :: D.Decoder Error Module
118− <$> D.field "name" nameDecoder
122+ <$> D.field "name" moduleNameDecoder
119− <*> D.field "comment" D.text
123+ <*> D.field "comment" D.string
120 <*> D.field "unions" (dictDecoder union)
124 <*> D.field "unions" (dictDecoder union)
121 <*> D.field "aliases" (dictDecoder alias)
125 <*> D.field "aliases" (dictDecoder alias)
122 <*> D.field "values" (dictDecoder value)
126 <*> D.field "values" (dictDecoder value)
@@ -131,13 +135,18 @@ dictDecoder entryDecoder =
131named :: D.Decoder Error a -> D.Decoder Error (Name.Name, a)
135named :: D.Decoder Error a -> D.Decoder Error (Name.Name, a)
132named entryDecoder =
136named entryDecoder =
134− <$> D.field "name" D.name
138+ <$> D.field "name" nameDecoder
135 <*> entryDecoder
139 <*> entryDecoder
138−nameDecoder :: D.Decoder Error Name.Name
142+nameDecoder :: D.Decoder e Name.Name
139nameDecoder =
143nameDecoder =
144+ fmap Coerce.coerce D.string
147+moduleNameDecoder :: D.Decoder Error ModuleName.Raw
140− D.mapError (const BadName) ModuleName.decoder
149+ D.mapError (const BadModuleName) ModuleName.decoder
143typeDecoder :: D.Decoder Error Type.Type
152typeDecoder :: D.Decoder Error Type.Type
@@ -153,7 +162,7 @@ encodeUnion :: (Name.Name, Union) -> E.Value
153encodeUnion (name, Union comment args cases) =
162encodeUnion (name, Union comment args cases) =
155 [ "name" ==> E.name name
164 [ "name" ==> E.name name
156− , "comment" ==> E.text comment
165+ , "comment" ==> E.string comment
157 , "args" ==> E.list E.name args
166 , "args" ==> E.list E.name args
158 , "cases" ==> E.list encodeCase cases
167 , "cases" ==> E.list encodeCase cases
@@ -162,8 +171,8 @@ encodeUnion (name, Union comment args cases) =
162union :: D.Decoder Error Union
171union :: D.Decoder Error Union
165− <$> D.field "comment" D.text
174+ <$> D.field "comment" D.string
166− <*> D.field "args" (D.list D.name)
175+ <*> D.field "args" (D.list nameDecoder)
167 <*> D.field "cases" (D.list caseDecoder)
176 <*> D.field "cases" (D.list caseDecoder)
@@ -174,7 +183,7 @@ encodeCase ( tag, args ) =
175caseDecoder :: D.Decoder Error ( Name.Name, [Type.Type] )
184caseDecoder :: D.Decoder Error ( Name.Name, [Type.Type] )
176caseDecoder =
185caseDecoder =
177− D.pair D.name (D.list typeDecoder)
186+ D.pair nameDecoder (D.list typeDecoder)
@@ -185,7 +194,7 @@ encodeAlias :: (Name.Name, Alias) -> E.Value
185encodeAlias ( name, Alias comment args tipe) =
194encodeAlias ( name, Alias comment args tipe) =
187 [ "name" ==> E.name name
196 [ "name" ==> E.name name
188− , "comment" ==> E.text comment
197+ , "comment" ==> E.string comment
189 , "args" ==> E.list E.name args
198 , "args" ==> E.list E.name args
190 , "type" ==> Type.encode tipe
199 , "type" ==> Type.encode tipe
@@ -194,8 +203,8 @@ encodeAlias ( name, Alias comment args tipe) =
194alias :: D.Decoder Error Alias
203alias :: D.Decoder Error Alias
197− <$> D.field "comment" D.text
206+ <$> D.field "comment" D.string
198− <*> D.field "args" (D.list D.name)
207+ <*> D.field "args" (D.list nameDecoder)
199 <*> D.field "type" typeDecoder
208 <*> D.field "type" typeDecoder
@@ -207,7 +216,7 @@ encodeValue :: (Name.Name, Value) -> E.Value
207encodeValue (name, Value comment tipe) =
216encodeValue (name, Value comment tipe) =
209 [ "name" ==> E.name name
218 [ "name" ==> E.name name
210− , "comment" ==> E.text comment
219+ , "comment" ==> E.string comment
211 , "type" ==> Type.encode tipe
220 , "type" ==> Type.encode tipe
@@ -215,7 +224,7 @@ encodeValue (name, Value comment tipe) =
215value :: D.Decoder Error Value
224value :: D.Decoder Error Value
218− <$> D.field "comment" D.text
227+ <$> D.field "comment" D.string
219 <*> D.field "type" typeDecoder
228 <*> D.field "type" typeDecoder
@@ -227,7 +236,7 @@ encodeBinop :: (Name.Name, Binop) -> E.Value
227encodeBinop (name, Binop comment tipe assoc prec) =
236encodeBinop (name, Binop comment tipe assoc prec) =
229 [ "name" ==> E.name name
238 [ "name" ==> E.name name
230− , "comment" ==> E.text comment
239+ , "comment" ==> E.string comment
231 , "type" ==> Type.encode tipe
240 , "type" ==> Type.encode tipe
232 , "associativity" ==> encodeAssoc assoc
241 , "associativity" ==> encodeAssoc assoc
233 , "precedence" ==> encodePrec prec
242 , "precedence" ==> encodePrec prec
@@ -237,7 +246,7 @@ encodeBinop (name, Binop comment tipe assoc prec) =
237binop :: D.Decoder Error Binop
246binop :: D.Decoder Error Binop
240− <$> D.field "comment" D.text
249+ <$> D.field "comment" D.string
241 <*> D.field "type" typeDecoder
250 <*> D.field "type" typeDecoder
242 <*> D.field "associativity" assocDecoder
251 <*> D.field "associativity" assocDecoder
243 <*> D.field "precedence" precDecoder
252 <*> D.field "precedence" precDecoder
@@ -250,19 +259,23 @@ binop =
250encodeAssoc :: Binop.Associativity -> E.Value
259encodeAssoc :: Binop.Associativity -> E.Value
251encodeAssoc assoc =
260encodeAssoc assoc =
252 case assoc of
261 case assoc of
253− Binop.Left -> E.text "left"
262+ Binop.Left -> E.chars "left"
254− Binop.Non -> E.text "non"
263+ Binop.Non -> E.chars "non"
255− Binop.Right -> E.text "right"
264+ Binop.Right -> E.chars "right"
258assocDecoder :: D.Decoder Error Binop.Associativity
267assocDecoder :: D.Decoder Error Binop.Associativity
259assocDecoder =
268assocDecoder =
260− do txt <- D.text
269+ let
261− case txt of
270+ left = Json.fromChars "left"
271+ non = Json.fromChars "non"
272+ right = Json.fromChars "right"
262− "left" -> D.succeed Binop.Left
275+ if | str == left -> return Binop.Left
263− "non" -> D.succeed Binop.Non
276+ | str == non -> return Binop.Non
264− "right" -> D.succeed Binop.Right
277+ | str == right -> return Binop.Right
265− _ -> D.fail (BadAssociativity txt)
278+ | otherwise -> D.failure BadAssociativity
@@ -283,142 +296,190 @@ precDecoder =
283-- FROM MODULE
296-- FROM MODULE
286−fromModule :: Can.Module -> Result.Result i w Error.Error Module
299+fromModule :: Can.Module -> Either E.Error Module
287−fromModule (Can.Module name docs exports decls unions aliases binops effects) =
300+fromModule modul@(Can.Module _ exports docs _ _ _ _ _) =
288 case exports of
301 case exports of
289 Can.ExportEverything region ->
302 Can.ExportEverything region ->
290− Result.throw $ Error.Docs $ E.ImplicitExposing region
303+ Left (E.ImplicitExposing region)
292 Can.Export exportDict ->
305 Can.Export exportDict ->
293 case docs of
306 case docs of
294− Can.NoDocs region ->
307+ Src.NoDocs region ->
295− Result.throw $ Error.Docs $ E.NoDocs region
308+ Left (E.NoDocs region)
297− Can.YesDocs region overview comments ->
310+ Src.YesDocs overview comments ->
298− do names <- parseOverview region overview
311+ do names <- parseOverview overview
299− Result.mapError Error.Docs $
300− do checkNames exportDict names
312+ checkNames exportDict names
301− let types = gatherTypes decls Map.empty
313+ checkDefs exportDict overview (Map.fromList comments) modul
302− let info = Info comments types unions aliases binops effects
303− inserters <- Map.traverseWithKey (checkExport info) exportDict
304− return $ foldr ($) (emptyModule name overview) inserters
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
313-- PARSE OVERVIEW
317-- PARSE OVERVIEW
316−parseOverview :: R.Region -> B.ByteString -> Result.Result i w Error.Error [A.Located Name.Name]
320+parseOverview :: Src.Comment -> Either E.Error [A.Located Name.Name]
317−parseOverview (R.Region (R.Position row col) _) overview =
321+parseOverview (Src.Comment snippet) =
318− case P.runAt row (col + 3) (chompOverview []) overview of
322+ case P.fromSnippet (chompOverview []) E.BadEnd snippet of
319 Left err ->
323 Left err ->
320− Result.throw (Error.Syntax err)
324+ Left (E.SyntaxProblem err)
322 Right names ->
326 Right names ->
323− Result.ok names
327+ Right names
331+ P.Parser E.SyntaxProblem a
326chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
334chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
327chompOverview names =
335chompOverview names =
328− do isDocs <- W.chompUntilDocs
336+ do isDocs <- chompUntilDocs
329 if isDocs
337 if isDocs
330− then chompOverviewHelp names
338+ then
331− else return names
339+ do Space.chomp E.Space
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
339− then chompOverview names
340− else chompOverview =<< chompDocs names
340+ chompOverview =<< chompDocs names
343chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
345chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
344chompDocs names =
346chompDocs names =
345− do name <- P.addLocation (P.oneOf [ Var.lower, Var.upper, chompBinop ])
347+ do name <-
346− spos <- W.whitespace
348+ P.addLocation $
347− P.oneOf
349+ P.oneOf E.Export
348− [ do P.checkSpace spos
350+ [ Var.lower E.Export
349− Symbol.comma
351+ , Var.upper E.Export
350− P.spaces
352+ , chompOperator
358+ [ do pos <- P.getPosition
359+ Space.checkIndent pos E.Comma
360+ word1 0x2C {-,-} E.Comma
351 chompDocs (name:names)
362 chompDocs (name:names)
352− , return (name:names)
356−chompBinop :: Parser Name.Name
367+chompOperator :: Parser Name.Name
357−chompBinop =
368+chompOperator =
358− do Symbol.leftParen
369+ do word1 0x28 {-(-} E.Op
359− name <- Symbol.binop
370+ op <- Symbol.operator E.Op E.OpBad
360− Symbol.rightParen
371+ word1 0x29 {-)-} E.Op
361− return name
372+ return op
375+-- TODO add rule that @docs must be after newline in 0.20
377+chompUntilDocs :: Parser Bool
379+ P.Parser $ \(P.State src pos end indent row col) cok _ _ _ ->
381+ (# isDocs, newPos, newRow, newCol #) = untilDocs pos end row col
382+ !newState = P.State src newPos end indent newRow newCol
387+untilDocs :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Bool, Ptr Word8, Row, Col #)
388+untilDocs pos end row col =
390+ (# False, pos, row, col #)
392+ let !word = P.unsafeIndex pos in
393+ if word == 0x0A {-\n-} then
394+ untilDocs (plusPtr pos 1) end (row + 1) 1
396+ let !pos5 = plusPtr pos 5 in
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
405+ (# True, pos5, row, col + 5 #)
407+ let !newPos = plusPtr pos (P.getCharWidth pos end word) in
408+ untilDocs newPos end row (col + 1)
365-- CHECK NAMES
412-- CHECK NAMES
368−type Result i w a =
415+checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Either E.Error ()
369− Result.Result i w E.Error a
416+checkNames exports names =
371−
418+ docs = List.foldl' addName Map.empty names
372−type Dups =
419+ loneDoc = Map.traverseMissing onlyInDocs
373− Map.Map Name.Name (OneOrMore.OneOrMore R.Region)
420+ loneExport = Map.traverseMissing onlyInExports
421+ checkBoth = Map.zipWithAMatched (\n _ r -> isUnique n r)
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))
376−checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Result i w ()
428+type DocNameRegions =
377−checkNames exports names =
429+ Map.Map Name.Name (OneOrMore.OneOrMore A.Region)
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
383− do _ <- Map.traverseWithKey onlyInDocs (Map.difference docs exports)
384− _ <- Map.traverseWithKey onlyInExports (Map.difference exports docs)
388−addName :: Dups -> A.Located Name.Name -> Dups
432+addName :: DocNameRegions -> A.Located Name.Name -> DocNameRegions
389addName dict (A.At region name) =
433addName dict (A.At region name) =
390 Map.insertWith OneOrMore.more name (OneOrMore.one region) dict
434 Map.insertWith OneOrMore.more name (OneOrMore.one region) dict
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
394isUnique name regions =
438isUnique name regions =
395 case regions of
439 case regions of
396 OneOrMore.One region ->
440 OneOrMore.One region ->
397 Result.ok region
441 Result.ok region
399− OneOrMore.More _ _ ->
443+ OneOrMore.More left right ->
400− let (r1:r2:_) = OneOrMore.toList regions in
444+ let (r1, r2) = OneOrMore.getFirstTwo left right in
401− Result.throw (E.Duplicate name r1 r2)
445+ Result.throw (E.NameDuplicate name r1 r2)
404−onlyInDocs :: Name.Name -> R.Region -> Result i w a
448+onlyInDocs :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result.Result i w E.NameProblem a
405−onlyInDocs name region =
449+onlyInDocs name regions =
450+ do region <- isUnique name regions
406− Result.throw $ E.OnlyInDocs name region
451+ Result.throw $ E.NameOnlyInDocs name region
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
410onlyInExports name (A.At region _) =
455onlyInExports name (A.At region _) =
411− Result.throw $ E.OnlyInExports name region
456+ Result.throw $ E.NameOnlyInExports name region
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) =
466+ types = gatherTypes decls Map.empty
467+ info = Info comments types unions aliases infixes effects
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
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
418data Info =
479data Info =
420− { _iComments :: Map.Map Name.Name Comment
481+ { _iComments :: Map.Map Name.Name Src.Comment
421− , _iValues :: Types
482+ , _iValues :: Map.Map Name.Name (Either A.Region Can.Type)
422 , _iUnions :: Map.Map Name.Name Can.Union
483 , _iUnions :: Map.Map Name.Name Can.Union
423 , _iAliases :: Map.Map Name.Name Can.Alias
484 , _iAliases :: Map.Map Name.Name Can.Alias
424 , _iBinops :: Map.Map Name.Name Can.Binop
485 , _iBinops :: Map.Map Name.Name Can.Binop
@@ -426,7 +487,7 @@ data Info =
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)
430checkExport info name (A.At region export) =
491checkExport info name (A.At region export) =
431 case export of
492 case export of
432 Can.ExportValue ->
493 Can.ExportValue ->
@@ -467,23 +528,23 @@ checkExport info name (A.At region export) =
467 m { _values = Map.insert name (Value comment tipe) (_values m) }
528 m { _values = Map.insert name (Value comment tipe) (_values m) }
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
471getComment region name info =
532getComment region name info =
472 case Map.lookup name (_iComments info) of
533 case Map.lookup name (_iComments info) of
473 Nothing ->
534 Nothing ->
474 Result.throw (E.NoComment name region)
535 Result.throw (E.NoComment name region)
476− Just comment ->
537+ Just (Src.Comment snippet) ->
477− Result.ok comment
538+ Result.ok (Json.fromComment snippet)
480−getType :: Name.Name -> Info -> Result i w Type.Type
541+getType :: Name.Name -> Info -> Result.Result i w E.DefProblem Type.Type
481getType name info =
542getType name info =
482 case _iValues info ! name of
543 case _iValues info ! name of
483− A.At defRegion Nothing ->
544+ Left region ->
484− Result.throw (E.NoAnnotation name defRegion)
545+ Result.throw (E.NoAnnotation name region)
486− A.At _ (Just tipe) ->
547+ Right tipe ->
487 Result.ok (Extract.fromType tipe)
548 Result.ok (Extract.fromType tipe)
@@ -497,7 +558,7 @@ dector (Can.Ctor name _ _ args) =
499type Types =
560type Types =
500− Map.Map Name.Name (A.Located (Maybe Can.Type))
561+ Map.Map Name.Name (Either A.Region Can.Type)
503gatherTypes :: Can.Decls -> Types -> Types
564gatherTypes :: Can.Decls -> Types -> Types
@@ -506,8 +567,8 @@ gatherTypes decls types =
506 Can.Declare def subDecls ->
567 Can.Declare def subDecls ->
507 gatherTypes subDecls (addDef types def)
568 gatherTypes subDecls (addDef types def)
509− Can.DeclareRec defs subDecls ->
570+ Can.DeclareRec def defs subDecls ->
510− gatherTypes subDecls (List.foldl' addDef types defs)
571+ gatherTypes subDecls (List.foldl' addDef (addDef types def) defs)
512 Can.SaveTheEnvironment ->
573 Can.SaveTheEnvironment ->
@@ -517,11 +578,10 @@ addDef :: Types -> Can.Def -> Types
517addDef types def =
578addDef types def =
518 case def of
579 case def of
519 Can.Def (A.At region name) _ _ ->
580 Can.Def (A.At region name) _ _ ->
520− Map.insert name (A.At region Nothing) types
581+ Map.insert name (Left region) types
522− Can.TypedDef (A.At region name) _ typedArgs _ resultType ->
583+ Can.TypedDef (A.At _ name) _ typedArgs _ resultType ->
525− foldr Can.TLambda resultType (map snd typedArgs)
585+ tipe = foldr Can.TLambda resultType (map snd typedArgs)
527− Map.insert name (A.At region (Just tipe)) types
587+ Map.insert name (Right tipe) types