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

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

on 11930f0 help sign in

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

848 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 type of a data type declaration

118--

119data DataType

120 -- |

121 -- A standard data constructor

122 --

123 = Data

124 -- |

125 -- A newtype constructor

126 --

127 | Newtype deriving (Eq, Ord, D.Data, D.Typeable)

128

129instance Show DataType where

130 show Data = "data"

131 show Newtype = "newtype"

132

133-- |

134-- The data type of declarations

135--

136data Declaration

137 -- |

138 -- A data type declaration (name, arguments, data constructors)

139 --

140 = DataDeclaration DataType ProperName [String] [(ProperName, [Type])]

141 -- |

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

143 --

144 | DataBindingGroupDeclaration [Declaration]

145 -- |

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

147 --

148 | TypeSynonymDeclaration ProperName [String] Type

149 -- |

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

151 --

152 | TypeDeclaration Ident Type

153 -- |

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

155 --

156 | ValueDeclaration Ident NameKind [Binder] (Maybe Guard) Value

157 -- |

158 -- A minimal mutually recursive set of value declarations

159 --

160 | BindingGroupDeclaration [(Ident, NameKind, Value)]

161 -- |

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

163 --

164 | ExternDeclaration ForeignImportType Ident (Maybe JS) Type

165 -- |

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

167 --

168 | ExternDataDeclaration ProperName Kind

169 -- |

170 -- A type class instance foreign import

171 --

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

173 -- |

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

175 --

176 | FixityDeclaration Fixity String

177 -- |

178 -- A module import (module name, optional set of identifiers to import, optional "qualified as"

179 -- name)

180 --

181 | ImportDeclaration ModuleName (Maybe [DeclarationRef]) (Maybe ModuleName)

182 -- |

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

184 --

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

186 -- |

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

188 -- declarations)

189 --

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

191 -- |

192 -- A declaration with source position information

193 --

194 | PositionedDeclaration SourcePos Declaration

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

196

197-- |

198-- Test if a declaration is a value declaration

199--

200isValueDecl :: Declaration -> Bool

201isValueDecl ValueDeclaration{} = True

202isValueDecl (PositionedDeclaration _ d) = isValueDecl d

203isValueDecl _ = False

204

205-- |

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

207--

208isDataDecl :: Declaration -> Bool

209isDataDecl DataDeclaration{} = True

210isDataDecl TypeSynonymDeclaration{} = True

211isDataDecl (PositionedDeclaration _ d) = isDataDecl d

212isDataDecl _ = False

213

214-- |

215-- Test if a declaration is a module import

216--

217isImportDecl :: Declaration -> Bool

218isImportDecl ImportDeclaration{} = True

219isImportDecl (PositionedDeclaration _ d) = isImportDecl d

220isImportDecl _ = False

221

222-- |

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

224--

225isExternDataDecl :: Declaration -> Bool

226isExternDataDecl ExternDataDeclaration{} = True

227isExternDataDecl (PositionedDeclaration _ d) = isExternDataDecl d

228isExternDataDecl _ = False

229

230-- |

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

232--

233isExternInstanceDecl :: Declaration -> Bool

234isExternInstanceDecl ExternInstanceDeclaration{} = True

235isExternInstanceDecl (PositionedDeclaration _ d) = isExternInstanceDecl d

236isExternInstanceDecl _ = False

237

238-- |

239-- Test if a declaration is a fixity declaration

240--

241isFixityDecl :: Declaration -> Bool

242isFixityDecl FixityDeclaration{} = True

243isFixityDecl (PositionedDeclaration _ d) = isFixityDecl d

244isFixityDecl _ = False

245

246-- |

247-- Test if a declaration is a foreign import

248--

249isExternDecl :: Declaration -> Bool

250isExternDecl ExternDeclaration{} = True

251isExternDecl (PositionedDeclaration _ d) = isExternDecl d

252isExternDecl _ = False

253

254-- |

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

256--

257isTypeClassDeclaration :: Declaration -> Bool

258isTypeClassDeclaration TypeClassDeclaration{} = True

259isTypeClassDeclaration TypeInstanceDeclaration{} = True

260isTypeClassDeclaration (PositionedDeclaration _ d) = isTypeClassDeclaration d

261isTypeClassDeclaration _ = False

262

263-- |

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

265--

266type Guard = Value

267

268-- |

269-- Data type for values

270--

271data Value

272 -- |

273 -- A numeric literal

274 --

275 = NumericLiteral (Either Integer Double)

276 -- |

277 -- A string literal

278 --

279 | StringLiteral String

280 -- |

281 -- A boolean literal

282 --

283 | BooleanLiteral Bool

284 -- |

285 -- A prefix -, will be desugared

286 --

287 | UnaryMinus Value

288 -- |

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

290 -- will be removed.

291 --

292 | BinaryNoParens (Qualified Ident) Value Value

293 -- |

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

295 -- will be removed.

296 --

297 | Parens Value

298 -- |

299 -- An array literal

300 --

301 | ArrayLiteral [Value]

302 -- |

303 -- An object literal

304 --

305 | ObjectLiteral [(String, Value)]

306 -- |

307 -- An record property accessor expression

308 --

309 | Accessor String Value

310 -- |

311 -- Partial record update

312 --

313 | ObjectUpdate Value [(String, Value)]

314 -- |

315 -- Function introduction

316 --

317 | Abs (Either Ident Binder) Value

318 -- |

319 -- Function application

320 --

321 | App Value Value

322 -- |

323 -- Variable

324 --

325 | Var (Qualified Ident)

326 -- |

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

328 --

329 | IfThenElse Value Value Value

330 -- |

331 -- A data constructor

332 --

333 | Constructor (Qualified ProperName)

334 -- |

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

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

337 --

338 | Case [Value] [CaseAlternative]

339 -- |

340 -- A value with a type annotation

341 --

342 | TypedValue Bool Value Type

343 -- |

344 -- A let binding

345 --

346 | Let [Declaration] Value

347 -- |

348 -- A do-notation block

349 --

350 | Do [DoNotationElement]

351 -- |

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

353 -- an ObjectLiteral.

354 --

355 | TypeClassDictionaryConstructorApp (Qualified ProperName) Value

356 -- |

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

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

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

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

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

362 --

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

364 -- |

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

366 --

367 | SuperClassDictionary (Qualified ProperName) [Type]

368 -- |

369 -- A value with source position information

370 --

371 | PositionedValue SourcePos Value deriving (Show, D.Data, D.Typeable)

372

373-- |

374-- An alternative in a case statement

375--

376data CaseAlternative = CaseAlternative

377 { -- |

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

379 --

380 caseAlternativeBinders :: [Binder]

381 -- |

382 -- An optional guard

383 --

384 , caseAlternativeGuard :: Maybe Guard

385 -- |

386 -- The result expression

387 --

388 , caseAlternativeResult :: Value

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

390

391-- |

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

393--

394canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident

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

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

397

398-- |

399-- A statement in a do-notation block

400--

401data DoNotationElement

402 -- |

403 -- A monadic value without a binder

404 --

405 = DoNotationValue Value

406 -- |

407 -- A monadic value with a binder

408 --

409 | DoNotationBind Binder Value

410 -- |

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

412 --

413 | DoNotationLet [Declaration]

414 -- |

415 -- A do notation element with source position information

416 --

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

418

419-- |

420-- Data type for binders

421--

422data Binder

423 -- |

424 -- Wildcard binder

425 --

426 = NullBinder

427 -- |

428 -- A binder which matches a boolean literal

429 --

430 | BooleanBinder Bool

431 -- |

432 -- A binder which matches a string literal

433 --

434 | StringBinder String

435 -- |

436 -- A binder which matches a numeric literal

437 --

438 | NumberBinder (Either Integer Double)

439 -- |

440 -- A binder which binds an identifier

441 --

442 | VarBinder Ident

443 -- |

444 -- A binder which matches a data constructor

445 --

446 | ConstructorBinder (Qualified ProperName) [Binder]

447 -- |

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

449 --

450 | ObjectBinder [(String, Binder)]

451 -- |

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

453 --

454 | ArrayBinder [Binder]

455 -- |

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

457 --

458 | ConsBinder Binder Binder

459 -- |

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

461 --

462 | NamedBinder Ident Binder

463 -- |

464 -- A binder with source position information

465 --

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

467

468-- |

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

470--

471binderNames :: Binder -> [Ident]

472binderNames = go []

473 where

474 go ns (VarBinder name) = name : ns

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

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

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

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

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

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

481 go ns _ = ns

482

483--

484-- Traversals

485--

486

487everywhereOnValues :: (Declaration -> Declaration) ->

488 (Value -> Value) ->

489 (Binder -> Binder) ->

490 (Declaration -> Declaration, Value -> Value, Binder -> Binder)

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

492 where

493 f' :: Declaration -> Declaration

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

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

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

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

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

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

500 f' other = f other

501

502 g' :: Value -> Value

503 g' (UnaryMinus v) = g (UnaryMinus (g' v))

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

505 g' (Parens v) = g (Parens (g' v))

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

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

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

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

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

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

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

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

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

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

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

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

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

519 g' other = g other

520

521 h' :: Binder -> Binder

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

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

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

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

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

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

528 h' other = h other

529

530 handleCaseAlternative :: CaseAlternative -> CaseAlternative

531 handleCaseAlternative ca =

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

533 , caseAlternativeGuard = fmap g' (caseAlternativeGuard ca)

534 , caseAlternativeResult = g' (caseAlternativeResult ca)

535 }

536

537 handleDoNotationElement :: DoNotationElement -> DoNotationElement

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

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

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

541 handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos (handleDoNotationElement e)

542

543

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

545 (Declaration -> m Declaration) ->

546 (Value -> m Value) ->

547 (Binder -> m Binder) ->

548 (Declaration -> m Declaration, Value -> m Value, Binder -> m Binder)

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

550 where

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

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

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

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

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

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

557 f' other = f other

558

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

575 g' other = g other

576

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

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

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

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

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

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

583 h' other = h other

584

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

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

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

588

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

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

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

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

593

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

595 (Declaration -> m Declaration) ->

596 (Value -> m Value) ->

597 (Binder -> m Binder) ->

598 (Declaration -> m Declaration, Value -> m Value, Binder -> m Binder)

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

600 where

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

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

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

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

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

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

607 f' other = f other

608

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

625 g' other = g other

626

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

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

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

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

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

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

633 h' other = h other

634

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

636 <*> maybeM g' grd

637 <*> g' val

638

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

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

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

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

643

644everythingOnValues :: (r -> r -> r) ->

645 (Declaration -> r) ->

646 (Value -> r) ->

647 (Binder -> r) ->

648 (CaseAlternative -> r) ->

649 (DoNotationElement -> r) ->

650 (Declaration -> r, Value -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)

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

652 where

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

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

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

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

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

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

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

660 f' d = f d

661

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

678 g' v = g v

679

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

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

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

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

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

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

686 h' b = h b

687

688 i' ca = case caseAlternativeGuard ca of

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

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

691

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

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

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

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

696

697everythingWithContextOnValues ::

698 s ->

699 r ->

700 (r -> r -> r) ->

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

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

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

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

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

706 ( Declaration -> r

707 , Value -> r

708 , Binder -> r

709 , CaseAlternative -> r

710 , DoNotationElement -> r)

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

712 where

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

714

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

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

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

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

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

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

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

722 f' _ _ = r0

723

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

725

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

742 g' _ _ = r0

743

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

745

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

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

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

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

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

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

752 h' _ _ = r0

753

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

755

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

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

758

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

760

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

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

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

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

765

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

767 s ->

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

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

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

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

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

773 ( Declaration -> m Declaration

774 , Value -> m Value

775 , Binder -> m Binder

776 , CaseAlternative -> m CaseAlternative

777 , DoNotationElement -> m DoNotationElement)

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

779 where

780 f'' s = uncurry f' <=< f s

781

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

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

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

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

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

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

788 f' _ other = return other

789

790 g'' s = uncurry g' <=< g s

791

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

808 g' _ other = return other

809

810 h'' s = uncurry h' <=< h s

811

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

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

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

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

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

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

818 h' _ other = return other

819

820 i'' s = uncurry i' <=< i s

821

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

823

824 j'' s = uncurry j' <=< j s

825

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

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

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

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

830

831accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Value -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)

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

833 where

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

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

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

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

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

839 forDecls (TypeSynonymDeclaration _ _ ty) = f ty

840 forDecls (TypeDeclaration _ ty) = f ty

841 forDecls _ = mempty

842

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

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

845 forValues (TypedValue _ _ ty) = f ty

846 forValues _ = mempty

847

848