@@ -0,0 +1,841 @@
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+