57e03b9 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Revive code to verify module documentation

57e03b9Evan Czaplicki9 years ago

src/AST/Canonical.hs+2−2

compare with master

unifiedsplit

@@ -236,7 +236,7 @@ data AliasType

236data Module =

237 Module

238 { _name :: ModuleName.Canonical

239− , _docs :: A.Located (Maybe Docs)

239+ , _docs :: Maybe (A.Located Docs)

240 , _exports :: Exports

241 , _decls :: Decls

242 , _unions :: Map.Map N.Name Union

@@ -268,7 +268,7 @@ data Docs =

268

269data Exports

270 = ExportEverything

271− | Export (Map.Map N.Name Export)

271+ | Export (Map.Map N.Name (A.Located Export))

272

273

274data Export

src/AST/Source.hs+1−1

@@ -137,7 +137,7 @@ data Header

137 { _name :: N.Name

138 , _effects :: Effects

139 , _exports :: Exposing

140− , _docs :: A.Located (Maybe B.ByteString)

140+ , _docs :: Maybe (A.Located B.ByteString)

141 }

142

143

src/AST/Valid.hs+2−7

@@ -75,7 +75,7 @@ data Def

75data Module =

76 Module

77 { _name :: N.Name

78− , _overview :: A.Located (Maybe B.ByteString)

78+ , _overview :: Maybe (A.Located B.ByteString)

79 , _docs :: Map.Map N.Name Text

80 , _exports :: Src.Exposing

81 , _imports :: [Src.Import]

@@ -112,7 +112,7 @@ defaultModule :: Map.Map N.Name Text -> [Src.Import] -> [A.Located Decl] -> [Uni

112defaultModule docs imports decls unions aliases binop =

113 Module

114 { _name = "Main"

115− , _overview = A.At zero Nothing

115+ , _overview = Nothing

116 , _docs = docs

117 , _exports = Src.Open

118 , _imports = imports

@@ -122,8 +122,3 @@ defaultModule docs imports decls unions aliases binop =

122 , _binop = binop

123 , _effects = NoEffects

124 }

125−

126−

127−zero :: R.Region

128−zero =

129− R.Region (R.Position 1 1) (R.Position 1 1)

src/Canonicalize/Module.hs+19−13

@@ -26,6 +26,7 @@ import qualified Elm.Name as N

26import qualified Elm.Package as Pkg

27import qualified Reporting.Annotation as A

28import qualified Reporting.Error.Canonicalize as Error

29+import qualified Reporting.Region as R

29import qualified Reporting.Result as Result

30import qualified Reporting.Result as Result

30import qualified Reporting.Warning as W

31import qualified Reporting.Warning as W

@@ -77,14 +78,14 @@ canonicalize pkg importDict interfaces module_@(Valid.Module name _ _ exports im

77-- DOCUMENTATION

78-- DOCUMENTATION

80−toDocs :: Valid.Module -> A.Located (Maybe Can.Docs)

81+toDocs :: Valid.Module -> Maybe (A.Located Can.Docs)

81−toDocs (Valid.Module _ (A.At region maybeOverview) comments _ _ _ _ _ _ _) =

82+toDocs (Valid.Module _ docs comments _ _ _ _ _ _ _) =

82− case maybeOverview of

83+ case docs of

83 Nothing ->

84 Nothing ->

84− A.At region Nothing

85+ Nothing

86− Just overview ->

87+ Just (A.At region overview) ->

87− A.At region (Just (Can.Docs overview comments))

88+ Just (A.At region (Can.Docs overview comments))

@@ -290,16 +291,16 @@ checkExposed

290 -> Map.Map N.Name binop

291 -> Map.Map N.Name binop

291 -> Can.Effects

292 -> Can.Effects

292 -> A.Located Src.Exposed

293 -> A.Located Src.Exposed

293− -> Result i w (Dups.Dict () Can.Export)

294+ -> Result i w (Dups.Dict () (A.Located Can.Export))

294checkExposed decls unions aliases binops effects (A.At region exposed) =

295checkExposed decls unions aliases binops effects (A.At region exposed) =

295 case exposed of

296 case exposed of

296 Src.Lower name ->

297 Src.Lower name ->

297 if Map.member name decls then

298 if Map.member name decls then

298− Result.ok (Dups.one name region () Can.ExportValue)

299+ ok name region Can.ExportValue

299 else

300 else

300 case checkPorts effects name of

301 case checkPorts effects name of

301 Nothing ->

302 Nothing ->

302− Result.ok (Dups.one name region () Can.ExportPort)

303+ ok name region Can.ExportPort

303

304

304 Just ports ->

305 Just ports ->

305 Result.throw $ Error.ExportNotFound region Error.BadVar name $

306 Result.throw $ Error.ExportNotFound region Error.BadVar name $

@@ -307,14 +308,14 @@ checkExposed decls unions aliases binops effects (A.At region exposed) =

307

308

308 Src.Operator name ->

309 Src.Operator name ->

309 if Map.member name binops then

310 if Map.member name binops then

310− Result.ok (Dups.one name region () Can.ExportBinop)

311+ ok name region Can.ExportBinop

311 else

312 else

312 Result.throw $ Error.ExportNotFound region Error.BadOp name $

313 Result.throw $ Error.ExportNotFound region Error.BadOp name $

313 Map.keys binops

314 Map.keys binops

314

315

315 Src.Upper name Src.Public ->

316 Src.Upper name Src.Public ->

316 if Map.member name unions then

317 if Map.member name unions then

317− Result.ok (Dups.one name region () Can.ExportUnionOpen)

318+ ok name region Can.ExportUnionOpen

318 else if Map.member name aliases then

319 else if Map.member name aliases then

319 Result.throw $ Error.ExportOpenAlias region name

320 Result.throw $ Error.ExportOpenAlias region name

320 else

321 else

@@ -323,9 +324,9 @@ checkExposed decls unions aliases binops effects (A.At region exposed) =

323

324

324 Src.Upper name Src.Private ->

325 Src.Upper name Src.Private ->

325 if Map.member name unions then

326 if Map.member name unions then

326− Result.ok (Dups.one name region () Can.ExportUnionClosed)

327+ ok name region Can.ExportUnionClosed

327 else if Map.member name aliases then

328 else if Map.member name aliases then

328− Result.ok (Dups.one name region () Can.ExportAlias)

329+ ok name region Can.ExportAlias

329 else

330 else

330 Result.throw $ Error.ExportNotFound region Error.BadType name $

331 Result.throw $ Error.ExportNotFound region Error.BadType name $

331 Map.keys unions ++ Map.keys aliases

332 Map.keys unions ++ Map.keys aliases

@@ -342,3 +343,8 @@ checkPorts effects name =

342

343

343 Can.Manager _ _ _ _ ->

344 Can.Manager _ _ _ _ ->

344 Just []

345 Just []

346+

347+

348+ok :: N.Name -> R.Region -> Can.Export -> Result i w (Dups.Dict () (A.Located Can.Export))

349+ok name region export =

350+ Result.ok $ Dups.one name region () (A.At region export)

src/Docs/Check.hsdeleted−234

@@ -1,234 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Docs.Check

3− ( check

4− )

5− where

6−

7−

8−import Data.List.NonEmpty (NonEmpty((:|)))

9−import qualified Data.Map as Map

10−import qualified Data.Set as Set

11−import Data.Text (Text)

12−

13−import qualified AST.Exposing as Exposing

14−import qualified Docs.AST as Docs

15−import qualified Elm.Compiler.Type as Type

16−import qualified Reporting.Annotation as A

17−import qualified Reporting.Error as Error

18−import qualified Reporting.Error.Docs as E

19−import qualified Reporting.Helpers as Help (nearbyNames)

20−import qualified Reporting.Region as R

21−import qualified Reporting.Result as R

22−import Parse.Helpers

23− ( Parser, addLocation, getPosition

24− , spaces, checkSpace, whitespace, SPos(..)

25− , capVar, lowVar, leftParen, rightParen, infixOp, runAt

26− , chompUntilDocs, comma, oneOf

27− )

28−

29−

30−

31−-- CHECK

32−

33−

34−check :: Exposing.Canonical -> A.Located (Maybe Docs.Centralized) -> R.Result () w Error.Error Docs.Checked

35−check exports (A.A region maybeDocs) =

36− case maybeDocs of

37− Nothing ->

38− R.throw region (Error.Docs E.NoDocs)

39−

40− Just docs ->

41− checkHelp region exports docs

42−

43−

44−checkHelp :: R.Region -> Exposing.Canonical -> Docs.Centralized -> R.Result () w Error.Error Docs.Checked

45−checkHelp region exposing (Docs.Docs overview unions aliases values) =

46− do docNames <- parseNames region overview

47−

48− let docSet = Set.fromList (map A.drop docNames)

49− let restrict checker dict =

50− Map.traverseWithKey (checkEntry checker) (Map.restrictKeys dict docSet)

51−

52− R.mapError Error.Docs $

53− Docs.Docs overview

54− <$> restrict (checkUnion exposing) unions

55− <*> restrict checkAlias aliases

56− <*> restrict checkValue values

57− <* checkCommentNames region exposing docNames

58−

59−

60−

61−-- CHECK COMMENT NAMES

62−

63−

64−type Result w a = R.Result () w E.Error a

65−

66−

67−checkCommentNames :: R.Region -> Exposing.Canonical -> [A.Located Text] -> Result w ()

68−checkCommentNames region (Exposing.Canonical values aliases unions) docNames =

69− let

70− addUnit name =

71− ( name, () )

72−

73− exposed =

74− Map.fromList $ map addUnit $

75− values ++ aliases ++ map fst unions

76−

77− docDict =

78− A.listToDict id docNames

79− in

80− checkOnlyInExports region (Map.difference exposed docDict)

81− <* Map.traverseMaybeWithKey (checkDocName exposed) docDict

82−

83−

84−checkOnlyInExports :: R.Region -> Map.Map Text () -> Result w ()

85−checkOnlyInExports region onlyInExports =

86− case Map.keys onlyInExports of

87− [] ->

88− R.ok ()

89−

90− names ->

91− R.throw region (E.OnlyInExports names)

92−

93−

94−checkDocName :: Map.Map Text () -> Text -> NonEmpty R.Region -> Result w (Maybe a)

95−checkDocName exposed name (region :| duplicates) =

96− case duplicates of

97− [] ->

98− if Map.member name exposed then

99− R.ok Nothing

100−

101− else

102− R.throw region $ E.OnlyInDocs name $

103− Help.nearbyNames id name (Map.keys exposed)

104−

105− _ ->

106− R.throw region (E.Duplicates name)

107−

108−

109−

110−-- CHECK COMMENT

111−

112−

113−checkComment :: R.Region -> Text -> Maybe Text -> Result w Text

114−checkComment region name maybeComment =

115− case maybeComment of

116− Just comment ->

117− R.ok comment

118−

119− Nothing ->

120− R.throw region (E.NoComment name)

121−

122−

123−

124−-- CHECK ENTRY

125−

126−

127−checkEntry :: (R.Region -> Text -> a -> Result w b) -> Text -> Docs.Raw a -> Result w (Docs.Good b)

128−checkEntry checkDetails name (A.A region (Docs.Entry comment details)) =

129− Docs.Entry

130− <$> checkComment region name comment

131− <*> checkDetails region name details

132−

133−

134−

135−-- CHECK UNION

136−

137−

138−checkUnion :: Exposing.Canonical -> R.Region -> Text -> Docs.Union -> Result w Docs.Union

139−checkUnion (Exposing.Canonical _ _ unions) _region name (Docs.Union args ctors) =

140− let

141− publicCtors =

142− maybe [] id (lookup name unions)

143−

144− isPublic (ctor, _) =

145− ctor `elem` publicCtors

146− in

147− pure $ Docs.Union args (filter isPublic ctors)

148−

149−

150−

151−-- CHECK ALIAS

152−

153−

154−checkAlias :: R.Region -> Text -> Docs.Alias -> Result w Docs.Alias

155−checkAlias _ _ alias =

156− pure alias

157−

158−

159−

160−-- CHECK VALUE

161−

162−

163−checkValue :: R.Region -> Text -> Docs.RawValue -> Result w Docs.GoodValue

164−checkValue region name value =

165− case value of

166− Docs.Value tipe ->

167− Docs.Value

168− <$> checkValueType region name tipe

169−

170− Docs.Infix tipe assoc prec ->

171− Docs.Infix

172− <$> checkValueType region name tipe

173− <*> pure assoc

174− <*> pure prec

175−

176−

177−checkValueType :: R.Region -> Text -> Maybe Type.Type -> Result w Type.Type

178−checkValueType region name maybeType =

179− case maybeType of

180− Just tipe ->

181− R.ok tipe

182−

183− Nothing ->

184− R.throw region (E.NoType name)

185−

186−

187−

188−-- PARSE DOC COMMENT

189−

190−

191−parseNames :: R.Region -> Text -> R.Result () w Error.Error [A.Located Text]

192−parseNames (R.Region (R.Position row col) _) comment =

193− case runAt row (col + 3) (namesParser []) comment of

194− Left (A.A region parseError) ->

195− R.throw region (Error.Syntax parseError)

196−

197− Right names ->

198− R.ok names

199−

200−

201−namesParser :: [A.Located Text] -> Parser [A.Located Text]

202−namesParser names =

203− do isDocs <- chompUntilDocs

204− if isDocs then namesParserHelp names else return names

205−

206−

207−namesParserHelp :: [A.Located Text] -> Parser [A.Located Text]

208−namesParserHelp names =

209− do pos <- getPosition

210− (SPos spos) <- whitespace

211− if pos == spos

212− then namesParser names

213− else namesParser =<< chompNames names

214−

215−

216−chompNames :: [A.Located Text] -> Parser [A.Located Text]

217−chompNames names =

218− do name <- addLocation (oneOf [ lowVar, capVar, operator ])

219− spos <- whitespace

220− oneOf

221− [ do checkSpace spos

222− comma

223− spaces

224− chompNames (name:names)

225− , return (name:names)

226− ]

227−

228−

229−operator :: Parser Text

230−operator =

231− do leftParen

232− op <- infixOp

233− rightParen

234− return op

src/Elm/Docs.hs+293−24

@@ -2,30 +2,50 @@

2{-# LANGUAGE OverloadedStrings #-}

3module Elm.Docs

4 ( Documentation

5− , Module(..)

6 , toDict

5 , toDict

7− , decoder

6+ , Module(..)

8− , encode

7+ , fromCanonical

9 , Union(..)

8 , Union(..)

10 , Alias(..)

9 , Alias(..)

11 , Value(..)

10 , Value(..)

12 , Binop(..)

11 , Binop(..)

13 , Binop.Associativity(..)

12 , Binop.Associativity(..)

14 , Binop.Precedence(..)

13 , Binop.Precedence(..)

14+ , decoder

15+ , encode

15 )

16 )

16 where

17 where

20+import Control.Monad (foldM)

21+import qualified Data.ByteString as B

22+import qualified Data.List as List

23+import Data.Map ((!))

19import qualified Data.Map as Map

24import qualified Data.Map as Map

25+import qualified Data.Text as Text

20−import Data.Text (Text)

26+import qualified Data.Text.Encoding as Text

28+import qualified AST.Canonical as Can

29+import qualified AST.Module.Name as ModuleName

22import qualified AST.Utils.Binop as Binop

30import qualified AST.Utils.Binop as Binop

31+import qualified Data.OneOrMore as OneOrMore

23import qualified Elm.Compiler.Module as Module

32import qualified Elm.Compiler.Module as Module

24import qualified Elm.Compiler.Type as Type

33import qualified Elm.Compiler.Type as Type

34+import qualified Elm.Compiler.Type.Extract as Extract

25import qualified Elm.Name as N

35import qualified Elm.Name as N

26import qualified Json.Decode as Decode

36import qualified Json.Decode as Decode

27import qualified Json.Encode as Encode

37import qualified Json.Encode as Encode

28import Json.Encode ((==>))

38import Json.Encode ((==>))

39+import qualified Reporting.Annotation as A

40+import qualified Reporting.Error as Error

41+import qualified Reporting.Error.Docs as E

42+import qualified Reporting.Region as R

43+import qualified Reporting.Result as Result

44+import Parse.Primitives (Parser)

45+import qualified Parse.Primitives as P

46+import qualified Parse.Primitives.Symbol as Symbol

47+import qualified Parse.Primitives.Variable as Var

48+import qualified Parse.Primitives.Whitespace as W

@@ -54,7 +74,7 @@ toPair modul@(Module name _ _ _ _ _) =

54data Module =

74data Module =

55 Module

75 Module

56 { _name :: N.Name

76 { _name :: N.Name

57− , _comment :: Text

77+ , _comment :: Comment

58 , _unions :: Map.Map N.Name Union

78 , _unions :: Map.Map N.Name Union

59 , _aliases :: Map.Map N.Name Alias

79 , _aliases :: Map.Map N.Name Alias

60 , _values :: Map.Map N.Name Value

80 , _values :: Map.Map N.Name Value

@@ -62,14 +82,17 @@ data Module =

62 }

82 }

65−data Alias = Alias Text [N.Name] Type.Type

85+type Comment = Text.Text

66−data Union = Union Text [N.Name] [(N.Name, [Type.Type])]

67−data Value = Value Text Type.Type

68−data Binop = Binop Text Type.Type Binop.Associativity Binop.Precedence

88+data Alias = Alias Comment [N.Name] Type.Type

89+data Union = Union Comment [N.Name] [(N.Name, [Type.Type])]

90+data Value = Value Comment Type.Type

91+data Binop = Binop Comment Type.Type Binop.Associativity Binop.Precedence

93+

94+

72−-- ENCODE

95+-- JSON ENCODE / DECODE

75encode :: Module -> Encode.Value

98encode :: Module -> Encode.Value

@@ -84,10 +107,6 @@ encode (Module name comment unions aliases values binops) =

84 ]

107 ]

108

109

87−

88−-- DECODE

89−

90−

91decoder :: Decode.Decoder Module

110decoder :: Decode.Decoder Module

92decoder =

111decoder =

93 Module

112 Module

@@ -112,7 +131,7 @@ named entryDecoder =

112

131

113

132

114

133

115−-- UNION

134+-- UNION JSON

116

135

117

136

118encodeUnion :: (N.Name, Union) -> Encode.Value

137encodeUnion :: (N.Name, Union) -> Encode.Value

@@ -133,10 +152,6 @@ union =

133 <*> Decode.field "cases" (Decode.list caseDecoder)

152 <*> Decode.field "cases" (Decode.list caseDecoder)

134

153

135

154

136−

137−-- UNION CASE

138−

139−

140encodeCase :: ( N.Name, [Type.Type] ) -> Encode.Value

155encodeCase :: ( N.Name, [Type.Type] ) -> Encode.Value

141encodeCase ( tag, args ) =

156encodeCase ( tag, args ) =

142 Encode.list id [ Encode.text tag, Encode.list Type.encode args ]

157 Encode.list id [ Encode.text tag, Encode.list Type.encode args ]

@@ -150,7 +165,7 @@ caseDecoder =

150

165

151

166

152

167

153−-- ALIAS

168+-- ALIAS JSON

154

169

155

170

156encodeAlias :: (N.Name, Alias) -> Encode.Value

171encodeAlias :: (N.Name, Alias) -> Encode.Value

@@ -172,7 +187,7 @@ alias =

172

187

173

188

174

189

175−-- ENCODE VALUE

190+-- VALUE JSON

176

191

177

192

178encodeValue :: (N.Name, Value) -> Encode.Value

193encodeValue :: (N.Name, Value) -> Encode.Value

@@ -192,7 +207,7 @@ value =

192

207

193

208

194

209

195−-- BINOP

210+-- BINOP JSON

196

211

197

212

198encodeBinop :: (N.Name, Binop) -> Encode.Value

213encodeBinop :: (N.Name, Binop) -> Encode.Value

@@ -216,7 +231,7 @@ binop =

216

231

217

232

218

233

219−-- ASSOCIATIVITY

234+-- ASSOCIATIVITY JSON

220

235

221

236

222encodeAssoc :: Binop.Associativity -> Encode.Value

237encodeAssoc :: Binop.Associativity -> Encode.Value

@@ -238,7 +253,7 @@ assocDecoder =

238

253

239

254

240

255

241−-- PRECEDENCE

256+-- PRECEDENCE JSON

242

257

243

258

244encodePrec :: Binop.Precedence -> Encode.Value

259encodePrec :: Binop.Precedence -> Encode.Value

@@ -249,3 +264,257 @@ encodePrec (Binop.Precedence n) =

249precDecoder :: Decode.Decoder Binop.Precedence

264precDecoder :: Decode.Decoder Binop.Precedence

250precDecoder =

265precDecoder =

251 Binop.Precedence <$> Decode.int

266 Binop.Precedence <$> Decode.int

267+

268+

269+

270+-- FROM MODULE

271+

272+

273+fromCanonical :: Can.Module -> Result.Result i w Error.Error Module

274+fromCanonical (Can.Module name docs exports decls unions aliases binops effects) =

275+ case exports of

276+ Can.ExportEverything ->

277+ Result.throw $ Error.Docs $ E.ImplicitExposing

278+

279+ Can.Export exportDict ->

280+ case docs of

281+ Nothing ->

282+ Result.throw $ Error.Docs $ E.NoDocs

283+

284+ Just (A.At region (Can.Docs overview comments)) ->

285+ do names <- parseOverview region overview

286+ Result.mapError Error.Docs $

287+ do checkNames exportDict names

288+ let types = gatherTypes decls Map.empty

289+ foldM

290+ (addExport (Info comments types unions aliases binops effects))

291+ (emptyModule name overview)

292+ (Map.toList exportDict)

293+

294+

295+emptyModule :: ModuleName.Canonical -> B.ByteString -> Module

296+emptyModule (ModuleName.Canonical _ name) overview =

297+ Module name (Text.decodeUtf8 overview) Map.empty Map.empty Map.empty Map.empty

298+

299+

300+

301+-- PARSE OVERVIEW

302+

303+

304+type LName = A.Located N.Name

305+

306+

307+parseOverview :: R.Region -> B.ByteString -> Result.Result i w Error.Error [LName]

308+parseOverview (R.Region (R.Position row col) _) overview =

309+ case P.runAt row (col + 3) (chompOverview []) overview of

310+ Left err ->

311+ Result.throw (Error.Syntax err)

312+

313+ Right names ->

314+ Result.ok names

315+

316+

317+chompOverview :: [LName] -> Parser [LName]

318+chompOverview names =

319+ do isDocs <- W.chompUntilDocs

320+ if isDocs

321+ then chompOverviewHelp names

322+ else return names

323+

324+

325+chompOverviewHelp :: [LName] -> Parser [LName]

326+chompOverviewHelp names =

327+ do pos <- P.getPosition

328+ (W.SPos spos) <- W.whitespace

329+ if pos == spos

330+ then chompOverview names

331+ else chompOverview =<< chompDocs names

332+

333+

334+chompDocs :: [LName] -> Parser [LName]

335+chompDocs names =

336+ do name <- P.addLocation (P.oneOf [ Var.lower, Var.upper, chompBinop ])

337+ spos <- W.whitespace

338+ P.oneOf

339+ [ do P.checkSpace spos

340+ Symbol.comma

341+ P.spaces

342+ chompDocs (name:names)

343+ , return (name:names)

344+ ]

345+

346+

347+chompBinop :: Parser N.Name

348+chompBinop =

349+ do Symbol.leftParen

350+ name <- Symbol.binop

351+ Symbol.rightParen

352+ return name

353+

354+

355+

356+-- CHECK NAMES

357+

358+

359+type Result i w a =

360+ Result.Result i w E.Error a

361+

362+

363+type Dups =

364+ Map.Map N.Name (OneOrMore.OneOrMore R.Region)

365+

366+

367+checkNames :: Map.Map N.Name (A.Located Can.Export) -> [LName] -> Result i w ()

368+checkNames exports names =

369+ do docs <- Map.traverseWithKey isUnique (List.foldl' addName Map.empty names)

370+ let overlap = Map.size (Map.intersection docs exports)

371+ if Map.size exports == overlap && overlap == Map.size docs

372+ then Result.ok ()

373+ else

374+ do _ <- Map.traverseWithKey onlyInDocs (Map.difference docs exports)

375+ _ <- Map.traverseWithKey onlyInExports (Map.difference exports docs)

376+ Result.ok ()

377+

378+

379+addName :: Dups -> LName -> Dups

380+addName dict (A.At region name) =

381+ Map.insertWith OneOrMore.more name (OneOrMore.one region) dict

382+

383+

384+isUnique :: N.Name -> OneOrMore.OneOrMore R.Region -> Result i w R.Region

385+isUnique name regions =

386+ case regions of

387+ OneOrMore.One region ->

388+ Result.ok region

389+

390+ OneOrMore.More _ _ ->

391+ let (r1:r2:_) = OneOrMore.toList regions in

392+ Result.throw (E.Duplicate name r1 r2)

393+

394+

395+onlyInDocs :: N.Name -> R.Region -> Result i w a

396+onlyInDocs name region =

397+ Result.throw $ E.OnlyInDocs name region

398+

399+

400+onlyInExports :: N.Name -> A.Located Can.Export -> Result i w a

401+onlyInExports name (A.At region _) =

402+ Result.throw $ E.OnlyInExports name region

403+

404+

405+

406+-- CHECK EXPORTS

407+

408+

409+data Info =

410+ Info

411+ { _iComments :: Map.Map N.Name Comment

412+ , _iValues :: Types

413+ , _iUnions :: Map.Map N.Name Can.Union

414+ , _iAliases :: Map.Map N.Name Can.Alias

415+ , _iBinops :: Map.Map N.Name Can.Binop

416+ , _iEffects :: Can.Effects

417+ }

418+

419+

420+addExport :: Info -> Module -> (N.Name, A.Located Can.Export) -> Result i w Module

421+addExport info (Module n c us as_ vs bs) (name, A.At region export) =

422+ case export of

423+ Can.ExportValue ->

424+ do tipe <- getType region name info

425+ comment <- getComment region name info

426+

427+ let newValues = Map.insert name (Value comment tipe) vs

428+ Result.ok $ Module n c us as_ newValues bs

429+

430+ Can.ExportBinop ->

431+ do let (Can.Binop_ assoc prec realName) = _iBinops info ! name

432+ tipe <- getType region realName info

433+ comment <- getComment region realName info

434+

435+ let newBinops = Map.insert name (Binop comment tipe assoc prec) bs

436+ Result.ok $ Module n c us as_ vs newBinops

437+

438+ Can.ExportAlias ->

439+ do let (Can.Alias tvars tipe _) = _iAliases info ! name

440+ comment <- getComment region name info

441+

442+ let newAliases = Map.insert name (Alias comment tvars (Extract.fromType tipe)) as_

443+ Result.ok $ Module n c us newAliases vs bs

444+

445+ Can.ExportUnionOpen ->

446+ do let (Can.Union tvars ctors) = _iUnions info ! name

447+ comment <- getComment region name info

448+

449+ let newUnions = Map.insert name (Union comment tvars (map dector ctors)) us

450+ Result.ok $ Module n c newUnions as_ vs bs

451+

452+ Can.ExportUnionClosed ->

453+ do let (Can.Union tvars _) = _iUnions info ! name

454+ comment <- getComment region name info

455+

456+ let newUnions = Map.insert name (Union comment tvars []) us

457+ Result.ok $ Module n c newUnions as_ vs bs

458+

459+ Can.ExportPort ->

460+ error "TODO"

461+

462+

463+getComment :: R.Region -> N.Name -> Info -> Result i w Comment

464+getComment region name info =

465+ case Map.lookup name (_iComments info) of

466+ Nothing ->

467+ Result.throw (E.NoComment name region)

468+

469+ Just comment ->

470+ Result.ok comment

471+

472+

473+getType :: R.Region -> N.Name -> Info -> Result i w Type.Type

474+getType exportRegion name info =

475+ case _iValues info ! name of

476+ A.At defRegion Nothing ->

477+ Result.throw (E.NoAnnotation name exportRegion defRegion)

478+

479+ A.At _ (Just tipe) ->

480+ Result.ok (Extract.fromType tipe)

481+

482+

483+dector :: (N.Name, [Can.Type]) -> (N.Name, [Type.Type])

484+dector (name, args) =

485+ ( name, map Extract.fromType args )

486+

487+

488+

489+-- GATHER TYPES

490+

491+

492+type Types =

493+ Map.Map N.Name (A.Located (Maybe Can.Type))

494+

495+

496+gatherTypes :: Can.Decls -> Types -> Types

497+gatherTypes decls types =

498+ case decls of

499+ Can.Declare def subDecls ->

500+ gatherTypes subDecls (addDef types def)

501+

502+ Can.DeclareRec defs subDecls ->

503+ gatherTypes subDecls (List.foldl' addDef types defs)

504+

505+ Can.SaveTheEnvironment ->

506+ types

507+

508+

509+addDef :: Types -> Can.Def -> Types

510+addDef types def =

511+ case def of

512+ Can.Def (A.At region name) _ _ ->

513+ Map.insert name (A.At region Nothing) types

514+

515+ Can.TypedDef (A.At region name) _ typedArgs _ resultType ->

516+ let

517+ tipe =

518+ foldr Can.TLambda resultType (map snd typedArgs)

519+ in

520+ Map.insert name (A.At region (Just tipe)) types

src/Parse/Module.hs+4−5

@@ -157,17 +157,16 @@ chompSubscription =

157-- DOC COMMENTS

158

159

160−maybeDocComment :: Parser (A.Located (Maybe B.ByteString))

160+maybeDocComment :: Parser (Maybe (A.Located B.ByteString))

161maybeDocComment =

162− do oldEnd <- P.getPosition

163− freshLine

162+ do freshLine

164 newStart <- P.getPosition

163 newStart <- P.getPosition

165 oneOf

164 oneOf

166 [ do doc <- W.docComment

165 [ do doc <- W.docComment

167 end <- P.getPosition

166 end <- P.getPosition

168 freshLine

167 freshLine

169− return (A.at newStart end (Just doc))

168+ return (Just (A.at newStart end doc))

170− , return (A.at oldEnd newStart Nothing)

169+ , return Nothing

171 ]

170 ]

172

171

173

172