src/Language/PureScript/Declarations.hs · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on 8bf954a help sign in

rowtype-yoga/purescript-native/src/Language/PureScript/Declarations.hs

849 lines 33 kB history raw

1-----------------------------------------------------------------------------

2--

3-- Module : Language.PureScript.Declarations

4-- Copyright : (c) Phil Freeman 2013

5-- License : MIT

6--

7-- Maintainer : Phil Freeman <paf31@cantab.net>

8-- Stability : experimental

9-- Portability :

10--

11-- | Data types for modules and declarations

12--

13-----------------------------------------------------------------------------

15{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}

17module Language.PureScript.Declarations where

19import Data.Monoid (Monoid(..), mconcat)

21import qualified Data.Data as D

23import Control.Applicative

24import Control.Monad

26import Language.PureScript.Types

27import Language.PureScript.Names

28import Language.PureScript.Kinds

29import Language.PureScript.TypeClassDictionaries

30import Language.PureScript.CodeGen.JS.AST

31import Language.PureScript.Environment

32import Language.PureScript.Traversals

34-- |

35-- A precedence level for an infix operator

36--

37type Precedence = Integer

39-- |

40-- Associativity for infix operators

41--

42data Associativity = Infixl | Infixr | Infix deriving (D.Data, D.Typeable)

44instance Show Associativity where

45 show Infixl = "infixl"

46 show Infixr = "infixr"

47 show Infix = "infix"

49-- |

50-- Source position information

51--

52data SourcePos = SourcePos

53 { -- |

54 -- Source name

55 --

56 sourceName :: String

57 -- |

58 -- Line number

59 --

60 , sourcePosLine :: Int

61 -- |

62 -- Column number

63 --

64 , sourcePosColumn :: Int

65 } deriving (D.Data, D.Typeable)

67instance Show SourcePos where

68 show sp = (sourceName sp) ++ " line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp)

70-- |

71-- Fixity data for infix operators

72--

73data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)

75-- |

76-- A module declaration, consisting of a module name, a list of declarations, and a list of the

77-- declarations that are explicitly exported. If the export list is Nothing, everything is exported.

78--

79data Module = Module ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, D.Data, D.Typeable)

81-- |

82-- An item in a list of explicit imports or exports

83--

84data DeclarationRef

85 -- |

86 -- A type constructor with data constructors

87 --

88 = TypeRef ProperName (Maybe [ProperName])

89 -- |

90 -- A value

91 --

92 | ValueRef Ident

93 -- |

94 -- A type class

95 --

96 | TypeClassRef ProperName

97 -- |

98 -- A type class instance, created during typeclass desugaring (name, class name, instance types)

99 --

100 | TypeInstanceRef Ident

101 -- |

102 -- A declaration reference with source position information

103 --

104 | PositionedDeclarationRef SourcePos DeclarationRef

105 deriving (Show, D.Data, D.Typeable)

106

107instance Eq DeclarationRef where

108 (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors'

109 (ValueRef name) == (ValueRef name') = name == name'

110 (TypeClassRef name) == (TypeClassRef name') = name == name'

111 (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'

112 (PositionedDeclarationRef _ r) == r' = r == r'

113 r == (PositionedDeclarationRef _ r') = r == r'

114 _ == _ = False

115

116-- |

117-- The data type which specifies type of import declaration

118--

119data ImportDeclarationType

120 -- |

121 -- Unqualified import

122 --

123 = Unqualified

124 -- |

125 -- Qualified import with a list of references to import

126 --

127 | Qualifying [DeclarationRef]

128 -- |

129 -- Import with hiding clause with a list of references to hide

130 --

131 | Hiding [DeclarationRef]

132 deriving (Show, D.Data, D.Typeable)

133

134-- |

135-- The data type of declarations

136--

137data Declaration

138 -- |

139 -- A data type declaration (data or newtype, name, arguments, data constructors)

140 --

141 = DataDeclaration DataDeclType ProperName [String] [(ProperName, [Type])]

142 -- |

143 -- A minimal mutually recursive set of data type declarations

144 --

145 | DataBindingGroupDeclaration [Declaration]

146 -- |

147 -- A type synonym declaration (name, arguments, type)

148 --

149 | TypeSynonymDeclaration ProperName [String] Type

150 -- |

151 -- A type declaration for a value (name, ty)

152 --

153 | TypeDeclaration Ident Type

154 -- |

155 -- A value declaration (name, top-level binders, optional guard, value)

156 --

157 | ValueDeclaration Ident NameKind [Binder] (Maybe Guard) Expr

158 -- |

159 -- A minimal mutually recursive set of value declarations

160 --

161 | BindingGroupDeclaration [(Ident, NameKind, Expr)]

162 -- |

163 -- A foreign import declaration (type, name, optional inline Javascript, type)

164 --

165 | ExternDeclaration ForeignImportType Ident (Maybe JS) Type

166 -- |

167 -- A data type foreign import (name, kind)

168 --

169 | ExternDataDeclaration ProperName Kind

170 -- |

171 -- A type class instance foreign import

172 --

173 | ExternInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type]

174 -- |

175 -- A fixity declaration (fixity data, operator name)

176 --

177 | FixityDeclaration Fixity String

178 -- |

179 -- A module import (module name, optional set of identifiers to import,

180 -- optional set of identifiers to hide, optional "qualified as" name)

181 --

182 | ImportDeclaration ModuleName ImportDeclarationType (Maybe ModuleName)

183 -- |

184 -- A type class declaration (name, argument, implies, member declarations)

185 --

186 | TypeClassDeclaration ProperName [String] [(Qualified ProperName, [Type])] [Declaration]

187 -- |

188 -- A type instance declaration (name, dependencies, class name, instance types, member

189 -- declarations)

190 --

191 | TypeInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type] [Declaration]

192 -- |

193 -- A declaration with source position information

194 --

195 | PositionedDeclaration SourcePos Declaration

196 deriving (Show, D.Data, D.Typeable)

197

198-- |

199-- Test if a declaration is a value declaration

200--

201isValueDecl :: Declaration -> Bool

202isValueDecl ValueDeclaration{} = True

203isValueDecl (PositionedDeclaration _ d) = isValueDecl d

204isValueDecl _ = False

205

206-- |

207-- Test if a declaration is a data type or type synonym declaration

208--

209isDataDecl :: Declaration -> Bool

210isDataDecl DataDeclaration{} = True

211isDataDecl TypeSynonymDeclaration{} = True

212isDataDecl (PositionedDeclaration _ d) = isDataDecl d

213isDataDecl _ = False

214

215-- |

216-- Test if a declaration is a module import

217--

218isImportDecl :: Declaration -> Bool

219isImportDecl ImportDeclaration{} = True

220isImportDecl (PositionedDeclaration _ d) = isImportDecl d

221isImportDecl _ = False

222

223-- |

224-- Test if a declaration is a data type foreign import

225--

226isExternDataDecl :: Declaration -> Bool

227isExternDataDecl ExternDataDeclaration{} = True

228isExternDataDecl (PositionedDeclaration _ d) = isExternDataDecl d

229isExternDataDecl _ = False

230

231-- |

232-- Test if a declaration is a type class instance foreign import

233--

234isExternInstanceDecl :: Declaration -> Bool

235isExternInstanceDecl ExternInstanceDeclaration{} = True

236isExternInstanceDecl (PositionedDeclaration _ d) = isExternInstanceDecl d

237isExternInstanceDecl _ = False

238

239-- |

240-- Test if a declaration is a fixity declaration

241--

242isFixityDecl :: Declaration -> Bool

243isFixityDecl FixityDeclaration{} = True

244isFixityDecl (PositionedDeclaration _ d) = isFixityDecl d

245isFixityDecl _ = False

246

247-- |

248-- Test if a declaration is a foreign import

249--

250isExternDecl :: Declaration -> Bool

251isExternDecl ExternDeclaration{} = True

252isExternDecl (PositionedDeclaration _ d) = isExternDecl d

253isExternDecl _ = False

254

255-- |

256-- Test if a declaration is a type class or instance declaration

257--

258isTypeClassDeclaration :: Declaration -> Bool

259isTypeClassDeclaration TypeClassDeclaration{} = True

260isTypeClassDeclaration TypeInstanceDeclaration{} = True

261isTypeClassDeclaration (PositionedDeclaration _ d) = isTypeClassDeclaration d

262isTypeClassDeclaration _ = False

263

264-- |

265-- A guard is just a boolean-valued expression that appears alongside a set of binders

266--

267type Guard = Expr

268

269-- |

270-- Data type for expressions and terms

271--

272data Expr

273 -- |

274 -- A numeric literal

275 --

276 = NumericLiteral (Either Integer Double)

277 -- |

278 -- A string literal

279 --

280 | StringLiteral String

281 -- |

282 -- A boolean literal

283 --

284 | BooleanLiteral Bool

285 -- |

286 -- A prefix -, will be desugared

287 --

288 | UnaryMinus Expr

289 -- |

290 -- Binary operator application. During the rebracketing phase of desugaring, this data constructor

291 -- will be removed.

292 --

293 | BinaryNoParens (Qualified Ident) Expr Expr

294 -- |

295 -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor

296 -- will be removed.

297 --

298 | Parens Expr

299 -- |

300 -- An array literal

301 --

302 | ArrayLiteral [Expr]

303 -- |

304 -- An object literal

305 --

306 | ObjectLiteral [(String, Expr)]

307 -- |

308 -- An record property accessor expression

309 --

310 | Accessor String Expr

311 -- |

312 -- Partial record update

313 --

314 | ObjectUpdate Expr [(String, Expr)]

315 -- |

316 -- Function introduction

317 --

318 | Abs (Either Ident Binder) Expr

319 -- |

320 -- Function application

321 --

322 | App Expr Expr

323 -- |

324 -- Variable

325 --

326 | Var (Qualified Ident)

327 -- |

328 -- Conditional (if-then-else expression)

329 --

330 | IfThenElse Expr Expr Expr

331 -- |

332 -- A data constructor

333 --

334 | Constructor (Qualified ProperName)

335 -- |

336 -- A case expression. During the case expansion phase of desugaring, top-level binders will get

337 -- desugared into case expressions, hence the need for guards and multiple binders per branch here.

338 --

339 | Case [Expr] [CaseAlternative]

340 -- |

341 -- A value with a type annotation

342 --

343 | TypedValue Bool Expr Type

344 -- |

345 -- A let binding

346 --

347 | Let [Declaration] Expr

348 -- |

349 -- A do-notation block

350 --

351 | Do [DoNotationElement]

352 -- |

353 -- An application of a typeclass dictionary constructor. The value should be

354 -- an ObjectLiteral.

355 --

356 | TypeClassDictionaryConstructorApp (Qualified ProperName) Expr

357 -- |

358 -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these

359 -- placeholders will be replaced with actual expressions representing type classes dictionaries which

360 -- can be evaluated at runtime. The constructor arguments represent (in order): whether or not to look

361 -- at superclass implementations when searching for a dictionary, the type class name and

362 -- instance type, and the type class dictionaries in scope.

363 --

364 | TypeClassDictionary Bool (Qualified ProperName, [Type]) [TypeClassDictionaryInScope]

365 -- |

366 -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking

367 --

368 | SuperClassDictionary (Qualified ProperName) [Type]

369 -- |

370 -- A value with source position information

371 --

372 | PositionedValue SourcePos Expr deriving (Show, D.Data, D.Typeable)

373

374-- |

375-- An alternative in a case statement

376--

377data CaseAlternative = CaseAlternative

378 { -- |

379 -- A collection of binders with which to match the inputs

380 --

381 caseAlternativeBinders :: [Binder]

382 -- |

383 -- An optional guard

384 --

385 , caseAlternativeGuard :: Maybe Guard

386 -- |

387 -- The result expression

388 --

389 , caseAlternativeResult :: Expr

390 } deriving (Show, D.Data, D.Typeable)

391

392-- |

393-- Find the original dictionary which a type class dictionary in scope refers to

394--

395canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident

396canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm

397canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm

398

399-- |

400-- A statement in a do-notation block

401--

402data DoNotationElement

403 -- |

404 -- A monadic value without a binder

405 --

406 = DoNotationValue Expr

407 -- |

408 -- A monadic value with a binder

409 --

410 | DoNotationBind Binder Expr

411 -- |

412 -- A let statement, i.e. a pure value with a binder

413 --

414 | DoNotationLet [Declaration]

415 -- |

416 -- A do notation element with source position information

417 --

418 | PositionedDoNotationElement SourcePos DoNotationElement deriving (Show, D.Data, D.Typeable)

419

420-- |

421-- Data type for binders

422--

423data Binder

424 -- |

425 -- Wildcard binder

426 --

427 = NullBinder

428 -- |

429 -- A binder which matches a boolean literal

430 --

431 | BooleanBinder Bool

432 -- |

433 -- A binder which matches a string literal

434 --

435 | StringBinder String

436 -- |

437 -- A binder which matches a numeric literal

438 --

439 | NumberBinder (Either Integer Double)

440 -- |

441 -- A binder which binds an identifier

442 --

443 | VarBinder Ident

444 -- |

445 -- A binder which matches a data constructor

446 --

447 | ConstructorBinder (Qualified ProperName) [Binder]

448 -- |

449 -- A binder which matches a record and binds its properties

450 --

451 | ObjectBinder [(String, Binder)]

452 -- |

453 -- A binder which matches an array and binds its elements

454 --

455 | ArrayBinder [Binder]

456 -- |

457 -- A binder which matches an array and binds its head and tail

458 --

459 | ConsBinder Binder Binder

460 -- |

461 -- A binder which binds its input to an identifier

462 --

463 | NamedBinder Ident Binder

464 -- |

465 -- A binder with source position information

466 --

467 | PositionedBinder SourcePos Binder deriving (Show, D.Data, D.Typeable)

468

469-- |

470-- Collect all names introduced in binders in an expression

471--

472binderNames :: Binder -> [Ident]

473binderNames = go []

474 where

475 go ns (VarBinder name) = name : ns

476 go ns (ConstructorBinder _ bs) = foldl go ns bs

477 go ns (ObjectBinder bs) = foldl go ns (map snd bs)

478 go ns (ArrayBinder bs) = foldl go ns bs

479 go ns (ConsBinder b1 b2) = go (go ns b1) b2

480 go ns (NamedBinder name b) = go (name : ns) b

481 go ns (PositionedBinder _ b) = go ns b

482 go ns _ = ns

483

484--

485-- Traversals

486--

487

488everywhereOnValues :: (Declaration -> Declaration) ->

489 (Expr -> Expr) ->

490 (Binder -> Binder) ->

491 (Declaration -> Declaration, Expr -> Expr, Binder -> Binder)

492everywhereOnValues f g h = (f', g', h')

493 where

494 f' :: Declaration -> Declaration

495 f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (map f' ds))

496 f' (ValueDeclaration name nameKind bs grd val) = f (ValueDeclaration name nameKind (map h' bs) (fmap g' grd) (g' val))

497 f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (map (\(name, nameKind, val) -> (name, nameKind, g' val)) ds))

498 f' (TypeClassDeclaration name args implies ds) = f (TypeClassDeclaration name args implies (map f' ds))

499 f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (map f' ds))

500 f' (PositionedDeclaration pos d) = f (PositionedDeclaration pos (f' d))

501 f' other = f other

502

503 g' :: Expr -> Expr

504 g' (UnaryMinus v) = g (UnaryMinus (g' v))

505 g' (BinaryNoParens op v1 v2) = g (BinaryNoParens op (g' v1) (g' v2))

506 g' (Parens v) = g (Parens (g' v))

507 g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs))

508 g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs))

509 g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))

510 g' (Accessor prop v) = g (Accessor prop (g' v))

511 g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))

512 g' (Abs name v) = g (Abs name (g' v))

513 g' (App v1 v2) = g (App (g' v1) (g' v2))

514 g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3))

515 g' (Case vs alts) = g (Case (map g' vs) (map handleCaseAlternative alts))

516 g' (TypedValue check v ty) = g (TypedValue check (g' v) ty)

517 g' (Let ds v) = g (Let (map f' ds) (g' v))

518 g' (Do es) = g (Do (map handleDoNotationElement es))

519 g' (PositionedValue pos v) = g (PositionedValue pos (g' v))

520 g' other = g other

521

522 h' :: Binder -> Binder

523 h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (map h' bs))

524 h' (ObjectBinder bs) = h (ObjectBinder (map (fmap h') bs))

525 h' (ArrayBinder bs) = h (ArrayBinder (map h' bs))

526 h' (ConsBinder b1 b2) = h (ConsBinder (h' b1) (h' b2))

527 h' (NamedBinder name b) = h (NamedBinder name (h' b))

528 h' (PositionedBinder pos b) = h (PositionedBinder pos (h' b))

529 h' other = h other

530

531 handleCaseAlternative :: CaseAlternative -> CaseAlternative

532 handleCaseAlternative ca =

533 ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)

534 , caseAlternativeGuard = fmap g' (caseAlternativeGuard ca)

535 , caseAlternativeResult = g' (caseAlternativeResult ca)

536 }

537

538 handleDoNotationElement :: DoNotationElement -> DoNotationElement

539 handleDoNotationElement (DoNotationValue v) = DoNotationValue (g' v)

540 handleDoNotationElement (DoNotationBind b v) = DoNotationBind (h' b) (g' v)

541 handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)

542 handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos (handleDoNotationElement e)

543

544

545everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>

546 (Declaration -> m Declaration) ->

547 (Expr -> m Expr) ->

548 (Binder -> m Binder) ->

549 (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)

550everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

551 where

552 f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f' <=< f) ds

553 f' (ValueDeclaration name nameKind bs grd val) = ValueDeclaration name nameKind <$> mapM (h' <=< h) bs <*> maybeM (g' <=< g) grd <*> (g val >>= g')

554 f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds

555 f' (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f' <=< f) ds

556 f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f' <=< f) ds

557 f' (PositionedDeclaration pos d) = PositionedDeclaration pos <$> (f d >>= f')

558 f' other = f other

559

560 g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g')

561 g' (BinaryNoParens op v1 v2) = BinaryNoParens op <$> (g v1 >>= g') <*> (g v2 >>= g')

562 g' (Parens v) = Parens <$> (g v >>= g')

563 g' (ArrayLiteral vs) = ArrayLiteral <$> mapM (g' <=< g) vs

564 g' (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g' <=< g)) vs

565 g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')

566 g' (Accessor prop v) = Accessor prop <$> (g v >>= g')

567 g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> mapM (sndM (g' <=< g)) vs

568 g' (Abs name v) = Abs name <$> (g v >>= g')

569 g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g')

570 g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g')

571 g' (Case vs alts) = Case <$> mapM (g' <=< g) vs <*> mapM handleCaseAlternative alts

572 g' (TypedValue check v ty) = TypedValue check <$> (g v >>= g') <*> pure ty

573 g' (Let ds v) = Let <$> mapM (f' <=< f) ds <*> (g v >>= g')

574 g' (Do es) = Do <$> mapM handleDoNotationElement es

575 g' (PositionedValue pos v) = PositionedValue pos <$> (g v >>= g')

576 g' other = g other

577

578 h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM (h' <=< h) bs

579 h' (ObjectBinder bs) = ObjectBinder <$> mapM (sndM (h' <=< h)) bs

580 h' (ArrayBinder bs) = ArrayBinder <$> mapM (h' <=< h) bs

581 h' (ConsBinder b1 b2) = ConsBinder <$> (h b1 >>= h') <*> (h b2 >>= h')

582 h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')

583 h' (PositionedBinder pos b) = PositionedBinder pos <$> (h b >>= h')

584 h' other = h other

585

586 handleCaseAlternative (CaseAlternative bs grd val) = CaseAlternative <$> mapM (h' <=< h) bs

587 <*> maybeM (g' <=< g) grd

588 <*> (g' <=< g) val

589

590 handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v

591 handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> (h' <=< h) b <*> (g' <=< g) v

592 handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM (f' <=< f) ds

593 handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos <$> handleDoNotationElement e

594

595everywhereOnValuesM :: (Functor m, Applicative m, Monad m) =>

596 (Declaration -> m Declaration) ->

597 (Expr -> m Expr) ->

598 (Binder -> m Binder) ->

599 (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)

600everywhereOnValuesM f g h = (f' <=< f, g' <=< g, h' <=< h)

601 where

602 f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> mapM f' ds) >>= f

603 f' (ValueDeclaration name nameKind bs grd val) = (ValueDeclaration name nameKind <$> mapM h' bs <*> maybeM g' grd <*> g' val) >>= f

604 f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f

605 f' (TypeClassDeclaration name args implies ds) = (TypeClassDeclaration name args implies <$> mapM f' ds) >>= f

606 f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> mapM f' ds) >>= f

607 f' (PositionedDeclaration pos d) = (PositionedDeclaration pos <$> f' d) >>= f

608 f' other = f other

609

610 g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g

611 g' (BinaryNoParens op v1 v2) = (BinaryNoParens op <$> (g' v1) <*> (g' v2)) >>= g

612 g' (Parens v) = (Parens <$> g' v) >>= g

613 g' (ArrayLiteral vs) = (ArrayLiteral <$> mapM g' vs) >>= g

614 g' (ObjectLiteral vs) = (ObjectLiteral <$> mapM (sndM g') vs) >>= g

615 g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g

616 g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g

617 g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> mapM (sndM g') vs) >>= g

618 g' (Abs name v) = (Abs name <$> g' v) >>= g

619 g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g

620 g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g

621 g' (Case vs alts) = (Case <$> mapM g' vs <*> mapM handleCaseAlternative alts) >>= g

622 g' (TypedValue check v ty) = (TypedValue check <$> g' v <*> pure ty) >>= g

623 g' (Let ds v) = (Let <$> mapM f' ds <*> g' v) >>= g

624 g' (Do es) = (Do <$> mapM handleDoNotationElement es) >>= g

625 g' (PositionedValue pos v) = (PositionedValue pos <$> g' v) >>= g

626 g' other = g other

627

628 h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> mapM h' bs) >>= h

629 h' (ObjectBinder bs) = (ObjectBinder <$> mapM (sndM h') bs) >>= h

630 h' (ArrayBinder bs) = (ArrayBinder <$> mapM h' bs) >>= h

631 h' (ConsBinder b1 b2) = (ConsBinder <$> h' b1 <*> h' b2) >>= h

632 h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h

633 h' (PositionedBinder pos b) = (PositionedBinder pos <$> h' b) >>= h

634 h' other = h other

635

636 handleCaseAlternative (CaseAlternative bs grd val) = CaseAlternative <$> mapM h' bs

637 <*> maybeM g' grd

638 <*> g' val

639

640 handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v

641 handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> h' b <*> g' v

642 handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM f' ds

643 handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos <$> handleDoNotationElement e

644

645everythingOnValues :: (r -> r -> r) ->

646 (Declaration -> r) ->

647 (Expr -> r) ->

648 (Binder -> r) ->

649 (CaseAlternative -> r) ->

650 (DoNotationElement -> r) ->

651 (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)

652everythingOnValues (<>) f g h i j = (f', g', h', i', j')

653 where

654 f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds)

655 f' d@(ValueDeclaration _ _ bs Nothing val) = foldl (<>) (f d) (map h' bs) <> g' val

656 f' d@(ValueDeclaration _ _ bs (Just grd) val) = foldl (<>) (f d) (map h' bs) <> g' grd <> g' val

657 f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds)

658 f' d@(TypeClassDeclaration _ _ _ ds) = foldl (<>) (f d) (map f' ds)

659 f' d@(TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) (f d) (map f' ds)

660 f' d@(PositionedDeclaration _ d1) = f d <> f' d1

661 f' d = f d

662

663 g' v@(UnaryMinus v1) = g v <> g' v1

664 g' v@(BinaryNoParens _ v1 v2) = g v <> g' v1 <> g' v2

665 g' v@(Parens v1) = g v <> g' v1

666 g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)

667 g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)

668 g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1

669 g' v@(Accessor _ v1) = g v <> g' v1

670 g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)

671 g' v@(Abs _ v1) = g v <> g' v1

672 g' v@(App v1 v2) = g v <> g' v1 <> g' v2

673 g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3

674 g' v@(Case vs alts) = foldl (<>) (foldl (<>) (g v) (map g' vs)) (map i' alts)

675 g' v@(TypedValue _ v1 _) = g v <> g' v1

676 g' v@(Let ds v1) = (foldl (<>) (g v) (map f' ds)) <> g' v1

677 g' v@(Do es) = foldl (<>) (g v) (map j' es)

678 g' v@(PositionedValue _ v1) = g v <> g' v1

679 g' v = g v

680

681 h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs)

682 h' b@(ObjectBinder bs) = foldl (<>) (h b) (map (h' . snd) bs)

683 h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs)

684 h' b@(ConsBinder b1 b2) = h b <> h' b1 <> h' b2

685 h' b@(NamedBinder _ b1) = h b <> h' b1

686 h' b@(PositionedBinder _ b1) = h b <> h' b1

687 h' b = h b

688

689 i' ca = case caseAlternativeGuard ca of

690 Nothing -> foldl (<>) (i ca) (map h' (caseAlternativeBinders ca)) <> g' (caseAlternativeResult ca)

691 Just grd -> foldl (<>) (i ca) (map h' (caseAlternativeBinders ca)) <> g' grd <> g' (caseAlternativeResult ca)

692

693 j' e@(DoNotationValue v) = j e <> g' v

694 j' e@(DoNotationBind b v) = j e <> h' b <> g' v

695 j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds)

696 j' e@(PositionedDoNotationElement _ e1) = j e <> j' e1

697

698everythingWithContextOnValues ::

699 s ->

700 r ->

701 (r -> r -> r) ->

702 (s -> Declaration -> (s, r)) ->

703 (s -> Expr -> (s, r)) ->

704 (s -> Binder -> (s, r)) ->

705 (s -> CaseAlternative -> (s, r)) ->

706 (s -> DoNotationElement -> (s, r)) ->

707 ( Declaration -> r

708 , Expr -> r

709 , Binder -> r

710 , CaseAlternative -> r

711 , DoNotationElement -> r)

712everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)

713 where

714 f'' s d = let (s', r) = f s d in r <> f' s' d

715

716 f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (map (f'' s) ds)

717 f' s (ValueDeclaration _ _ bs Nothing val) = foldl (<>) r0 (map (h'' s) bs) <> (g'' s) val

718 f' s (ValueDeclaration _ _ bs (Just grd) val) = foldl (<>) r0 (map (h'' s) bs) <> (g'' s) grd <> (g'' s) val

719 f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (map (\(_, _, val) -> (g'' s) val) ds)

720 f' s (TypeClassDeclaration _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)

721 f' s (TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)

722 f' s (PositionedDeclaration _ d1) = (f'' s) d1

723 f' _ _ = r0

724

725 g'' s v = let (s', r) = g s v in r <> g' s' v

726

727 g' s (UnaryMinus v1) = (g'' s) v1

728 g' s (BinaryNoParens _ v1 v2) = (g'' s) v1 <> (g'' s) v2

729 g' s (Parens v1) = (g'' s) v1

730 g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs)

731 g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs)

732 g' s (TypeClassDictionaryConstructorApp _ v1) = (g'' s) v1

733 g' s (Accessor _ v1) = (g'' s) v1

734 g' s (ObjectUpdate obj vs) = foldl (<>) ((g'' s) obj) (map (g'' s . snd) vs)

735 g' s (Abs _ v1) = (g'' s) v1

736 g' s (App v1 v2) = (g'' s) v1 <> (g'' s) v2

737 g' s (IfThenElse v1 v2 v3) = (g'' s) v1 <> (g'' s) v2 <> (g'' s) v3

738 g' s (Case vs alts) = foldl (<>) (foldl (<>) r0 (map (g'' s) vs)) (map (i'' s) alts)

739 g' s (TypedValue _ v1 _) = (g'' s) v1

740 g' s (Let ds v1) = (foldl (<>) r0 (map (f'' s) ds)) <> (g'' s) v1

741 g' s (Do es) = foldl (<>) r0 (map (j'' s) es)

742 g' s (PositionedValue _ v1) = (g'' s) v1

743 g' _ _ = r0

744

745 h'' s b = let (s', r) = h s b in r <> h' s' b

746

747 h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (h'' s) bs)

748 h' s (ObjectBinder bs) = foldl (<>) r0 (map (h'' s . snd) bs)

749 h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs)

750 h' s (ConsBinder b1 b2) = (h'' s) b1 <> (h'' s) b2

751 h' s (NamedBinder _ b1) = (h'' s) b1

752 h' s (PositionedBinder _ b1) = (h'' s) b1

753 h' _ _ = r0

754

755 i'' s ca = let (s', r) = i s ca in r <> i' s' ca

756

757 i' s (CaseAlternative bs Nothing val) = foldl (<>) r0 (map (h'' s) bs) <> (g'' s) val

758 i' s (CaseAlternative bs (Just grd) val) = foldl (<>) r0 (map (h'' s) bs) <> (g'' s) grd <> (g'' s) val

759

760 j'' s e = let (s', r) = j s e in r <> j' s' e

761

762 j' s (DoNotationValue v) = (g'' s) v

763 j' s (DoNotationBind b v) = (h'' s) b <> (g'' s) v

764 j' s (DoNotationLet ds) = foldl (<>) r0 (map (f'' s) ds)

765 j' s (PositionedDoNotationElement _ e1) = (j'' s) e1

766

767everywhereWithContextOnValuesM :: (Functor m, Applicative m, Monad m) =>

768 s ->

769 (s -> Declaration -> m (s, Declaration)) ->

770 (s -> Expr -> m (s, Expr)) ->

771 (s -> Binder -> m (s, Binder)) ->

772 (s -> CaseAlternative -> m (s, CaseAlternative)) ->

773 (s -> DoNotationElement -> m (s, DoNotationElement)) ->

774 ( Declaration -> m Declaration

775 , Expr -> m Expr

776 , Binder -> m Binder

777 , CaseAlternative -> m CaseAlternative

778 , DoNotationElement -> m DoNotationElement)

779everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)

780 where

781 f'' s = uncurry f' <=< f s

782

783 f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f'' s) ds

784 f' s (ValueDeclaration name nameKind bs grd val) = ValueDeclaration name nameKind <$> mapM (h'' s) bs <*> maybeM (g'' s) grd <*> g'' s val

785 f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (thirdM (g'' s)) ds

786 f' s (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f'' s) ds

787 f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f'' s) ds

788 f' s (PositionedDeclaration pos d1) = PositionedDeclaration pos <$> f'' s d1

789 f' _ other = return other

790

791 g'' s = uncurry g' <=< g s

792

793 g' s (UnaryMinus v) = UnaryMinus <$> g'' s v

794 g' s (BinaryNoParens op v1 v2) = BinaryNoParens op <$> g'' s v1 <*> g'' s v2

795 g' s (Parens v) = Parens <$> g'' s v

796 g' s (ArrayLiteral vs) = ArrayLiteral <$> mapM (g'' s) vs

797 g' s (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g'' s)) vs

798 g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g'' s) v

799 g' s (Accessor prop v) = Accessor prop <$> g'' s v

800 g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> mapM (sndM (g'' s)) vs

801 g' s (Abs name v) = Abs name <$> g'' s v

802 g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2

803 g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3

804 g' s (Case vs alts) = Case <$> mapM (g'' s) vs <*> mapM (i'' s) alts

805 g' s (TypedValue check v ty) = TypedValue check <$> g'' s v <*> pure ty

806 g' s (Let ds v) = Let <$> mapM (f'' s) ds <*> g'' s v

807 g' s (Do es) = Do <$> mapM (j'' s) es

808 g' s (PositionedValue pos v) = PositionedValue pos <$> g'' s v

809 g' _ other = return other

810

811 h'' s = uncurry h' <=< h s

812

813 h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM (h'' s) bs

814 h' s (ObjectBinder bs) = ObjectBinder <$> mapM (sndM (h'' s)) bs

815 h' s (ArrayBinder bs) = ArrayBinder <$> mapM (h'' s) bs

816 h' s (ConsBinder b1 b2) = ConsBinder <$> h'' s b1 <*> h'' s b2

817 h' s (NamedBinder name b) = NamedBinder name <$> h'' s b

818 h' s (PositionedBinder pos b) = PositionedBinder pos <$> h'' s b

819 h' _ other = return other

820

821 i'' s = uncurry i' <=< i s

822

823 i' s (CaseAlternative bs grd val) = CaseAlternative <$> mapM (h'' s) bs <*> maybeM (g'' s) grd <*> g'' s val

824

825 j'' s = uncurry j' <=< j s

826

827 j' s (DoNotationValue v) = DoNotationValue <$> g'' s v

828 j' s (DoNotationBind b v) = DoNotationBind <$> h'' s b <*> g'' s v

829 j' s (DoNotationLet ds) = DoNotationLet <$> mapM (f'' s) ds

830 j' s (PositionedDoNotationElement pos e1) = PositionedDoNotationElement pos <$> j'' s e1

831

832accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)

833accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)

834 where

835 forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)

836 forDecls (ExternDeclaration _ _ _ ty) = f ty

837 forDecls (ExternInstanceDeclaration _ cs _ tys) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)

838 forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . snd) implies)

839 forDecls (TypeInstanceDeclaration _ cs _ tys _) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)

840 forDecls (TypeSynonymDeclaration _ _ ty) = f ty

841 forDecls (TypeDeclaration _ ty) = f ty

842 forDecls _ = mempty

843

844 forValues (TypeClassDictionary _ (_, cs) _) = mconcat (map f cs)

845 forValues (SuperClassDictionary _ tys) = mconcat (map f tys)

846 forValues (TypedValue _ _ ty) = f ty

847 forValues _ = mempty

848

849