purescript 0.4.18.2 → 0.4.19

raw patch · 17 files changed

+571/−262 lines, 17 filesdep −sybPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: syb

API changes (from Hackage documentation)

Files

• purescript.cabal +8/−8
• src/Data/Generics/Extras.hs +0/−73
• src/Language/PureScript/CodeGen/JS.hs +25/−5
• src/Language/PureScript/DeadCodeElimination.hs +4/−4
• src/Language/PureScript/Declarations.hs +311/−3
• src/Language/PureScript/ModuleDependencies.hs +20/−15
• src/Language/PureScript/Scope.hs +49/−27
• src/Language/PureScript/Sugar.hs +1/−1
• src/Language/PureScript/Sugar/BindingGroups.hs +11/−8
• src/Language/PureScript/Sugar/CaseDeclarations.hs +7/−6
• src/Language/PureScript/Sugar/DoNotation.hs +13/−7
• src/Language/PureScript/Sugar/Names.hs +55/−72
• src/Language/PureScript/Sugar/Operators.hs +7/−8
• src/Language/PureScript/Sugar/TypeDeclarations.hs +2/−3
• src/Language/PureScript/Traversals.hs +34/−0
• src/Language/PureScript/TypeChecker/Types.hs +23/−19
• src/Language/PureScript/Types.hs +1/−3

@@ -1,5 +1,5 @@ name: purescript-version: 0.4.18.2+version: 0.4.19 cabal-version: >=1.8 build-type: Custom license: MIT@@ -19,15 +19,14 @@  library     build-depends: base >=4 && <5, cmdtheline -any, containers -any, unordered-containers -any,-                   directory >= 1.2, filepath -any, mtl -any, parsec -any, syb >= 0.4.1 && < 0.5,+                   directory >= 1.2, filepath -any, mtl -any, parsec -any,                    transformers -any, utf8-string -any,                    pattern-arrows >= 0.0.2 && < 0.1,                    monad-unify >= 0.2.2 && < 0.3,                    xdg-basedir -any, time -any     if (!os(windows))         build-depends: unix -any-    exposed-modules: Data.Generics.Extras-                     Language.PureScript+    exposed-modules: Language.PureScript                      Language.PureScript.Constants                      Language.PureScript.Options                      Language.PureScript.Declarations@@ -37,6 +36,7 @@                      Language.PureScript.Names                      Language.PureScript.Types                      Language.PureScript.Scope+                     Language.PureScript.Traversals                      Language.PureScript.TypeClassDictionaries                      Language.PureScript.DeadCodeElimination                      Language.PureScript.Sugar@@ -87,7 +87,7 @@ executable psc     build-depends: base >=4 && <5, cmdtheline -any, containers -any,                    directory -any, filepath -any, mtl -any, parsec -any,-                   purescript -any, syb >= 0.4.1 && < 0.5, transformers -any, utf8-string -any+                   purescript -any, transformers -any, utf8-string -any     main-is: Main.hs     buildable: True     hs-source-dirs: psc@@ -97,7 +97,7 @@ executable psc-make     build-depends: base >=4 && <5, cmdtheline -any, containers -any,                    directory -any, filepath -any, mtl -any, parsec -any,-                   purescript -any, syb >= 0.4.1 && < 0.5, transformers -any, utf8-string -any+                   purescript -any, transformers -any, utf8-string -any     main-is: Main.hs     buildable: True     hs-source-dirs: psc-make@@ -107,7 +107,7 @@ executable psci     build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,                    mtl -any, parsec -any, haskeline -any, purescript -any,-                   syb >= 0.4.1 && < 0.5, transformers -any, utf8-string -any, process -any,+                   transformers -any, utf8-string -any, process -any,                    xdg-basedir -any, cmdtheline -any     main-is: Main.hs     buildable: True@@ -136,7 +136,7 @@  test-suite tests     build-depends: base >=4 && <5, containers -any, directory -any,-                   filepath -any, mtl -any, parsec -any, purescript -any, syb >= 0.4.1 && < 0.5,+                   filepath -any, mtl -any, parsec -any, purescript -any,                     transformers -any, utf8-string -any, process -any     type: exitcode-stdio-1.0     main-is: Main.hs

@@ -1,73 +0,0 @@------------------------------------------------------------------------------------ Module      :  Data.Generics.Extras--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- Additional SYB combinators-----------------------------------------------------------------------------------{-# LANGUAGE Rank2Types #-}--module Data.Generics.Extras where--import Data.Data---- |--- Apply a top-down monadic transformation everywhere----everywhereM' :: (Monad m, Data d) => (forall d1. (Data d1) => d1 -> m d1) -> d -> m d-everywhereM' f x = do-  y <- f x-  gmapM (everywhereM' f) y---- |--- Apply a top-down transformation, mutating a state when descending from parents to children------ For example, if we want to relabel bound variables with a different data constructor, we can do so:------ > data Expr = Var String--- >           | Lam String Test--- >           | App Test Test--- >           | LocalVar String deriving (Show, Data, Typeable)--- >--- > test = App (Lam "a" (App (Var "a") (Var "b"))) (Var "a")--- >--- > varsToLocals :: Expr -> Expr--- > varsToLocals = everywhereWithContext' [] (mkS go)--- >   where--- >   go locals (Var v) | v `elem` locals = (locals, LocalVar v)--- >   go locals lam@(Lam local _) = (local : locals, lam)--- >   go locals other = (locals, other)----everywhereWithContextM' :: (Monad m, Data d) => s -> (forall d1. (Data d1) => s -> d1 -> m (s, d1)) -> d -> m d-everywhereWithContextM' s0 f x = do-  (s, y) <- f s0 x-  gmapM (everywhereWithContextM' s f) y---- |--- Make a stateful transformation function----mkS :: (Monad m, Data a, Data b) => (s -> a -> m (s, a)) -> s -> b -> m (s, b)-mkS = extS (curry return)---- |--- Extend a stateful transformation function----extS :: (Monad m, Data a, Data b) => (s -> a -> m (s, a)) -> (s -> b -> m (s, b)) -> (s -> a -> m (s, a))-extS f g s a = do-  (s', a') <- f s a-  case cast a' of-    Just b -> do-      (s'', b') <- g s' b-      case cast b' of-        Just a'' -> return (s'', a'')-        Nothing -> return (s', a')-    Nothing -> return (s', a')-

@@ -26,7 +26,6 @@ import Data.Maybe (fromJust, fromMaybe, mapMaybe) import Data.Function (on) import Data.List (nub, (\\))-import Data.Generics (mkQ, everything)  import Control.Arrow (second) import Control.Monad (replicateM, forM)@@ -34,7 +33,6 @@ import qualified Data.Map as M  import Language.PureScript.Names-import Language.PureScript.Scope import Language.PureScript.Declarations import Language.PureScript.CodeGen.Monad import Language.PureScript.Options@@ -44,6 +42,8 @@ import Language.PureScript.CodeGen.Common import Language.PureScript.Environment +import qualified Language.PureScript.Scope as S+ -- | -- Different types of modules which are supported --@@ -77,7 +77,9 @@     Globals -> JSAccessor (moduleNameToJs mn) (JSVar (fromJust (optionsBrowserNamespace opts)))  imports :: Declaration -> [ModuleName]-imports = everything (++) (mkQ [] collect)+imports =+  let (f, _, _, _, _) = everythingOnValues (++) (const []) collect (const []) (const []) (const [])+  in f   where   collect :: Value -> [ModuleName]   collect (Var (Qualified (Just mn) _)) = [mn]@@ -167,7 +169,8 @@ extendObj :: JS -> [(String, JS)] -> JS extendObj obj sts = JSApp (JSFunction Nothing [] block) []   where-  [newObj, key] = take 2 . map identToJs . unusedNames $ (obj, sts)+  [newObj, key] = take 2 . map identToJs . S.unusedNames $ used+  used = usedNamesJS obj ++ concatMap (usedNamesJS . snd) sts   jsKey = JSVar key   jsNewObj = JSVar newObj   block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])@@ -247,12 +250,14 @@ -- and guards. -- bindersToJs :: Options -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> JS-bindersToJs opts m e binders vals = runGen (map identToJs (unusedNames (binders, vals))) $ do+bindersToJs opts m e binders vals = runGen (map identToJs (S.unusedNames usedNames)) $ do   valNames <- replicateM (length vals) fresh   jss <- forM binders $ \(CaseAlternative bs grd result) -> go valNames [JSReturn (valueToJs opts m (bindNames m (concatMap binderNames bs) e) result)] bs grd   return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))                  vals   where+    usedNames = concatMap usedNamesJS vals ++ concatMap S.usedNamesCaseAlternative binders+     go :: [String] -> [JS] -> [Binder] -> Maybe Guard -> Gen [JS]     go _ done [] Nothing = return done     go _ done [] (Just cond) = return [JSIfElse (valueToJs opts m e cond) (JSBlock done) Nothing]@@ -262,6 +267,20 @@     go _ _ _ _ = error "Invalid arguments to bindersToJs"  -- |+-- Gather all used names appearing inside a value+--+usedNamesJS :: JS -> [Ident]+usedNamesJS val = nub $ everythingOnJS (++) namesJS val+  where+  namesJS (JSVar name) = [Ident name]+  namesJS (JSFunction (Just name) args _) = Ident name : map Ident args+  namesJS (JSFunction Nothing args _) = map Ident args+  namesJS (JSVariableIntroduction name _) = [Ident name]+  namesJS (JSFor name _ _ _) = [Ident name]+  namesJS (JSForIn name _ _) = [Ident name]+  namesJS _ = []++-- | -- Generate code in the simplified Javascript intermediate representation for a pattern match -- binder. --@@ -342,3 +361,4 @@   numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors e   typeConstructor (Qualified (Just moduleName) _, (tyCtor, _)) = (moduleName, tyCtor)   typeConstructor _ = error "Invalid argument to isOnlyConstructor"+

@@ -16,10 +16,8 @@   eliminateDeadCode ) where -import Data.Data import Data.List import Data.Graph-import Data.Generics import Data.Maybe (mapMaybe)  import Language.PureScript.Names@@ -73,8 +71,10 @@   go (PositionedDeclaration _ d) = go d   go _ = [] -dependencies :: (Data d) => ModuleName -> d -> [Key]-dependencies moduleName = nub . everything (++) (mkQ [] values)+dependencies :: ModuleName -> Declaration -> [Key]+dependencies moduleName =+  let (f, _, _, _, _) = everythingOnValues (++) (const []) values (const []) (const []) (const [])+  in nub . f   where   values :: Value -> [Key]   values (Var ident) = let (mn, name) = qualify moduleName ident in [(mn, Left name)]

@@ -12,18 +12,24 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}  module Language.PureScript.Declarations where +import Data.Monoid (Monoid(..), mconcat)++import qualified Data.Data as D++import Control.Applicative+import Control.Monad+ import Language.PureScript.Types import Language.PureScript.Names import Language.PureScript.Kinds import Language.PureScript.TypeClassDictionaries import Language.PureScript.CodeGen.JS.AST import Language.PureScript.Environment--import qualified Data.Data as D+import Language.PureScript.Traversals  -- | -- A precedence level for an infix operator@@ -510,3 +516,305 @@   handleDoNotationElement (DoNotationBind b v) = DoNotationBind (h' b) (g' v)   handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)   handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos (handleDoNotationElement e)+++everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>+  (Declaration -> m Declaration) ->+  (Value -> m Value) ->+  (Binder -> m Binder) ->+  (Declaration -> m Declaration, Value -> m Value, Binder -> m Binder)+everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)+  where+  f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f' <=< f) ds+  f' (ValueDeclaration name nameKind bs grd val) = ValueDeclaration name nameKind <$> mapM (h' <=< h) bs <*> maybeM (g' <=< g) grd <*> (g val >>= g')+  f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds+  f' (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f' <=< f) ds+  f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f' <=< f) ds+  f' (PositionedDeclaration pos d) = PositionedDeclaration pos <$> (f d >>= f')+  f' other = f other++  g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g')+  g' (BinaryNoParens op v1 v2) = BinaryNoParens op <$> (g v1 >>= g') <*> (g v2 >>= g')+  g' (Parens v) = Parens <$> (g v >>= g')+  g' (ArrayLiteral vs) = ArrayLiteral <$> mapM (g' <=< g) vs+  g' (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g' <=< g)) vs+  g' (Accessor prop v) = Accessor prop <$> (g v >>= g')+  g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> mapM (sndM (g' <=< g)) vs+  g' (Abs name v) = Abs name <$> (g v >>= g')+  g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g')+  g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g')+  g' (Case vs alts) = Case <$> mapM (g' <=< g) vs <*> mapM handleCaseAlternative alts+  g' (TypedValue check v ty) = TypedValue check <$> (g v >>= g') <*> pure ty+  g' (Let ds v) = Let <$> mapM (f' <=< f) ds <*> (g v >>= g')+  g' (Do es) = Do <$> mapM handleDoNotationElement es+  g' (PositionedValue pos v) = PositionedValue pos <$> (g v >>= g')+  g' other = g other++  h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM (h' <=< h) bs+  h' (ObjectBinder bs) = ObjectBinder <$> mapM (sndM (h' <=< h)) bs+  h' (ArrayBinder bs) = ArrayBinder <$> mapM (h' <=< h) bs+  h' (ConsBinder b1 b2) = ConsBinder <$> (h b1 >>= h') <*> (h b2 >>= h')+  h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')+  h' (PositionedBinder pos b) = PositionedBinder pos <$> (h b >>= h')+  h' other = h other++  handleCaseAlternative (CaseAlternative bs grd val) = CaseAlternative <$> mapM (h' <=< h) bs+                                                                       <*> maybeM (g' <=< g) grd+                                                                       <*> (g' <=< g) val++  handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v+  handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> (h' <=< h) b <*> (g' <=< g) v+  handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM (f' <=< f) ds+  handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos <$> handleDoNotationElement e++everywhereOnValuesM :: (Functor m, Applicative m, Monad m) =>+  (Declaration -> m Declaration) ->+  (Value -> m Value) ->+  (Binder -> m Binder) ->+  (Declaration -> m Declaration, Value -> m Value, Binder -> m Binder)+everywhereOnValuesM f g h = (f' <=< f, g' <=< g, h' <=< h)+  where+  f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> mapM f' ds) >>= f+  f' (ValueDeclaration name nameKind bs grd val) = (ValueDeclaration name nameKind <$> mapM h' bs <*> maybeM g' grd <*> g' val) >>= f+  f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f+  f' (TypeClassDeclaration name args implies ds) = (TypeClassDeclaration name args implies <$> mapM f' ds) >>= f+  f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> mapM f' ds) >>= f+  f' (PositionedDeclaration pos d) = (PositionedDeclaration pos <$> f' d) >>= f+  f' other = f other++  g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g+  g' (BinaryNoParens op v1 v2) = (BinaryNoParens op <$> (g' v1) <*> (g' v2)) >>= g+  g' (Parens v) = (Parens <$> g' v) >>= g+  g' (ArrayLiteral vs) = (ArrayLiteral <$> mapM g' vs) >>= g+  g' (ObjectLiteral vs) = (ObjectLiteral <$> mapM (sndM g') vs) >>= g+  g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g+  g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> mapM (sndM g') vs) >>= g+  g' (Abs name v) = (Abs name <$> g' v) >>= g+  g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g+  g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g+  g' (Case vs alts) = (Case <$> mapM g' vs <*> mapM handleCaseAlternative alts) >>= g+  g' (TypedValue check v ty) = (TypedValue check <$> g' v <*> pure ty) >>= g+  g' (Let ds v) = (Let <$> mapM f' ds <*> g' v) >>= g+  g' (Do es) = (Do <$> mapM handleDoNotationElement es) >>= g+  g' (PositionedValue pos v) = (PositionedValue pos <$> g' v) >>= g+  g' other = g other++  h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> mapM h' bs) >>= h+  h' (ObjectBinder bs) = (ObjectBinder <$> mapM (sndM h') bs) >>= h+  h' (ArrayBinder bs) = (ArrayBinder <$> mapM h' bs) >>= h+  h' (ConsBinder b1 b2) = (ConsBinder <$> h' b1 <*> h' b2) >>= h+  h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h+  h' (PositionedBinder pos b) = (PositionedBinder pos <$> h' b) >>= h+  h' other = h other++  handleCaseAlternative (CaseAlternative bs grd val) = CaseAlternative <$> mapM h' bs+                                                                       <*> maybeM g' grd+                                                                       <*> g' val++  handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v+  handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> h' b <*> g' v+  handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM f' ds+  handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos <$> handleDoNotationElement e++everythingOnValues :: (r -> r -> r) ->+                      (Declaration -> r) ->+                      (Value -> r) ->+                      (Binder -> r) ->+                      (CaseAlternative -> r) ->+                      (DoNotationElement -> r) ->+                      (Declaration -> r, Value -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)+everythingOnValues (<>) f g h i j = (f', g', h', i', j')+  where+  f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds)+  f' d@(ValueDeclaration _ _ bs Nothing val) = foldl (<>) (f d) (map h' bs) <> g' val+  f' d@(ValueDeclaration _ _ bs (Just grd) val) = foldl (<>) (f d) (map h' bs) <> g' grd <> g' val+  f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds)+  f' d@(TypeClassDeclaration _ _ _ ds) = foldl (<>) (f d) (map f' ds)+  f' d@(TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) (f d) (map f' ds)+  f' d@(PositionedDeclaration _ d1) = f d <> f' d1+  f' d = f d++  g' v@(UnaryMinus v1) = g v <> g' v1+  g' v@(BinaryNoParens _ v1 v2) = g v <> g' v1 <> g' v2+  g' v@(Parens v1) = g v <> g' v1+  g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)+  g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)+  g' v@(Accessor _ v1) = g v <> g' v1+  g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)+  g' v@(Abs _ v1) = g v <> g' v1+  g' v@(App v1 v2) = g v <> g' v1 <> g' v2+  g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3+  g' v@(Case vs alts) = foldl (<>) (foldl (<>) (g v) (map g' vs)) (map i' alts)+  g' v@(TypedValue _ v1 _) = g v <> g' v1+  g' v@(Let ds v1) = (foldl (<>) (g v) (map f' ds)) <> g' v1+  g' v@(Do es) = foldl (<>) (g v) (map j' es)+  g' v@(PositionedValue _ v1) = g v <> g' v1+  g' v = g v++  h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs)+  h' b@(ObjectBinder bs) = foldl (<>) (h b) (map (h' . snd) bs)+  h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs)+  h' b@(ConsBinder b1 b2) = h b <> h' b1 <> h' b2+  h' b@(NamedBinder _ b1) = h b <> h' b1+  h' b@(PositionedBinder _ b1) = h b <> h' b1+  h' b = h b++  i' ca = case caseAlternativeGuard ca of+    Nothing -> foldl (<>) (i ca) (map h' (caseAlternativeBinders ca)) <> g' (caseAlternativeResult ca)+    Just grd -> foldl (<>) (i ca) (map h' (caseAlternativeBinders ca)) <> g' grd <> g' (caseAlternativeResult ca)++  j' e@(DoNotationValue v) = j e <> g' v+  j' e@(DoNotationBind b v) = j e <> h' b <> g' v+  j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds)+  j' e@(PositionedDoNotationElement _ e1) = j e <> j' e1++everythingWithContextOnValues ::+  s ->+  r ->+  (r -> r -> r) ->+  (s -> Declaration       -> (s, r)) ->+  (s -> Value             -> (s, r)) ->+  (s -> Binder            -> (s, r)) ->+  (s -> CaseAlternative   -> (s, r)) ->+  (s -> DoNotationElement -> (s, r)) ->+  ( Declaration       -> r+  , Value             -> r+  , Binder            -> r+  , CaseAlternative   -> r+  , DoNotationElement -> r)+everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)+  where+  f'' s d = let (s', r) = f s d in r <> f' s' d++  f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (map (f'' s) ds)+  f' s (ValueDeclaration _ _ bs Nothing val) = foldl (<>) r0 (map (h'' s) bs) <> (g'' s) val+  f' s (ValueDeclaration _ _ bs (Just grd) val) = foldl (<>) r0 (map (h'' s) bs) <> (g'' s) grd <> (g'' s) val+  f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (map (\(_, _, val) -> (g'' s) val) ds)+  f' s (TypeClassDeclaration _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)+  f' s (TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)+  f' s (PositionedDeclaration _ d1) = (f'' s) d1+  f' _ _ = r0++  g'' s v = let (s', r) = g s v in r <> g' s' v++  g' s (UnaryMinus v1) = (g'' s) v1+  g' s (BinaryNoParens _ v1 v2) = (g'' s) v1 <> (g'' s) v2+  g' s (Parens v1) = (g'' s) v1+  g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs)+  g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs)+  g' s (Accessor _ v1) = (g'' s) v1+  g' s (ObjectUpdate obj vs) = foldl (<>) ((g'' s) obj) (map (g'' s . snd) vs)+  g' s (Abs _ v1) = (g'' s) v1+  g' s (App v1 v2) = (g'' s) v1 <> (g'' s) v2+  g' s (IfThenElse v1 v2 v3) = (g'' s) v1 <> (g'' s) v2 <> (g'' s) v3+  g' s (Case vs alts) = foldl (<>) (foldl (<>) r0 (map (g'' s) vs)) (map (i'' s) alts)+  g' s (TypedValue _ v1 _) = (g'' s) v1+  g' s (Let ds v1) = (foldl (<>) r0 (map (f'' s) ds)) <> (g'' s) v1+  g' s (Do es) = foldl (<>) r0 (map (j'' s) es)+  g' s (PositionedValue _ v1) = (g'' s) v1+  g' _ _ = r0++  h'' s b = let (s', r) = h s b in r <> h' s' b++  h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (h'' s) bs)+  h' s (ObjectBinder bs) = foldl (<>) r0 (map (h'' s . snd) bs)+  h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs)+  h' s (ConsBinder b1 b2) = (h'' s) b1 <> (h'' s) b2+  h' s (NamedBinder _ b1) = (h'' s) b1+  h' s (PositionedBinder _ b1) = (h'' s) b1+  h' _ _ = r0++  i'' s ca = let (s', r) = i s ca in r <> i' s' ca++  i' s (CaseAlternative bs Nothing val) = foldl (<>) r0 (map (h'' s) bs) <> (g'' s) val+  i' s (CaseAlternative bs (Just grd) val) = foldl (<>) r0 (map (h'' s) bs) <> (g'' s) grd <> (g'' s) val++  j'' s e = let (s', r) = j s e in r <> j' s' e++  j' s (DoNotationValue v) = (g'' s) v+  j' s (DoNotationBind b v) =  (h'' s) b <> (g'' s) v+  j' s (DoNotationLet ds) = foldl (<>) r0 (map (f'' s) ds)+  j' s (PositionedDoNotationElement _ e1) = (j'' s) e1++everywhereWithContextOnValuesM :: (Functor m, Applicative m, Monad m) =>+  s ->+  (s -> Declaration       -> m (s, Declaration)) ->+  (s -> Value             -> m (s, Value)) ->+  (s -> Binder            -> m (s, Binder)) ->+  (s -> CaseAlternative   -> m (s, CaseAlternative)) ->+  (s -> DoNotationElement -> m (s, DoNotationElement)) ->+  ( Declaration       -> m Declaration+  , Value             -> m Value+  , Binder            -> m Binder+  , CaseAlternative   -> m CaseAlternative+  , DoNotationElement -> m DoNotationElement)+everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)+  where+  f'' s = uncurry f' <=< f s++  f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f'' s) ds+  f' s (ValueDeclaration name nameKind bs grd val) = ValueDeclaration name nameKind <$> mapM (h'' s) bs <*> maybeM (g'' s) grd <*> g'' s val+  f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (thirdM (g'' s)) ds+  f' s (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f'' s) ds+  f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f'' s) ds+  f' s (PositionedDeclaration pos d1) = PositionedDeclaration pos <$> f'' s d1+  f' _ other = return other++  g'' s = uncurry g' <=< g s++  g' s (UnaryMinus v) = UnaryMinus <$> g'' s v+  g' s (BinaryNoParens op v1 v2) = BinaryNoParens op <$> g'' s v1 <*> g'' s v2+  g' s (Parens v) = Parens <$> g'' s v+  g' s (ArrayLiteral vs) = ArrayLiteral <$> mapM (g'' s) vs+  g' s (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g'' s)) vs+  g' s (Accessor prop v) = Accessor prop <$> g'' s v+  g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> mapM (sndM (g'' s)) vs+  g' s (Abs name v) = Abs name <$> g'' s v+  g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2+  g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3+  g' s (Case vs alts) = Case <$> mapM (g'' s) vs <*> mapM (i'' s) alts+  g' s (TypedValue check v ty) = TypedValue check <$> g'' s v <*> pure ty+  g' s (Let ds v) = Let <$> mapM (f'' s) ds <*> g'' s v+  g' s (Do es) = Do <$> mapM (j'' s) es+  g' s (PositionedValue pos v) = PositionedValue pos <$> g'' s v+  g' _ other = return other++  h'' s = uncurry h' <=< h s++  h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM (h'' s) bs+  h' s (ObjectBinder bs) = ObjectBinder <$> mapM (sndM (h'' s)) bs+  h' s (ArrayBinder bs) = ArrayBinder <$> mapM (h'' s) bs+  h' s (ConsBinder b1 b2) = ConsBinder <$> h'' s b1 <*> h'' s b2+  h' s (NamedBinder name b) = NamedBinder name <$> h'' s b+  h' s (PositionedBinder pos b) = PositionedBinder pos <$> h'' s b+  h' _ other = return other++  i'' s = uncurry i' <=< i s++  i' s (CaseAlternative bs grd val) = CaseAlternative <$> mapM (h'' s) bs <*> maybeM (g'' s) grd <*> g'' s val++  j'' s = uncurry j' <=< j s++  j' s (DoNotationValue v) = DoNotationValue <$> g'' s v+  j' s (DoNotationBind b v) = DoNotationBind <$> h'' s b <*> g'' s v+  j' s (DoNotationLet ds) = DoNotationLet <$> mapM (f'' s) ds+  j' s (PositionedDoNotationElement pos e1) = PositionedDoNotationElement pos <$> j'' s e1++accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Value -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)+accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)+  where+  forDecls (DataDeclaration _ _ dctors) = mconcat (concatMap (map f . snd) dctors)+  forDecls (ExternDeclaration _ _ _ ty) = f ty+  forDecls (ExternInstanceDeclaration _ cs _ tys) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)+  forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . snd) implies)+  forDecls (TypeInstanceDeclaration _ cs _ tys _) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)+  forDecls (TypeSynonymDeclaration _ _ ty) = f ty+  forDecls (TypeDeclaration _ ty) = f ty+  forDecls _ = mempty++  forValues (TypeClassDictionary _ (_, cs) _) = mconcat (map f cs)+  forValues (SuperClassDictionary _ tys) = mconcat (map f tys)+  forValues (TypedValue _ _ ty) = f ty+  forValues _ = mempty++

@@ -17,13 +17,13 @@   ModuleGraph ) where -import Data.Data import Data.Graph-import Data.Generics import Data.List (nub)+import Data.Maybe (mapMaybe)  import Language.PureScript.Declarations import Language.PureScript.Names+import Language.PureScript.Types  -- | -- A list of modules with their dependencies@@ -37,7 +37,7 @@ -- sortModules :: [Module] -> Either String ([Module], ModuleGraph) sortModules ms = do-  let verts = map (\m -> (m, getModuleName m, usedModules m)) ms+  let verts = map (\m@(Module _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms   ms' <- mapM toModule $ stronglyConnComp verts   let moduleGraph = map (\(_, mn, deps) -> (mn, deps)) verts   return (ms', moduleGraph)@@ -45,19 +45,24 @@ -- | -- Calculate a list of used modules based on explicit imports and qualified names ---usedModules :: (Data d) => d -> [ModuleName]-usedModules = nub . everything (++) (mkQ [] qualifiedIdents `extQ` qualifiedProperNames `extQ` imports)+usedModules :: Declaration -> [ModuleName]+usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (const []) (const []) (const []) in nub . f   where-  qualifiedIdents :: Qualified Ident -> [ModuleName]-  qualifiedIdents (Qualified (Just mn) _) = [mn]-  qualifiedIdents _ = []-  qualifiedProperNames :: Qualified ProperName -> [ModuleName]-  qualifiedProperNames (Qualified (Just mn) _) = [mn]-  qualifiedProperNames _ = []-  imports :: Declaration -> [ModuleName]-  imports (ImportDeclaration mn _ _) = [mn]-  imports (PositionedDeclaration _ d) = imports d-  imports _ = []+  forDecls :: Declaration -> [ModuleName]+  forDecls (ImportDeclaration mn _ _) = [mn]+  forDecls _ = []++  forValues :: Value -> [ModuleName]+  forValues (Var (Qualified (Just mn) _)) = [mn]+  forValues (BinaryNoParens (Qualified (Just mn) _) _ _) = [mn]+  forValues (Constructor (Qualified (Just mn) _)) = [mn]+  forValues (TypedValue _ _ ty) = forTypes ty+  forValues _ = []++  forTypes :: Type -> [ModuleName]+  forTypes (TypeConstructor (Qualified (Just mn) _)) = [mn]+  forTypes (ConstrainedType cs _) = mapMaybe (\(Qualified mn _, _) -> mn) cs+  forTypes _ = []  getModuleName :: Module -> ModuleName getModuleName (Module mn _ _) = mn

@@ -14,49 +14,71 @@ -----------------------------------------------------------------------------  module Language.PureScript.Scope (-    usedNames,+    usedNamesDecl,+    usedNamesValue,+    usedNamesBinder,+    usedNamesCaseAlternative,+    usedNamesDoNotationElement,     unusedNames ) where -import Control.Applicative ((<$>))--import Data.Data import Data.List ((\\), nub)-import Data.Generics (extQ, mkQ, everything)  import Language.PureScript.Declarations import Language.PureScript.Names-import Language.PureScript.CodeGen.JS.AST +usedNames :: (Declaration -> [Ident], Value -> [Ident], Binder -> [Ident], CaseAlternative -> [Ident], DoNotationElement -> [Ident])+usedNames = everythingOnValues (++) f g h (const []) (const [])+  where+  f :: Declaration -> [Ident]+  f (ValueDeclaration name _ _ _ _) = [name]+  f _ = []++  g :: Value -> [Ident]+  g (Abs (Left arg) _) = [arg]+  g (Var (Qualified Nothing name)) = [name]+  g _ = []++  h :: Binder -> [Ident]+  h (VarBinder name) = [name]+  h _ = []+ -- |+-- Gather all used names appearing inside a declaration+--+usedNamesDecl :: Declaration -> [Ident]+usedNamesDecl = let (f, _, _, _, _) = usedNames in nub . f++-- | -- Gather all used names appearing inside a value ---usedNames :: (Data d) => d -> [Ident]-usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesB `extQ` namesJS) val-  where-  namesV :: Value -> [Ident]-  namesV (Abs (Left arg) _) = [arg]-  namesV (Var (Qualified Nothing name)) = [name]-  namesV _ = []-  namesB :: Binder -> [Ident]-  namesB (VarBinder name) = [name]-  namesB _ = []-  namesJS :: JS -> [Ident]-  namesJS (JSVar name) = [Ident name]-  namesJS (JSFunction (Just name) args _) = Ident name : (Ident <$> args)-  namesJS (JSFunction Nothing args _) = Ident <$> args-  namesJS (JSVariableIntroduction name _) = [Ident name]-  namesJS (JSFor name _ _ _) = [Ident name]-  namesJS (JSForIn name _ _) = [Ident name]-  namesJS _ = []+usedNamesValue :: Value -> [Ident]+usedNamesValue = let (_, f, _, _, _) = usedNames in nub . f  -- |+-- Gather all used names appearing inside a binder+--+usedNamesBinder :: Binder -> [Ident]+usedNamesBinder = let (_, _, f, _, _) = usedNames in nub . f++-- |+-- Gather all used names appearing inside a case alternative+--+usedNamesCaseAlternative :: CaseAlternative -> [Ident]+usedNamesCaseAlternative = let (_, _, _, f, _) = usedNames in nub . f++-- |+-- Gather all used names appearing inside a do notation element+--+usedNamesDoNotationElement :: DoNotationElement -> [Ident]+usedNamesDoNotationElement = let (_, _, _, _, f) = usedNames in nub . f++-- | -- Generate a set of names which are unused inside a value, of the form @_{n}@ for an integer @n@ ---unusedNames :: (Data d) => d -> [Ident]-unusedNames val =+unusedNames :: [Ident] -> [Ident]+unusedNames allNames =   let-    allNames = usedNames val     varNames = map (Ident . ('_' :) . show) ([1..] :: [Int])   in     varNames \\ allNames

@@ -49,7 +49,7 @@ -- desugar :: [Module] -> Either ErrorStack [Module] desugar = map removeSignedLiterals-          >>> desugarDo+          >>> mapM desugarDoModule           >=> desugarCasesModule           >=> desugarTypeDeclarationsModule           >=> desugarImports

@@ -21,10 +21,7 @@     collapseBindingGroupsModule ) where -import Data.Data import Data.Graph-import Data.Generics-import Data.Generics.Extras import Data.List (nub, intersect) import Data.Maybe (isJust, mapMaybe) import Control.Applicative ((<$>), (<*>), pure)@@ -70,7 +67,9 @@            bindingGroupDecls  createBindingGroupsForValue :: ModuleName -> Declaration -> Either ErrorStack Declaration-createBindingGroupsForValue moduleName = everywhereM' (mkM go)+createBindingGroupsForValue moduleName =+  let (f, _, _) = everywhereOnValuesTopDownM return go return+  in f   where   go (Let ds val) = Let <$> createBindingGroups moduleName ds <*> pure val   go other = return other@@ -90,16 +89,20 @@ collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val collapseBindingGroupsForValue other = other -usedIdents :: (Data d) => ModuleName -> d -> [Ident]-usedIdents moduleName = nub . everything (++) (mkQ [] usedNames)+usedIdents :: ModuleName -> Declaration -> [Ident]+usedIdents moduleName =+  let (f, _, _, _, _) = everythingOnValues (++) (const []) usedNames (const []) (const []) (const [])+  in nub . f   where   usedNames :: Value -> [Ident]   usedNames (Var (Qualified Nothing name)) = [name]   usedNames (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]   usedNames _ = [] -usedProperNames :: (Data d) => ModuleName -> d -> [ProperName]-usedProperNames moduleName = nub . everything (++) (mkQ [] usedNames)+usedProperNames :: ModuleName -> Declaration -> [ProperName]+usedProperNames moduleName =+  let (f, _, _, _, _) = accumTypes (everythingOnTypes (++) usedNames)+  in nub . f   where   usedNames :: Type -> [ProperName]   usedNames (ConstrainedType constraints _) = flip mapMaybe constraints $ \qual ->

@@ -21,8 +21,6 @@  import Data.Monoid ((<>)) import Data.List (groupBy)-import Data.Generics (mkM)-import Data.Generics.Extras  import Control.Applicative import Control.Monad ((<=<), forM, join, unless)@@ -49,7 +47,8 @@    replace (Abs (Right binder) val) =     let-      ident = head $ unusedNames (binder, val)+      used = usedNamesBinder binder ++ usedNamesValue val+      ident = head $ unusedNames used     in       Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing val]   replace other = other@@ -63,8 +62,9 @@     desugarRest :: [Declaration] -> Either ErrorStack [Declaration]     desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =       (:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest-    desugarRest (ValueDeclaration name nameKind bs g val : rest) = do-      (:) <$> (ValueDeclaration name nameKind bs g <$> everywhereM' (mkM go) val) <*> desugarRest rest+    desugarRest (ValueDeclaration name nameKind bs g val : rest) =+      let (_, f, _) = everywhereOnValuesTopDownM return go return+      in (:) <$> (ValueDeclaration name nameKind bs g <$> f val) <*> desugarRest rest       where       go (Let ds val') = Let <$> desugarCases ds <*> pure val'       go other = return other@@ -108,7 +108,8 @@ makeCaseDeclaration ident alternatives =   let     argPattern = length . fst . head $ alternatives-    args = take argPattern $ unusedNames (ident, alternatives)+    args = take argPattern $ unusedNames used+    used = concatMap (\(bs, (grd, val)) -> concatMap usedNamesBinder bs ++ maybe [] usedNamesValue grd ++ usedNamesValue val) alternatives     vars = map (Var . Qualified Nothing) args     binders = [ CaseAlternative bs g val | (bs, (g, val)) <- alternatives ]     value = foldr (Abs . Left) (Case vars binders) args

@@ -15,12 +15,9 @@ -----------------------------------------------------------------------------  module Language.PureScript.Sugar.DoNotation (-    desugarDo+    desugarDoModule ) where -import Data.Data-import Data.Generics- import Language.PureScript.Names import Language.PureScript.Scope import Language.PureScript.Declarations@@ -34,16 +31,24 @@ -- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function, -- and all @DoNotationLet@ constructors with let expressions. ---desugarDo :: (Data d) => d -> Either ErrorStack d-desugarDo = everywhereM (mkM replace)+desugarDoModule :: Module -> Either ErrorStack Module+desugarDoModule (Module mn ds exts) = Module mn <$> mapM desugarDo ds <*> pure exts++desugarDo :: Declaration -> Either ErrorStack Declaration+desugarDo =+  let (f, _, _) = everywhereOnValuesM return replace return+  in f   where   prelude :: ModuleName   prelude = ModuleName [ProperName C.prelude]+   bind :: Value   bind = Var (Qualified (Just prelude) (Op (C.>>=)))+   replace :: Value -> Either ErrorStack Value   replace (Do els) = go els   replace other = return other+   go :: [DoNotationElement] -> Either ErrorStack Value   go [] = error "The impossible happened in desugarDo"   go [DoNotationValue val] = return val@@ -57,7 +62,8 @@     return $ App (App bind val) (Abs (Left ident) rest')   go (DoNotationBind binder val : rest) = do     rest' <- go rest-    let ident = head $ unusedNames rest'+    let used = concatMap usedNamesDoNotationElement rest+        ident = head $ unusedNames used     return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing rest']))   go [DoNotationLet _] = Left $ mkErrorStack "Let statement cannot be the last statement in a do block" Nothing   go (DoNotationLet ds : rest) = do

@@ -16,10 +16,8 @@   desugarImports ) where -import Data.Data import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Monoid ((<>))-import Data.Generics.Extras (mkS, extS, everywhereWithContextM')  import Control.Applicative (Applicative(..), (<$>), (<*>)) import Control.Monad.Error@@ -31,6 +29,7 @@ import Language.PureScript.Types import Language.PureScript.Environment import Language.PureScript.Errors+import Language.PureScript.Traversals  -- | -- The global export environment - every declaration exported from every module.@@ -177,83 +176,67 @@ renameInModule imports exports (Module mn decls exps) =   Module mn <$> mapM go decls <*> pure exps   where-  go :: Declaration -> Either ErrorStack Declaration-  go (PositionedDeclaration pos d) = rethrowWithPosition pos $ PositionedDeclaration pos <$> go d-  go (DataDeclaration name args dctors) =-      rethrow (strMsg ("Error in data declaration " ++ show name) <>) $-        DataDeclaration <$> pure name <*> pure args <*> updateAll dctors-  go (DataBindingGroupDeclaration decls') =-      DataBindingGroupDeclaration <$> mapM go decls'-  go (TypeSynonymDeclaration name ps ty) =-      rethrow (strMsg ("Error in type synonym " ++ show name) <>) $-        TypeSynonymDeclaration <$> pure name <*> pure ps <*> updateType' ty-  go (TypeClassDeclaration className args implies ds) =-    TypeClassDeclaration className args <$> updateConstraints Nothing implies <*> mapM go ds-  go (TypeInstanceDeclaration name cs cn ts ds) =-      TypeInstanceDeclaration name <$> updateConstraints Nothing cs <*> updateClassName cn Nothing <*> updateType' ts <*> mapM go ds-  go (ExternInstanceDeclaration name cs cn ts) =-      ExternInstanceDeclaration name <$> updateConstraints Nothing cs <*> updateClassName cn Nothing <*> updateType' ts-  go (ValueDeclaration name nameKind [] Nothing val) = do-    val' <- everywhereWithContextM' (Nothing, []) (mkS bindFunctionArgs `extS` bindBinders) val-    rethrow (strMsg ("Error in declaration " ++ show name) <>) $-      ValueDeclaration name nameKind [] Nothing <$> updateAll val'-    where-    bindFunctionArgs :: (Maybe SourcePos, [Ident]) -> Value -> Either ErrorStack ((Maybe SourcePos, [Ident]), Value)-    bindFunctionArgs (_, bound) v@(PositionedValue pos' _) = return ((Just pos', bound), v)-    bindFunctionArgs (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')-    bindFunctionArgs (pos, bound) (Let ds val') =-      let args = mapMaybe letBoundVariable ds-      in return ((pos, args ++ bound), Let ds val')-    bindFunctionArgs (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =-      (,) (pos, bound) <$> (Var <$> updateValueName name' pos)-    bindFunctionArgs (pos, bound) (Var name'@(Qualified (Just _) _)) =-      (,) (pos, bound) <$> (Var <$> updateValueName name' pos)-    bindFunctionArgs (pos, bound) (BinaryNoParens name'@(Qualified Nothing ident) v1 v2) | ident `notElem` bound =-      (,) (pos, bound) <$> (BinaryNoParens <$> updateValueName name' pos <*> pure v1 <*> pure v2)-    bindFunctionArgs (pos, bound) (BinaryNoParens name'@(Qualified (Just _) _) v1 v2) =-      (,) (pos, bound) <$> (BinaryNoParens <$> updateValueName name' pos <*> pure v1 <*> pure v2)-    bindFunctionArgs pb other = return (pb, other)--    bindBinders :: (Maybe SourcePos, [Ident]) -> CaseAlternative -> Either ErrorStack ((Maybe SourcePos, [Ident]), CaseAlternative)-    bindBinders (pos, bound) c@(CaseAlternative bs _ _) = return ((pos, concatMap binderNames bs ++ bound), c)+  (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS -    letBoundVariable :: Declaration -> Maybe Ident-    letBoundVariable (ValueDeclaration ident _ _ _ _) = Just ident-    letBoundVariable (PositionedDeclaration _ d) = letBoundVariable d-    letBoundVariable _ = Nothing-  go (ValueDeclaration name _ _ _ _) = error $ "Binders should have been desugared in " ++ show name-  go (ExternDeclaration fit name js ty) =-      rethrow (strMsg ("Error in declaration " ++ show name) <>) $-        ExternDeclaration <$> pure fit <*> pure name <*> pure js <*> updateType' ty-  go (BindingGroupDeclaration decls') = BindingGroupDeclaration <$> mapM go' decls'-      where-      go' (name, nk, value) = rethrow (strMsg ("Error in declaration " ++ show name) <>) $-                                (,,) <$> pure name <*> pure nk <*> updateAll value-  go d = updateAll d+  updateDecl :: (Maybe SourcePos, [Ident]) -> Declaration -> Either ErrorStack ((Maybe SourcePos, [Ident]), Declaration)+  updateDecl (_, bound) d@(PositionedDeclaration pos _) = return ((Just pos, bound), d)+  updateDecl (pos, bound) (DataDeclaration name args dctors) =+    (,) (pos, bound) <$> (DataDeclaration name args <$> mapM (sndM (mapM (updateTypesEverywhere pos))) dctors)+  updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) =+    (,) (pos, bound) <$> (TypeSynonymDeclaration name ps <$> updateTypesEverywhere pos ty)+  updateDecl (pos, bound) (TypeClassDeclaration className args implies ds) =+    (,) (pos, bound) <$> (TypeClassDeclaration className args <$> updateConstraints pos implies <*> pure ds)+  updateDecl (pos, bound) (TypeInstanceDeclaration name cs cn ts ds) =+    (,) (pos, bound) <$> (TypeInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn pos <*> mapM (updateTypesEverywhere pos) ts <*> pure ds)+  updateDecl (pos, bound) (ExternInstanceDeclaration name cs cn ts) =+    (,) (pos, bound) <$> (ExternInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn Nothing <*> mapM (updateTypesEverywhere pos) ts)+  updateDecl (pos, bound) (TypeDeclaration name ty) =+    (,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty)+  updateDecl (pos, bound) (ExternDeclaration fit name js ty) =+    (,) (pos, name : bound) <$> (ExternDeclaration fit name js <$> updateTypesEverywhere pos ty)+  updateDecl s d = return (s, d) -  updateAll :: Data d => d -> Either ErrorStack d-  updateAll = everywhereWithContextM' Nothing (mkS updateType `extS` updateValue `extS` updateBinder)+  updateValue :: (Maybe SourcePos, [Ident]) -> Value -> Either ErrorStack ((Maybe SourcePos, [Ident]), Value)+  updateValue (_, bound) v@(PositionedValue pos' _) = return ((Just pos', bound), v)+  updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')+  updateValue (pos, bound) (Let ds val') =+      let args = mapMaybe letBoundVariable ds+      in return ((pos, args ++ bound), Let ds val')+  updateValue (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =+    (,) (pos, bound) <$> (Var <$> updateValueName name' pos)+  updateValue (pos, bound) (Var name'@(Qualified (Just _) _)) =+    (,) (pos, bound) <$> (Var <$> updateValueName name' pos)+  updateValue (pos, bound) (BinaryNoParens name'@(Qualified Nothing ident) v1 v2) | ident `notElem` bound =+    (,) (pos, bound) <$> (BinaryNoParens <$> updateValueName name' pos <*> pure v1 <*> pure v2)+  updateValue (pos, bound) (BinaryNoParens name'@(Qualified (Just _) _) v1 v2) =+    (,) (pos, bound) <$> (BinaryNoParens <$> updateValueName name' pos <*> pure v1 <*> pure v2)+  updateValue s@(pos, _) (Constructor name) = (,) s <$> (Constructor <$> updateDataConstructorName name pos)+  updateValue s@(pos, _) (TypedValue check val ty) = (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)+  updateValue s v = return (s, v) -  updateValue :: Maybe SourcePos -> Value -> Either ErrorStack (Maybe SourcePos, Value)-  updateValue _ v@(PositionedValue pos _) = return (Just pos, v)-  updateValue pos (Constructor name) = (,) <$> pure pos <*> (Constructor <$> updateDataConstructorName name pos)-  updateValue pos v = return (pos, v)+  updateBinder :: (Maybe SourcePos, [Ident]) -> Binder -> Either ErrorStack ((Maybe SourcePos, [Ident]), Binder)+  updateBinder (_, bound) v@(PositionedBinder pos _) = return ((Just pos, bound), v)+  updateBinder s@(pos, _) (ConstructorBinder name b) = (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)+  updateBinder s v = return (s, v) -  updateBinder :: Maybe SourcePos -> Binder -> Either ErrorStack (Maybe SourcePos, Binder)-  updateBinder _ v@(PositionedBinder pos _) = return (Just pos, v)-  updateBinder pos (ConstructorBinder name b) = (,) <$> pure pos <*> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)-  updateBinder pos v = return (pos, v)+  updateCase :: (Maybe SourcePos, [Ident]) -> CaseAlternative -> Either ErrorStack ((Maybe SourcePos, [Ident]), CaseAlternative)+  updateCase (pos, bound) c@(CaseAlternative bs _ _) = return ((pos, concatMap binderNames bs ++ bound), c) -  updateType :: Maybe SourcePos -> Type -> Either ErrorStack (Maybe SourcePos, Type)-  updateType pos (TypeConstructor name) = (,) <$> pure pos <*> (TypeConstructor <$> updateTypeName name pos)-  updateType pos (SaturatedTypeSynonym name tys) = (,) <$> pure pos <*> (SaturatedTypeSynonym <$> updateTypeName name pos <*> updateType' tys)-  updateType pos (ConstrainedType cs t) = (,) <$> pure pos <*> (ConstrainedType <$> updateConstraints pos cs <*> pure t)-  updateType pos t = return (pos, t)+  letBoundVariable :: Declaration -> Maybe Ident+  letBoundVariable (ValueDeclaration ident _ _ _ _) = Just ident+  letBoundVariable (PositionedDeclaration _ d) = letBoundVariable d+  letBoundVariable _ = Nothing -  updateType' :: Data d => d -> Either ErrorStack d-  updateType' = everywhereWithContextM' Nothing (mkS updateType)+  updateTypesEverywhere :: Maybe SourcePos -> Type -> Either ErrorStack Type+  updateTypesEverywhere pos0 = everywhereOnTypesM (updateType pos0)+    where+    updateType :: Maybe SourcePos -> Type -> Either ErrorStack Type+    updateType pos (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos+    updateType pos (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name pos <*> pure tys+    updateType pos (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t+    updateType _ t = return t -  updateConstraints pos = mapM (\(name, ts) -> (,) <$> updateClassName name pos <*> pure ts)+  updateConstraints pos = mapM (\(name, ts) -> (,) <$> updateClassName name pos <*> mapM (updateTypesEverywhere pos) ts)    updateTypeName = update "type" importedTypes (\mes -> isJust . (`lookup` exportedTypes mes))   updateClassName = update "type class" importedTypeClasses (flip elem . exportedTypeClasses)

@@ -37,10 +37,6 @@ import Data.Functor.Identity import Data.List (groupBy, sortBy) -import qualified Data.Data as D-import qualified Data.Generics as G-import qualified Data.Generics.Extras as G- import qualified Text.Parsec as P import qualified Text.Parsec.Pos as P import qualified Text.Parsec.Expr as P@@ -57,7 +53,6 @@   let opTable = customOperatorTable $ map (\(i, _, f) -> (i, f)) fixities   mapM (rebracketModule opTable) ms - removeSignedLiterals :: Module -> Module removeSignedLiterals (Module mn ds exts) = Module mn (map f' ds) exts   where@@ -69,10 +64,14 @@   go other = other  rebracketModule :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Module -> Either ErrorStack Module-rebracketModule opTable (Module mn ds exts) = Module mn <$> (removeParens <$> G.everywhereM' (G.mkM (matchOperators opTable)) ds) <*> pure exts+rebracketModule opTable (Module mn ds exts) =+  let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return+  in Module mn <$> (map removeParens <$> mapM f ds) <*> pure exts -removeParens :: (D.Data d) => d -> d-removeParens = G.everywhere (G.mkT go)+removeParens :: Declaration -> Declaration+removeParens =+  let (f, _, _) = everywhereOnValues id go id+  in f   where   go (Parens val) = val   go val = val

@@ -19,8 +19,6 @@     desugarTypeDeclarationsModule ) where -import Data.Generics (mkM)-import Data.Generics.Extras import Data.Monoid ((<>))  import Control.Applicative@@ -59,7 +57,8 @@   fromValueDeclaration _ = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing desugarTypeDeclarations (TypeDeclaration name _ : []) = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing desugarTypeDeclarations (ValueDeclaration name nameKind bs g val : rest) = do-  (:) <$> (ValueDeclaration name nameKind bs g <$> everywhereM' (mkM go) val) <*> desugarTypeDeclarations rest+  let (_, f, _) = everywhereOnValuesTopDownM return go return+  (:) <$> (ValueDeclaration name nameKind bs g <$> f val) <*> desugarTypeDeclarations rest   where   go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val'   go other = return other

@@ -0,0 +1,34 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Traversals+-- Copyright   :  (c) 2014 Phil Freeman+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- | Common functions for implementing generic traversals+--+-----------------------------------------------------------------------------++module Language.PureScript.Traversals where++import Control.Applicative++fstM :: (Functor f) => (a -> f c) -> (a, b) -> f (c, b)+fstM f (a, b) = flip (,) b <$> f a++sndM :: (Functor f) => (b -> f c) -> (a, b) -> f (a, c)+sndM f (a, b) = (,) a <$> f b++thirdM :: (Functor f) => (c -> f d) -> (a, b, c) -> f (a, b, d)+thirdM f (a, b, c) = (,,) a b <$> f c++maybeM :: (Applicative f) => (a -> f b) -> Maybe a -> f (Maybe b)+maybeM _ Nothing = pure Nothing+maybeM f (Just a) = Just <$> f a++defS :: (Monad m) => st -> val -> m (st, val)+defS s val = return (s, val)+

@@ -43,9 +43,9 @@  import Data.List import Data.Maybe (maybeToList, isNothing, isJust, fromMaybe)-import Data.Generics-       (everythingWithContext, mkM, something, mkQ)-import Data.Generics.Extras+import Data.Function (on)+import Data.Ord (comparing)+import Data.Monoid  import Language.PureScript.Declarations import Language.PureScript.Types@@ -69,9 +69,6 @@  import qualified Data.Map as M import qualified Data.HashMap.Strict as H-import Data.Function (on)-import Data.Ord (comparing)-import Data.Monoid ((<>))  instance Partial Type where   unknown = TUnknown@@ -273,7 +270,9 @@ -- Replace type class dictionary placeholders with inferred type class dictionaries -- replaceTypeClassDictionaries :: ModuleName -> Value -> Check Value-replaceTypeClassDictionaries mn = everywhereM' (mkM go)+replaceTypeClassDictionaries mn =+  let (_, f, _) = everywhereOnValuesTopDownM return go return+  in f   where   go (TypeClassDictionary trySuperclasses constraint dicts) = do     env <- getEnv@@ -461,27 +460,32 @@   -- We traverse the tree top-down, and collect any SkolemScopes introduced by ForAlls.   -- If a Skolem is encountered whose SkolemScope is not in the current list, we have found   -- an escaped skolem variable.-  case everythingWithContext [] (++) (mkQ ((,) []) go) root of-    [] -> return ()-    ((binding, val) : _) -> throwError $ mkErrorStack ("Rigid/skolem type variable " ++ maybe "" (("bound by " ++) . prettyPrintValue) binding ++ " has escaped.") (Just (ValueError val))+  let (_, f, _, _, _) = everythingWithContextOnValues [] [] (++) def go def def def+  in case f root of+       [] -> return ()+       ((binding, val) : _) -> throwError $ mkErrorStack ("Rigid/skolem type variable " ++ maybe "" (("bound by " ++) . prettyPrintValue) binding ++ " has escaped.") (Just (ValueError val))   where-  go :: Value -> [(SkolemScope, Value)] -> ([(Maybe Value, Value)], [(SkolemScope, Value)])-  go val@(TypedValue _ _ (ForAll _ _ (Just sco))) scos = ([], (sco, val) : scos)-  go val@(TypedValue _ _ ty) scos = case collectSkolems ty \\ map fst scos of-                                      (sco : _) -> ([(findBindingScope sco, val)], scos)-                                      _ -> ([], scos)+  def s _ = (s, [])++  go :: [(SkolemScope, Value)] -> Value -> ([(SkolemScope, Value)], [(Maybe Value, Value)])+  go scos val@(TypedValue _ _ (ForAll _ _ (Just sco))) = ((sco, val) : scos, [])+  go scos val@(TypedValue _ _ ty) = case collectSkolems ty \\ map fst scos of+                                      (sco : _) -> (scos, [(findBindingScope sco, val)])+                                      _ -> (scos, [])     where     collectSkolems :: Type -> [SkolemScope]     collectSkolems = nub . everythingOnTypes (++) collect       where       collect (Skolem _ _ scope) = [scope]       collect _ = []-  go _ scos = ([], scos)+  go scos _ = (scos, [])   findBindingScope :: SkolemScope -> Maybe Value-  findBindingScope sco = something (mkQ Nothing go') root+  findBindingScope sco =+    let (_, f, _, _, _) = everythingOnValues mappend (const mempty) go' (const mempty) (const mempty) (const mempty)+    in getFirst $ f root     where-    go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = Just val-    go' _ = Nothing+    go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = First (Just val)+    go' _ = mempty skolemEscapeCheck val = throwError $ mkErrorStack "Untyped value passed to skolemEscapeCheck" (Just (ValueError val))  -- |

@@ -26,6 +26,7 @@ import Control.Monad ((<=<))  import Language.PureScript.Names+import Language.PureScript.Traversals  -- | -- An identifier for the scope of a skolem variable@@ -231,9 +232,6 @@   go (PrettyPrintObject t) = PrettyPrintObject (go (f t))   go (PrettyPrintForAll args t) = PrettyPrintForAll args (go (f t))   go other = f other--sndM :: (Functor f) => (b -> f c) -> (a, b) -> f (a, c)-sndM f (a, b) = (,) a <$> f b  everywhereOnTypesM :: (Functor m, Applicative m, Monad m) => (Type -> m Type) -> Type -> m Type everywhereOnTypesM f = go