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

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

on e84d52b help sign in

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

841 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

25import Control.Arrow ((***), (+++))

27import Language.PureScript.Types

28import Language.PureScript.Names

29import Language.PureScript.Kinds

30import Language.PureScript.TypeClassDictionaries

31import Language.PureScript.CodeGen.JS.AST

32import Language.PureScript.Environment

33import Language.PureScript.Traversals

35-- |

36-- A precedence level for an infix operator

37--

38type Precedence = Integer

40-- |

41-- Associativity for infix operators

42--

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

45instance Show Associativity where

46 show Infixl = "infixl"

47 show Infixr = "infixr"

48 show Infix = "infix"

50-- |

51-- Source position information

52--

53data SourcePos = SourcePos

54 { -- |

55 -- Source name

56 --

57 sourceName :: String

58 -- |

59 -- Line number

60 --

61 , sourcePosLine :: Int

62 -- |

63 -- Column number

64 --

65 , sourcePosColumn :: Int

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

68instance Show SourcePos where

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

71-- |

72-- Fixity data for infix operators

73--

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

76-- |

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

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

79--

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

82-- |

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

84--

85data DeclarationRef

86 -- |

87 -- A type constructor with data constructors

88 --

89 = TypeRef ProperName (Maybe [ProperName])

90 -- |

91 -- A value

92 --

93 | ValueRef Ident

94 -- |

95 -- A type class

96 --

97 | TypeClassRef ProperName

98 -- |

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

100 --

101 | TypeInstanceRef Ident

102 -- |

103 -- A declaration reference with source position information

104 --

105 | PositionedDeclarationRef SourcePos DeclarationRef

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

107

108instance Eq DeclarationRef where

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

110 (ValueRef name) == (ValueRef name') = name == name'

111 (TypeClassRef name) == (TypeClassRef name') = name == name'

112 (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'

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

114 r == (PositionedDeclarationRef _ r') = r == r'

115 _ == _ = False

116

117-- |

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

119--

120data ImportDeclarationType

121 -- |

122 -- Unqualified import

123 --

124 = Unqualified

125 -- |

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

127 --

128 | Qualifying [DeclarationRef]

129 -- |

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

131 --

132 | Hiding [DeclarationRef]

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

134

135-- |

136-- The data type of declarations

137--

138data Declaration

139 -- |

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

141 --

142 = DataDeclaration DataDeclType ProperName [(String, Maybe Kind)] [(ProperName, [Type])]

143 -- |

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

145 --

146 | DataBindingGroupDeclaration [Declaration]

147 -- |

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

149 --

150 | TypeSynonymDeclaration ProperName [(String, Maybe Kind)] Type

151 -- |

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

153 --

154 | TypeDeclaration Ident Type

155 -- |

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

157 --

158 | ValueDeclaration Ident NameKind [Binder] (Either [(Guard, Expr)] Expr)

159 -- |

160 -- A minimal mutually recursive set of value declarations

161 --

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

163 -- |

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

165 --

166 | ExternDeclaration ForeignImportType Ident (Maybe JS) Type

167 -- |

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

169 --

170 | ExternDataDeclaration ProperName Kind

171 -- |

172 -- A type class instance foreign import

173 --

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

175 -- |

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

177 --

178 | FixityDeclaration Fixity String

179 -- |

180 -- A module import (module name, qualified/unqualified/hiding, 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, Maybe Kind)] [(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 -- The result expression or a collect of guarded expressions

384 --

385 , caseAlternativeResult :: Either [(Guard, Expr)] Expr

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

387

388-- |

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

390--

391canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident

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

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

394

395-- |

396-- A statement in a do-notation block

397--

398data DoNotationElement

399 -- |

400 -- A monadic value without a binder

401 --

402 = DoNotationValue Expr

403 -- |

404 -- A monadic value with a binder

405 --

406 | DoNotationBind Binder Expr

407 -- |

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

409 --

410 | DoNotationLet [Declaration]

411 -- |

412 -- A do notation element with source position information

413 --

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

415

416-- |

417-- Data type for binders

418--

419data Binder

420 -- |

421 -- Wildcard binder

422 --

423 = NullBinder

424 -- |

425 -- A binder which matches a boolean literal

426 --

427 | BooleanBinder Bool

428 -- |

429 -- A binder which matches a string literal

430 --

431 | StringBinder String

432 -- |

433 -- A binder which matches a numeric literal

434 --

435 | NumberBinder (Either Integer Double)

436 -- |

437 -- A binder which binds an identifier

438 --

439 | VarBinder Ident

440 -- |

441 -- A binder which matches a data constructor

442 --

443 | ConstructorBinder (Qualified ProperName) [Binder]

444 -- |

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

446 --

447 | ObjectBinder [(String, Binder)]

448 -- |

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

450 --

451 | ArrayBinder [Binder]

452 -- |

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

454 --

455 | ConsBinder Binder Binder

456 -- |

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

458 --

459 | NamedBinder Ident Binder

460 -- |

461 -- A binder with source position information

462 --

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

464

465-- |

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

467--

468binderNames :: Binder -> [Ident]

469binderNames = go []

470 where

471 go ns (VarBinder name) = name : ns

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

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

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

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

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

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

478 go ns _ = ns

479

480--

481-- Traversals

482--

483

484everywhereOnValues :: (Declaration -> Declaration) ->

485 (Expr -> Expr) ->

486 (Binder -> Binder) ->

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

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

489 where

490 f' :: Declaration -> Declaration

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

492 f' (ValueDeclaration name nameKind bs val) = f (ValueDeclaration name nameKind (map h' bs) ((map (g' *** g') +++ g') val))

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

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

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

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

497 f' other = f other

498

499 g' :: Expr -> Expr

500 g' (UnaryMinus v) = g (UnaryMinus (g' v))

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

502 g' (Parens v) = g (Parens (g' v))

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

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

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

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

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

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

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

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

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

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

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

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

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

516 g' other = g other

517

518 h' :: Binder -> Binder

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

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

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

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

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

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

525 h' other = h other

526

527 handleCaseAlternative :: CaseAlternative -> CaseAlternative

528 handleCaseAlternative ca =

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

530 , caseAlternativeResult = (map (g' *** g') +++ g') (caseAlternativeResult ca)

531 }

532

533 handleDoNotationElement :: DoNotationElement -> DoNotationElement

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

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

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

537 handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos (handleDoNotationElement e)

538

539

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

541 (Declaration -> m Declaration) ->

542 (Expr -> m Expr) ->

543 (Binder -> m Binder) ->

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

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

546 where

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

548 f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h' <=< h) bs <*> eitherM (mapM (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val

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

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

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

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

553 f' other = f other

554

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

571 g' other = g other

572

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

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

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

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

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

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

579 h' other = h other

580

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

582 <*> eitherM (mapM (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val

583

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

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

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

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

588

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

590 (Declaration -> m Declaration) ->

591 (Expr -> m Expr) ->

592 (Binder -> m Binder) ->

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

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

595 where

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

597 f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> mapM h' bs <*> eitherM (mapM (pairM g' g')) g' val) >>= f

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

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

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

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

602 f' other = f other

603

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

620 g' other = g other

621

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

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

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

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

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

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

628 h' other = h other

629

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

631 <*> eitherM (mapM (pairM g' g')) g' val

632

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

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

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

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

637

638everythingOnValues :: (r -> r -> r) ->

639 (Declaration -> r) ->

640 (Expr -> r) ->

641 (Binder -> r) ->

642 (CaseAlternative -> r) ->

643 (DoNotationElement -> r) ->

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

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

646 where

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

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

649 f' d@(ValueDeclaration _ _ bs (Left gs)) = foldl (<>) (f d) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)

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

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

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

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

654 f' d = f d

655

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

672 g' v = g v

673

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

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

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

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

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

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

680 h' b = h b

681

682 i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val

683 i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)

684

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

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

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

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

689

690everythingWithContextOnValues ::

691 s ->

692 r ->

693 (r -> r -> r) ->

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

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

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

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

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

699 ( Declaration -> r

700 , Expr -> r

701 , Binder -> r

702 , CaseAlternative -> r

703 , DoNotationElement -> r)

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

705 where

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

707

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

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

710 f' s (ValueDeclaration _ _ bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)

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

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

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

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

715 f' _ _ = r0

716

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

718

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

735 g' _ _ = r0

736

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

738

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

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

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

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

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

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

745 h' _ _ = r0

746

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

748

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

750 i' s (CaseAlternative bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)

751

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

753

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

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

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

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

758

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

760 s ->

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

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

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

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

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

766 ( Declaration -> m Declaration

767 , Expr -> m Expr

768 , Binder -> m Binder

769 , CaseAlternative -> m CaseAlternative

770 , DoNotationElement -> m DoNotationElement)

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

772 where

773 f'' s = uncurry f' <=< f s

774

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

776 f' s (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h'' s) bs <*> eitherM (mapM (pairM (g'' s) (g'' s))) (g'' s) val

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

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

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

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

781 f' _ other = return other

782

783 g'' s = uncurry g' <=< g s

784

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

801 g' _ other = return other

802

803 h'' s = uncurry h' <=< h s

804

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

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

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

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

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

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

811 h' _ other = return other

812

813 i'' s = uncurry i' <=< i s

814

815 i' s (CaseAlternative bs val) = CaseAlternative <$> mapM (h'' s) bs <*> eitherM (mapM (pairM (g'' s) (g'' s))) (g'' s) val

816

817 j'' s = uncurry j' <=< j s

818

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

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

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

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

823

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

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

826 where

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

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

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

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

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

832 forDecls (TypeSynonymDeclaration _ _ ty) = f ty

833 forDecls (TypeDeclaration _ ty) = f ty

834 forDecls _ = mempty

835

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

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

838 forValues (TypedValue _ _ ty) = f ty

839 forValues _ = mempty

840

841