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

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

on 067b0b6 help sign in

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

853 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

468 -- |

469 -- A binder with a type annotation

470 --

471 | TypedBinder Type Binder deriving (Show, D.Data, D.Typeable)

472

473-- |

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

475--

476binderNames :: Binder -> [Ident]

477binderNames = go []

478 where

479 go ns (VarBinder name) = name : ns

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

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

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

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

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

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

486 go ns _ = ns

487

488--

489-- Traversals

490--

491

492everywhereOnValues :: (Declaration -> Declaration) ->

493 (Expr -> Expr) ->

494 (Binder -> Binder) ->

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

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

497 where

498 f' :: Declaration -> Declaration

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

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

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

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

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

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

505 f' other = f other

506

507 g' :: Expr -> Expr

508 g' (UnaryMinus v) = g (UnaryMinus (g' v))

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

510 g' (Parens v) = g (Parens (g' v))

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

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

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

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

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

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

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

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

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

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

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

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

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

524 g' other = g other

525

526 h' :: Binder -> Binder

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

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

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

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

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

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

533 h' other = h other

534

535 handleCaseAlternative :: CaseAlternative -> CaseAlternative

536 handleCaseAlternative ca =

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

538 , caseAlternativeGuard = fmap g' (caseAlternativeGuard ca)

539 , caseAlternativeResult = g' (caseAlternativeResult ca)

540 }

541

542 handleDoNotationElement :: DoNotationElement -> DoNotationElement

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

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

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

546 handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos (handleDoNotationElement e)

547

548

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

550 (Declaration -> m Declaration) ->

551 (Expr -> m Expr) ->

552 (Binder -> m Binder) ->

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

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

555 where

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

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

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

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

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

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

562 f' other = f other

563

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

580 g' other = g other

581

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

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

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

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

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

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

588 h' other = h other

589

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

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

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

593

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

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

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

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

598

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

600 (Declaration -> m Declaration) ->

601 (Expr -> m Expr) ->

602 (Binder -> m Binder) ->

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

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

605 where

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

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

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

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

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

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

612 f' other = f other

613

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

630 g' other = g other

631

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

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

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

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

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

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

638 h' other = h other

639

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

641 <*> maybeM g' grd

642 <*> g' val

643

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

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

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

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

648

649everythingOnValues :: (r -> r -> r) ->

650 (Declaration -> r) ->

651 (Expr -> r) ->

652 (Binder -> r) ->

653 (CaseAlternative -> r) ->

654 (DoNotationElement -> r) ->

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

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

657 where

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

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

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

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

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

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

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

665 f' d = f d

666

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

683 g' v = g v

684

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

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

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

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

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

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

691 h' b = h b

692

693 i' ca = case caseAlternativeGuard ca of

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

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

696

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

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

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

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

701

702everythingWithContextOnValues ::

703 s ->

704 r ->

705 (r -> r -> r) ->

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

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

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

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

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

711 ( Declaration -> r

712 , Expr -> r

713 , Binder -> r

714 , CaseAlternative -> r

715 , DoNotationElement -> r)

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

717 where

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

719

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

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

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

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

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

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

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

727 f' _ _ = r0

728

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

730

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

747 g' _ _ = r0

748

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

750

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

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

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

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

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

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

757 h' _ _ = r0

758

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

760

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

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

763

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

765

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

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

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

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

770

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

772 s ->

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

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

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

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

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

778 ( Declaration -> m Declaration

779 , Expr -> m Expr

780 , Binder -> m Binder

781 , CaseAlternative -> m CaseAlternative

782 , DoNotationElement -> m DoNotationElement)

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

784 where

785 f'' s = uncurry f' <=< f s

786

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

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

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

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

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

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

793 f' _ other = return other

794

795 g'' s = uncurry g' <=< g s

796

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

813 g' _ other = return other

814

815 h'' s = uncurry h' <=< h s

816

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

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

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

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

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

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

823 h' _ other = return other

824

825 i'' s = uncurry i' <=< i s

826

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

828

829 j'' s = uncurry j' <=< j s

830

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

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

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

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

835

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

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

838 where

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

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

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

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

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

844 forDecls (TypeSynonymDeclaration _ _ ty) = f ty

845 forDecls (TypeDeclaration _ ty) = f ty

846 forDecls _ = mempty

847

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

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

850 forValues (TypedValue _ _ ty) = f ty

851 forValues _ = mempty

852

853