summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-04-17 04:34:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-04-17 04:34:00 (GMT)
commit2e5f2b2995a5ce55b52c8167e027682c11f101f4 (patch)
treecc0ff0d322f6c595b32b6b397db759b6df404466
parent04b3be14a6ecb9f962b1d812dd1d6bcced9893d9 (diff)
version 0.4.190.4.19
-rw-r--r--purescript.cabal16
-rw-r--r--src/Data/Generics/Extras.hs73
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs30
-rw-r--r--src/Language/PureScript/DeadCodeElimination.hs8
-rw-r--r--src/Language/PureScript/Declarations.hs314
-rw-r--r--src/Language/PureScript/ModuleDependencies.hs35
-rw-r--r--src/Language/PureScript/Scope.hs76
-rw-r--r--src/Language/PureScript/Sugar.hs2
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs19
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs13
-rw-r--r--src/Language/PureScript/Sugar/DoNotation.hs20
-rw-r--r--src/Language/PureScript/Sugar/Names.hs135
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs17
-rw-r--r--src/Language/PureScript/Sugar/TypeDeclarations.hs5
-rw-r--r--src/Language/PureScript/Traversals.hs34
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs42
-rw-r--r--src/Language/PureScript/Types.hs4
17 files changed, 576 insertions, 267 deletions
diff --git a/purescript.cabal b/purescript.cabal
index 910fff2..3ec910c 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -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 @@ data-dir: ""
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 @@ library
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 @@ library
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
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 psc-make
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 @@ executable hierarchy
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
diff --git a/src/Data/Generics/Extras.hs b/src/Data/Generics/Extras.hs
deleted file mode 100644
index adf9892..0000000
--- a/src/Data/Generics/Extras.hs
+++ /dev/null
@@ -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')
-
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 1df88c7..fa1f404 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -26,7 +26,6 @@ module Language.PureScript.CodeGen.JS (
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 Control.Monad (replicateM, forM)
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.Optimizer
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 @@ importToJs mt opts mn = JSVariableIntroduction (moduleNameToJs mn) (Just moduleB
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 @@ valueToJs _ _ _ _ = error "Invalid argument to valueToJs"
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 @@ qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)
-- 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 @@ bindersToJs opts m e binders vals = runGen (map identToJs (unusedNames (binders,
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 @@ isOnlyConstructor e ctor =
numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors e
typeConstructor (Qualified (Just moduleName) _, (tyCtor, _)) = (moduleName, tyCtor)
typeConstructor _ = error "Invalid argument to isOnlyConstructor"
+
diff --git a/src/Language/PureScript/DeadCodeElimination.hs b/src/Language/PureScript/DeadCodeElimination.hs
index 81cd769..3357125 100644
--- a/src/Language/PureScript/DeadCodeElimination.hs
+++ b/src/Language/PureScript/DeadCodeElimination.hs
@@ -16,10 +16,8 @@ module Language.PureScript.DeadCodeElimination (
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 @@ declarationsByModule (Module moduleName ds _) = concatMap go ds
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)]
diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs
index 8d3e554..5e9d307 100644
--- a/src/Language/PureScript/Declarations.hs
+++ b/src/Language/PureScript/Declarations.hs
@@ -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 @@ everywhereOnValues f g h = (f', g', h')
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
+
+
diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs
index 78c716f..6c23255 100644
--- a/src/Language/PureScript/ModuleDependencies.hs
+++ b/src/Language/PureScript/ModuleDependencies.hs
@@ -17,13 +17,13 @@ module Language.PureScript.ModuleDependencies (
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 @@ type ModuleGraph = [(ModuleName, [ModuleName])]
--
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 @@ sortModules ms = do
-- |
-- 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
diff --git a/src/Language/PureScript/Scope.hs b/src/Language/PureScript/Scope.hs
index fea0e65..50cf065 100644
--- a/src/Language/PureScript/Scope.hs
+++ b/src/Language/PureScript/Scope.hs
@@ -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
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index 51e2a83..b2db77a 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -49,7 +49,7 @@ import Control.Category ((>>>))
--
desugar :: [Module] -> Either ErrorStack [Module]
desugar = map removeSignedLiterals
- >>> desugarDo
+ >>> mapM desugarDoModule
>=> desugarCasesModule
>=> desugarTypeDeclarationsModule
>=> desugarImports
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index 9b89ed3..e4c587b 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -21,10 +21,7 @@ module Language.PureScript.Sugar.BindingGroups (
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 @@ createBindingGroups moduleName ds = do
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 :: Value -> Value
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 ->
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index 986a179..c8a97b4 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -21,8 +21,6 @@ module Language.PureScript.Sugar.CaseDeclarations (
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 @@ desugarAbs = map f
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 @@ desugarCases = desugarRest <=< fmap join . mapM toDecls . groupBy inSameGroup
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 -> [([Binder], (Maybe Guard, Value))] -> Declaratio
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
diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs
index 5f5d3e6..fc665e3 100644
--- a/src/Language/PureScript/Sugar/DoNotation.hs
+++ b/src/Language/PureScript/Sugar/DoNotation.hs
@@ -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 @@ import Control.Applicative
-- 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 @@ desugarDo = everywhereM (mkM replace)
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
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index 1b28d1b..7af9be4 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -16,10 +16,8 @@ module Language.PureScript.Sugar.Names (
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.Names
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 :: ImportEnvironment -> ExportEnvironment -> Module -> Either Err
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') =
+ (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS
+
+ 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)
+
+ 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')
- 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)
-
- 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
-
- updateAll :: Data d => d -> Either ErrorStack d
- updateAll = everywhereWithContextM' Nothing (mkS updateType `extS` updateValue `extS` updateBinder)
-
- 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 -> 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)
-
- 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)
-
- updateType' :: Data d => d -> Either ErrorStack d
- updateType' = everywhereWithContextM' Nothing (mkS updateType)
+ 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)
+
+ 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)
+
+ updateCase :: (Maybe SourcePos, [Ident]) -> CaseAlternative -> Either ErrorStack ((Maybe SourcePos, [Ident]), CaseAlternative)
+ updateCase (pos, bound) c@(CaseAlternative bs _ _) = return ((pos, concatMap binderNames bs ++ bound), c)
+
+ letBoundVariable :: Declaration -> Maybe Ident
+ letBoundVariable (ValueDeclaration ident _ _ _ _) = Just ident
+ letBoundVariable (PositionedDeclaration _ d) = letBoundVariable d
+ letBoundVariable _ = Nothing
+
+ 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)
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index d50be3f..d53cc26 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -37,10 +37,6 @@ import Data.Function (on)
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 @@ rebracket ms = do
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 @@ removeSignedLiterals (Module mn ds exts) = Module mn (map f' ds) exts
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
-
-removeParens :: (D.Data d) => d -> d
-removeParens = G.everywhere (G.mkT go)
+rebracketModule opTable (Module mn ds exts) =
+ let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return
+ in Module mn <$> (map removeParens <$> mapM f ds) <*> pure exts
+
+removeParens :: Declaration -> Declaration
+removeParens =
+ let (f, _, _) = everywhereOnValues id go id
+ in f
where
go (Parens val) = val
go val = val
diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs
index e72014f..9ffb69e 100644
--- a/src/Language/PureScript/Sugar/TypeDeclarations.hs
+++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs
@@ -19,8 +19,6 @@ module Language.PureScript.Sugar.TypeDeclarations (
desugarTypeDeclarationsModule
) where
-import Data.Generics (mkM)
-import Data.Generics.Extras
import Data.Monoid ((<>))
import Control.Applicative
@@ -59,7 +57,8 @@ desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do
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
diff --git a/src/Language/PureScript/Traversals.hs b/src/Language/PureScript/Traversals.hs
new file mode 100644
index 0000000..c456d53
--- /dev/null
+++ b/src/Language/PureScript/Traversals.hs
@@ -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)
+
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index e890eb7..386e516 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -43,9 +43,9 @@ module Language.PureScript.TypeChecker.Types (
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 Control.Arrow (Arrow(..))
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 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f'
-- 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 @@ skolemEscapeCheck root@TypedValue{} =
-- 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))
-- |
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index 8eba2fe..083bd22 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -26,6 +26,7 @@ import Control.Applicative
import Control.Monad ((<=<))
import Language.PureScript.Names
+import Language.PureScript.Traversals
-- |
-- An identifier for the scope of a skolem variable
@@ -232,9 +233,6 @@ everywhereOnTypesTopDown f = go . f
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
where