@@ -1,841 +0,0 @@
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−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}
16−
17−module Language.PureScript.Declarations where
18−
19−import Data.Monoid (Monoid(..), mconcat)
20−
21−import qualified Data.Data as D
22−
23−import Control.Applicative
24−import Control.Monad
25−import Control.Arrow ((***), (+++))
26−
27−import Language.PureScript.Types
28−import Language.PureScript.Names
29−import Language.PureScript.Kinds
30−import Language.PureScript.TypeClassDictionaries
31−import Language.PureScript.CodeGen.JS.AST
32−import Language.PureScript.Environment
33−import Language.PureScript.Traversals
34−
35−-- |
36−-- A precedence level for an infix operator
37−--
38−type Precedence = Integer
39−
40−-- |
41−-- Associativity for infix operators
42−--
43−data Associativity = Infixl | Infixr | Infix deriving (D.Data, D.Typeable)
44−
45−instance Show Associativity where
46− show Infixl = "infixl"
47− show Infixr = "infixr"
48− show Infix = "infix"
49−
50−-- |
51−-- Source position information
52−--
53−data 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)
67−
68−instance Show SourcePos where
69− show sp = (sourceName sp) ++ " line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp)
70−
71−-- |
72−-- Fixity data for infix operators
73−--
74−data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)
75−
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−--
80−data Module = Module ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, D.Data, D.Typeable)
81−
82−-- |
83−-- An item in a list of explicit imports or exports
84−--
85−data 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−
108−instance 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−--
120−data 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−--
138−data 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−--
201−isValueDecl :: Declaration -> Bool
202−isValueDecl ValueDeclaration{} = True
203−isValueDecl (PositionedDeclaration _ d) = isValueDecl d
204−isValueDecl _ = False
205−
206−-- |
207−-- Test if a declaration is a data type or type synonym declaration
208−--
209−isDataDecl :: Declaration -> Bool
210−isDataDecl DataDeclaration{} = True
211−isDataDecl TypeSynonymDeclaration{} = True
212−isDataDecl (PositionedDeclaration _ d) = isDataDecl d
213−isDataDecl _ = False
214−
215−-- |
216−-- Test if a declaration is a module import
217−--
218−isImportDecl :: Declaration -> Bool
219−isImportDecl ImportDeclaration{} = True
220−isImportDecl (PositionedDeclaration _ d) = isImportDecl d
221−isImportDecl _ = False
222−
223−-- |
224−-- Test if a declaration is a data type foreign import
225−--
226−isExternDataDecl :: Declaration -> Bool
227−isExternDataDecl ExternDataDeclaration{} = True
228−isExternDataDecl (PositionedDeclaration _ d) = isExternDataDecl d
229−isExternDataDecl _ = False
230−
231−-- |
232−-- Test if a declaration is a type class instance foreign import
233−--
234−isExternInstanceDecl :: Declaration -> Bool
235−isExternInstanceDecl ExternInstanceDeclaration{} = True
236−isExternInstanceDecl (PositionedDeclaration _ d) = isExternInstanceDecl d
237−isExternInstanceDecl _ = False
238−
239−-- |
240−-- Test if a declaration is a fixity declaration
241−--
242−isFixityDecl :: Declaration -> Bool
243−isFixityDecl FixityDeclaration{} = True
244−isFixityDecl (PositionedDeclaration _ d) = isFixityDecl d
245−isFixityDecl _ = False
246−
247−-- |
248−-- Test if a declaration is a foreign import
249−--
250−isExternDecl :: Declaration -> Bool
251−isExternDecl ExternDeclaration{} = True
252−isExternDecl (PositionedDeclaration _ d) = isExternDecl d
253−isExternDecl _ = False
254−
255−-- |
256−-- Test if a declaration is a type class or instance declaration
257−--
258−isTypeClassDeclaration :: Declaration -> Bool
259−isTypeClassDeclaration TypeClassDeclaration{} = True
260−isTypeClassDeclaration TypeInstanceDeclaration{} = True
261−isTypeClassDeclaration (PositionedDeclaration _ d) = isTypeClassDeclaration d
262−isTypeClassDeclaration _ = False
263−
264−-- |
265−-- A guard is just a boolean-valued expression that appears alongside a set of binders
266−--
267−type Guard = Expr
268−
269−-- |
270−-- Data type for expressions and terms
271−--
272−data 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−--
377−data 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−--
391−canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident
392−canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm
393−canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm
394−
395−-- |
396−-- A statement in a do-notation block
397−--
398−data 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−--
419−data 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−--
468−binderNames :: Binder -> [Ident]
469−binderNames = 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−
484−everywhereOnValues :: (Declaration -> Declaration) ->
485− (Expr -> Expr) ->
486− (Binder -> Binder) ->
487− (Declaration -> Declaration, Expr -> Expr, Binder -> Binder)
488−everywhereOnValues 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−
540−everywhereOnValuesTopDownM :: (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)
545−everywhereOnValuesTopDownM 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−
589−everywhereOnValuesM :: (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)
594−everywhereOnValuesM 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−
638−everythingOnValues :: (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)
645−everythingOnValues (<>) 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−
690−everythingWithContextOnValues ::
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)
704−everythingWithContextOnValues 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−
759−everywhereWithContextOnValuesM :: (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)
771−everywhereWithContextOnValuesM 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−
824−accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)
825−accumTypes 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−