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

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

on 5c2aa36 help sign in

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

585 lines 19 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 #-}

17module Language.PureScript.Declarations where

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

21import Language.PureScript.Types

22import Language.PureScript.Names

23import Language.PureScript.Kinds

24import Language.PureScript.TypeClassDictionaries

25import Language.PureScript.CodeGen.JS.AST

26import Language.PureScript.Environment

28import qualified Data.Data as D

30-- |

31-- A precedence level for an infix operator

32--

33type Precedence = Integer

35-- |

36-- Associativity for infix operators

37--

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

40instance Show Associativity where

41 show Infixl = "infixl"

42 show Infixr = "infixr"

43 show Infix = "infix"

45-- |

46-- Source position information

47--

48data SourcePos = SourcePos

49 { -- |

50 -- Source name

51 --

52 sourceName :: String

53 -- |

54 -- Line number

55 --

56 , sourcePosLine :: Int

57 -- |

58 -- Column number

59 --

60 , sourcePosColumn :: Int

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

63instance Show SourcePos where

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

66-- |

67-- Fixity data for infix operators

68--

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

71-- |

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

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

74--

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

77-- |

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

79--

80data DeclarationRef

81 -- |

82 -- A type constructor with data constructors

83 --

84 = TypeRef ProperName (Maybe [ProperName])

85 -- |

86 -- A value

87 --

88 | ValueRef Ident

89 -- |

90 -- A type class

91 --

92 | TypeClassRef ProperName

93 -- |

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

95 --

96 | TypeInstanceRef Ident

97 -- |

98 -- A declaration reference with source position information

99 --

100 | PositionedDeclarationRef SourcePos DeclarationRef

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

102

103instance Eq DeclarationRef where

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

105 (ValueRef name) == (ValueRef name') = name == name'

106 (TypeClassRef name) == (TypeClassRef name') = name == name'

107 (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'

108 (PositionedDeclarationRef _ r) == r' = r == r'

109 r == (PositionedDeclarationRef _ r') = r == r'

110 _ == _ = False

111

112-- |

113-- The data type of declarations

114--

115data Declaration

116 -- |

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

118 --

119 = DataDeclaration ProperName [String] [(ProperName, [Type])]

120 -- |

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

122 --

123 | DataBindingGroupDeclaration [Declaration]

124 -- |

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

126 --

127 | TypeSynonymDeclaration ProperName [String] Type

128 -- |

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

130 --

131 | TypeDeclaration Ident Type

132 -- |

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

134 --

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

136 -- |

137 -- A minimal mutually recursive set of value declarations

138 --

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

140 -- |

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

142 --

143 | ExternDeclaration ForeignImportType Ident (Maybe JS) Type

144 -- |

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

146 --

147 | ExternDataDeclaration ProperName Kind

148 -- |

149 -- A type class instance foreign import

150 --

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

152 -- |

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

154 --

155 | FixityDeclaration Fixity String

156 -- |

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

158 -- name)

159 --

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

161 -- |

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

163 --

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

165 -- |

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

167 -- declarations)

168 --

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

170 -- |

171 -- A declaration with source position information

172 --

173 | PositionedDeclaration SourcePos Declaration

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

175

176-- |

177-- Test if a declaration is a value declaration

178--

179isValueDecl :: Declaration -> Bool

180isValueDecl ValueDeclaration{} = True

181isValueDecl (PositionedDeclaration _ d) = isValueDecl d

182isValueDecl _ = False

183

184-- |

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

186--

187isDataDecl :: Declaration -> Bool

188isDataDecl DataDeclaration{} = True

189isDataDecl TypeSynonymDeclaration{} = True

190isDataDecl (PositionedDeclaration _ d) = isDataDecl d

191isDataDecl _ = False

192

193-- |

194-- Test if a declaration is a module import

195--

196isImportDecl :: Declaration -> Bool

197isImportDecl ImportDeclaration{} = True

198isImportDecl (PositionedDeclaration _ d) = isImportDecl d

199isImportDecl _ = False

200

201-- |

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

203--

204isExternDataDecl :: Declaration -> Bool

205isExternDataDecl ExternDataDeclaration{} = True

206isExternDataDecl (PositionedDeclaration _ d) = isExternDataDecl d

207isExternDataDecl _ = False

208

209-- |

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

211--

212isExternInstanceDecl :: Declaration -> Bool

213isExternInstanceDecl ExternInstanceDeclaration{} = True

214isExternInstanceDecl (PositionedDeclaration _ d) = isExternInstanceDecl d

215isExternInstanceDecl _ = False

216

217-- |

218-- Test if a declaration is a fixity declaration

219--

220isFixityDecl :: Declaration -> Bool

221isFixityDecl FixityDeclaration{} = True

222isFixityDecl (PositionedDeclaration _ d) = isFixityDecl d

223isFixityDecl _ = False

224

225-- |

226-- Test if a declaration is a foreign import

227--

228isExternDecl :: Declaration -> Bool

229isExternDecl ExternDeclaration{} = True

230isExternDecl (PositionedDeclaration _ d) = isExternDecl d

231isExternDecl _ = False

232

233-- |

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

235--

236isTypeClassDeclaration :: Declaration -> Bool

237isTypeClassDeclaration TypeClassDeclaration{} = True

238isTypeClassDeclaration TypeInstanceDeclaration{} = True

239isTypeClassDeclaration (PositionedDeclaration _ d) = isTypeClassDeclaration d

240isTypeClassDeclaration _ = False

241

242-- |

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

244--

245type Guard = Value

246

247-- |

248-- Data type for values

249--

250data Value

251 -- |

252 -- A numeric literal

253 --

254 = NumericLiteral (Either Integer Double)

255 -- |

256 -- A string literal

257 --

258 | StringLiteral String

259 -- |

260 -- A boolean literal

261 --

262 | BooleanLiteral Bool

263 -- |

264 -- A prefix -, will be desugared

265 --

266 | UnaryMinus Value

267 -- |

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

269 -- will be removed.

270 --

271 | BinaryNoParens (Qualified Ident) Value Value

272 -- |

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

274 -- will be removed.

275 --

276 | Parens Value

277 -- |

278 -- An array literal

279 --

280 | ArrayLiteral [Value]

281 -- |

282 -- An object literal

283 --

284 | ObjectLiteral [(String, Value)]

285 -- |

286 -- An record property accessor expression

287 --

288 | Accessor String Value

289 -- |

290 -- Partial record update

291 --

292 | ObjectUpdate Value [(String, Value)]

293 -- |

294 -- Function introduction

295 --

296 | Abs (Either Ident Binder) Value

297 -- |

298 -- Function application

299 --

300 | App Value Value

301 -- |

302 -- Variable

303 --

304 | Var (Qualified Ident)

305 -- |

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

307 --

308 | IfThenElse Value Value Value

309 -- |

310 -- A data constructor

311 --

312 | Constructor (Qualified ProperName)

313 -- |

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

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

316 --

317 | Case [Value] [CaseAlternative]

318 -- |

319 -- A value with a type annotation

320 --

321 | TypedValue Bool Value Type

322 -- |

323 -- A let binding

324 --

325 | Let [Declaration] Value

326 -- |

327 -- A do-notation block

328 --

329 | Do [DoNotationElement]

330 -- |

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

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

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

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

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

336 --

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

338 -- |

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

340 --

341 | SuperClassDictionary (Qualified ProperName) [Type]

342 -- |

343 -- A value with source position information

344 --

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

346

347-- |

348-- An alternative in a case statement

349--

350data CaseAlternative = CaseAlternative

351 { -- |

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

353 --

354 caseAlternativeBinders :: [Binder]

355 -- |

356 -- An optional guard

357 --

358 , caseAlternativeGuard :: Maybe Guard

359 -- |

360 -- The result expression

361 --

362 , caseAlternativeResult :: Value

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

364

365-- |

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

367--

368canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident

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

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

371

372-- |

373-- A statement in a do-notation block

374--

375data DoNotationElement

376 -- |

377 -- A monadic value without a binder

378 --

379 = DoNotationValue Value

380 -- |

381 -- A monadic value with a binder

382 --

383 | DoNotationBind Binder Value

384 -- |

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

386 --

387 | DoNotationLet [Declaration]

388 -- |

389 -- A do notation element with source position information

390 --

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

392

393-- |

394-- Data type for binders

395--

396data Binder

397 -- |

398 -- Wildcard binder

399 --

400 = NullBinder

401 -- |

402 -- A binder which matches a boolean literal

403 --

404 | BooleanBinder Bool

405 -- |

406 -- A binder which matches a string literal

407 --

408 | StringBinder String

409 -- |

410 -- A binder which matches a numeric literal

411 --

412 | NumberBinder (Either Integer Double)

413 -- |

414 -- A binder which binds an identifier

415 --

416 | VarBinder Ident

417 -- |

418 -- A binder which matches a data constructor

419 --

420 | ConstructorBinder (Qualified ProperName) [Binder]

421 -- |

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

423 --

424 | ObjectBinder [(String, Binder)]

425 -- |

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

427 --

428 | ArrayBinder [Binder]

429 -- |

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

431 --

432 | ConsBinder Binder Binder

433 -- |

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

435 --

436 | NamedBinder Ident Binder

437 -- |

438 -- A binder with source position information

439 --

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

441

442-- |

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

444--

445binderNames :: Binder -> [Ident]

446binderNames = go []

447 where

448 go ns (VarBinder name) = name : ns

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

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

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

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

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

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

455 go ns _ = ns

456

457--

458-- Traversals

459--

460

461everywhereOnValues :: (Declaration -> Declaration) ->

462 (Value -> Value) ->

463 (Binder -> Binder) ->

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

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

466 where

467 f' :: Declaration -> Declaration

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

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

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

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

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

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

474 f' other = f other

475

476 g' :: Value -> Value

477 g' (UnaryMinus v) = g (UnaryMinus (g' v))

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

479 g' (Parens v) = g (Parens (g' v))

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

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

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

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

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

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

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

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

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

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

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

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

492 g' other = g other

493

494 h' :: Binder -> Binder

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

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

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

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

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

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

501 h' other = h other

502

503 handleCaseAlternative :: CaseAlternative -> CaseAlternative

504 handleCaseAlternative ca =

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

506 , caseAlternativeGuard = fmap g' (caseAlternativeGuard ca)

507 , caseAlternativeResult = g' (caseAlternativeResult ca)

508 }

509

510 handleDoNotationElement :: DoNotationElement -> DoNotationElement

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

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

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

514 handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos (handleDoNotationElement e)

515

516everythingOnValues :: (r -> r -> r) ->

517 (Declaration -> r) ->

518 (Value -> r) ->

519 (Binder -> r) ->

520 (CaseAlternative -> r) ->

521 (DoNotationElement -> r) ->

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

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

524 where

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

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

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

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

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

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

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

532 f' d = f d

533

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

549 g' v = g v

550

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

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

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

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

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

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

557 h' b = h b

558

559 i' ca = case caseAlternativeGuard ca of

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

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

562

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

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

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

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

567

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

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

570 where

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

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

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

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

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

576 forDecls (TypeSynonymDeclaration _ _ ty) = f ty

577 forDecls (TypeDeclaration _ ty) = f ty

578 forDecls _ = mempty

579

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

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

582 forValues (TypedValue _ _ ty) = f ty

583 forValues _ = mempty

584

585