summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-04-15 06:55:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-04-15 06:55:00 (GMT)
commit365e910aab012ac04814c0059363a16bc5b48869 (patch)
tree2a16b5569b6713b729d0cd3b4523ff60c9ee45fc
parent50c471402cfc96ba0453f90e09dcb249169c65dd (diff)
version 0.4.18.10.4.18.1
-rw-r--r--purescript.cabal10
-rw-r--r--src/Language/PureScript.hs3
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs2
-rw-r--r--src/Language/PureScript/CodeGen/JS/AST.hs82
-rw-r--r--src/Language/PureScript/Declarations.hs75
-rw-r--r--src/Language/PureScript/Kinds.hs14
-rw-r--r--src/Language/PureScript/Optimizer/Blocks.hs4
-rw-r--r--src/Language/PureScript/Optimizer/Common.hs25
-rw-r--r--src/Language/PureScript/Optimizer/Inliner.hs24
-rw-r--r--src/Language/PureScript/Optimizer/MagicDo.hs13
-rw-r--r--src/Language/PureScript/Optimizer/TCO.hs14
-rw-r--r--src/Language/PureScript/Optimizer/Unused.hs8
-rw-r--r--src/Language/PureScript/Pretty/Kinds.hs3
-rw-r--r--src/Language/PureScript/Pretty/Types.hs7
-rw-r--r--src/Language/PureScript/Sugar.hs2
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs2
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs6
-rw-r--r--src/Language/PureScript/Sugar/Names.hs2
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs7
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs12
-rw-r--r--src/Language/PureScript/TypeChecker/Synonyms.hs10
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs58
-rw-r--r--src/Language/PureScript/Types.hs79
-rw-r--r--tests/Main.hs1
24 files changed, 354 insertions, 109 deletions
diff --git a/purescript.cabal b/purescript.cabal
index 91aec93..e23d122 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.4.18
+version: 0.4.18.1
cabal-version: >=1.8
build-type: Custom
license: MIT
@@ -18,11 +18,11 @@ data-files: prelude/prelude.purs
data-dir: ""
library
- build-depends: base >=4 && <5, cmdtheline -any, containers -any,
+ 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,
- transformers -any, utf8-string -any,
- pattern-arrows >= 0.0.2 && < 0.1,
- monad-unify >= 0.2.1 && < 0.3,
+ 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
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index 32c0960..ba6913f 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -36,7 +36,6 @@ import qualified Language.PureScript.Constants as C
import Data.List (find, sortBy, groupBy, intercalate)
import Data.Time.Clock
import Data.Function (on)
-import Data.Generics (mkQ, everything)
import Data.Maybe (fromJust, fromMaybe)
import Control.Monad.Error
import Control.Monad.State.Lazy
@@ -109,7 +108,7 @@ typeCheckModule mainModuleName (Module mn decls exps) = do
-- Find the type constructors exported from the current module used in a type
findTcons :: Type -> [ProperName]
- findTcons = everything (++) (mkQ [] go)
+ findTcons = everythingOnTypes (++) go
where
go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [name]
go _ = []
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index e49738d..1df88c7 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -249,7 +249,7 @@ qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)
bindersToJs :: Options -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> JS
bindersToJs opts m e binders vals = runGen (map identToJs (unusedNames (binders, vals))) $ do
valNames <- replicateM (length vals) fresh
- jss <- forM binders $ \(CaseAlternative bs grd result) -> go valNames [JSReturn (valueToJs opts m (bindNames m (binderNames bs) e) result)] bs grd
+ 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
diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs
index 2111774..1aa800c 100644
--- a/src/Language/PureScript/CodeGen/JS/AST.hs
+++ b/src/Language/PureScript/CodeGen/JS/AST.hs
@@ -233,3 +233,85 @@ data JS
-- Raw Javascript (generated when parsing fails for an inline foreign import declaration)
--
| JSRaw String deriving (Show, Eq, Data, Typeable)
+
+--
+-- Traversals
+--
+
+everywhereOnJS :: (JS -> JS) -> JS -> JS
+everywhereOnJS f = go
+ where
+ go :: JS -> JS
+ go (JSUnary op j) = f (JSUnary op (go j))
+ go (JSBinary op j1 j2) = f (JSBinary op (go j1) (go j2))
+ go (JSArrayLiteral js) = f (JSArrayLiteral (map go js))
+ go (JSIndexer j1 j2) = f (JSIndexer (go j1) (go j2))
+ go (JSObjectLiteral js) = f (JSObjectLiteral (map (fmap go) js))
+ go (JSAccessor prop j) = f (JSAccessor prop (go j))
+ go (JSFunction name args j) = f (JSFunction name args (go j))
+ go (JSApp j js) = f (JSApp (go j) (map go js))
+ go (JSConditional j1 j2 j3) = f (JSConditional (go j1) (go j2) (go j3))
+ go (JSBlock js) = f (JSBlock (map go js))
+ go (JSVariableIntroduction name j) = f (JSVariableIntroduction name (fmap go j))
+ go (JSAssignment j1 j2) = f (JSAssignment (go j1) (go j2))
+ go (JSWhile j1 j2) = f (JSWhile (go j1) (go j2))
+ go (JSFor name j1 j2 j3) = f (JSFor name (go j1) (go j2) (go j3))
+ go (JSForIn name j1 j2) = f (JSForIn name (go j1) (go j2))
+ go (JSIfElse j1 j2 j3) = f (JSIfElse (go j1) (go j2) (fmap go j3))
+ go (JSReturn js) = f (JSReturn (go js))
+ go (JSThrow js) = f (JSThrow (go js))
+ go (JSTypeOf js) = f (JSTypeOf (go js))
+ go (JSLabel name js) = f (JSLabel name (go js))
+ go other = f other
+
+everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS
+everywhereOnJSTopDown f = go . f
+ where
+ go :: JS -> JS
+ go (JSUnary op j) = JSUnary op (go (f j))
+ go (JSBinary op j1 j2) = JSBinary op (go (f j1)) (go (f j2))
+ go (JSArrayLiteral js) = JSArrayLiteral (map (go . f) js)
+ go (JSIndexer j1 j2) = JSIndexer (go (f j1)) (go (f j2))
+ go (JSObjectLiteral js) = JSObjectLiteral (map (fmap (go . f)) js)
+ go (JSAccessor prop j) = JSAccessor prop (go (f j))
+ go (JSFunction name args j) = JSFunction name args (go (f j))
+ go (JSApp j js) = JSApp (go (f j)) (map (go . f) js)
+ go (JSConditional j1 j2 j3) = JSConditional (go (f j1)) (go (f j2)) (go (f j3))
+ go (JSBlock js) = JSBlock (map (go . f) js)
+ go (JSVariableIntroduction name j) = JSVariableIntroduction name (fmap (go . f) j)
+ go (JSAssignment j1 j2) = JSAssignment (go (f j1)) (go (f j2))
+ go (JSWhile j1 j2) = JSWhile (go (f j1)) (go (f j2))
+ go (JSFor name j1 j2 j3) = JSFor name (go (f j1)) (go (f j2)) (go (f j3))
+ go (JSForIn name j1 j2) = JSForIn name (go (f j1)) (go (f j2))
+ go (JSIfElse j1 j2 j3) = JSIfElse (go (f j1)) (go (f j2)) (fmap (go . f) j3)
+ go (JSReturn j) = JSReturn (go (f j))
+ go (JSThrow j) = JSThrow (go (f j))
+ go (JSTypeOf j) = JSTypeOf (go (f j))
+ go (JSLabel name j) = JSLabel name (go (f j))
+ go other = f other
+
+everythingOnJS :: (r -> r -> r) -> (JS -> r) -> JS -> r
+everythingOnJS (<>) f = go
+ where
+ go j@(JSUnary _ j1) = f j <> go j1
+ go j@(JSBinary _ j1 j2) = f j <> go j1 <> go j2
+ go j@(JSArrayLiteral js) = foldl (<>) (f j) (map go js)
+ go j@(JSIndexer j1 j2) = f j <> go j1 <> go j2
+ go j@(JSObjectLiteral js) = foldl (<>) (f j) (map (go . snd) js)
+ go j@(JSAccessor _ j1) = f j <> go j1
+ go j@(JSFunction _ _ j1) = f j <> go j1
+ go j@(JSApp j1 js) = foldl (<>) (f j <> go j1) (map go js)
+ go j@(JSConditional j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
+ go j@(JSBlock js) = foldl (<>) (f j) (map go js)
+ go j@(JSVariableIntroduction _ (Just j1)) = f j <> go j1
+ go j@(JSAssignment j1 j2) = f j <> go j1 <> go j2
+ go j@(JSWhile j1 j2) = f j <> go j1 <> go j2
+ go j@(JSFor _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
+ go j@(JSForIn _ j1 j2) = f j <> go j1 <> go j2
+ go j@(JSIfElse j1 j2 Nothing) = f j <> go j1 <> go j2
+ go j@(JSIfElse j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3
+ go j@(JSReturn j1) = f j <> go j1
+ go j@(JSThrow j1) = f j <> go j1
+ go j@(JSTypeOf j1) = f j <> go j1
+ go j@(JSLabel _ j1) = f j <> go j1
+ go other = f other
diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs
index c662007..8d3e554 100644
--- a/src/Language/PureScript/Declarations.hs
+++ b/src/Language/PureScript/Declarations.hs
@@ -24,7 +24,6 @@ import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.Environment
import qualified Data.Data as D
-import Data.Generics (mkQ, everything)
-- |
-- A precedence level for an infix operator
@@ -441,9 +440,73 @@ data Binder
-- |
-- Collect all names introduced in binders in an expression
--
-binderNames :: (D.Data d) => d -> [Ident]
-binderNames = everything (++) (mkQ [] go)
+binderNames :: Binder -> [Ident]
+binderNames = go []
where
- go (VarBinder ident) = [ident]
- go (NamedBinder ident _) = [ident]
- go _ = []
+ go ns (VarBinder name) = name : ns
+ go ns (ConstructorBinder _ bs) = foldl go ns bs
+ go ns (ObjectBinder bs) = foldl go ns (map snd bs)
+ go ns (ArrayBinder bs) = foldl go ns bs
+ go ns (ConsBinder b1 b2) = go (go ns b1) b2
+ go ns (NamedBinder name b) = go (name : ns) b
+ go ns (PositionedBinder _ b) = go ns b
+ go ns _ = ns
+
+--
+-- Traversals
+--
+
+everywhereOnValues :: (Declaration -> Declaration) ->
+ (Value -> Value) ->
+ (Binder -> Binder) ->
+ (Declaration -> Declaration, Value -> Value, Binder -> Binder)
+everywhereOnValues f g h = (f', g', h')
+ where
+ f' :: Declaration -> Declaration
+ f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (map f' ds))
+ f' (ValueDeclaration name nameKind bs grd val) = f (ValueDeclaration name nameKind (map h' bs) (fmap g' grd) (g' val))
+ f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (map (\(name, nameKind, val) -> (name, nameKind, g' val)) ds))
+ f' (TypeClassDeclaration name args implies ds) = f (TypeClassDeclaration name args implies (map f' ds))
+ f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (map f' ds))
+ f' (PositionedDeclaration pos d) = f (PositionedDeclaration pos (f' d))
+ f' other = f other
+
+ g' :: Value -> Value
+ g' (UnaryMinus v) = g (UnaryMinus (g' v))
+ g' (BinaryNoParens op v1 v2) = g (BinaryNoParens op (g' v1) (g' v2))
+ g' (Parens v) = g (Parens (g' v))
+ g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs))
+ g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs))
+ g' (Accessor prop v) = g (Accessor prop (g' v))
+ g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))
+ g' (Abs name v) = g (Abs name (g' v))
+ g' (App v1 v2) = g (App (g' v1) (g' v2))
+ g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3))
+ g' (Case vs alts) = g (Case (map g' vs) (map handleCaseAlternative alts))
+ g' (TypedValue check v ty) = g (TypedValue check (g' v) ty)
+ g' (Let ds v) = g (Let (map f' ds) (g' v))
+ g' (Do es) = g (Do (map handleDoNotationElement es))
+ g' (PositionedValue pos v) = g (PositionedValue pos (g' v))
+ g' other = g other
+
+ h' :: Binder -> Binder
+ h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (map h' bs))
+ h' (ObjectBinder bs) = h (ObjectBinder (map (fmap h') bs))
+ h' (ArrayBinder bs) = h (ArrayBinder (map h' bs))
+ h' (ConsBinder b1 b2) = h (ConsBinder (h' b1) (h' b2))
+ h' (NamedBinder name b) = h (NamedBinder name (h' b))
+ h' (PositionedBinder pos b) = h (PositionedBinder pos (h' b))
+ h' other = h other
+
+ handleCaseAlternative :: CaseAlternative -> CaseAlternative
+ handleCaseAlternative ca =
+ ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)
+ , caseAlternativeGuard = fmap g' (caseAlternativeGuard ca)
+ , caseAlternativeResult = g' (caseAlternativeResult ca)
+ }
+
+ handleDoNotationElement :: DoNotationElement -> DoNotationElement
+ handleDoNotationElement (DoNotationValue v) = DoNotationValue (g' v)
+ handleDoNotationElement (DoNotationBind b v) = DoNotationBind (h' b) (g' v)
+ handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)
+ handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos (handleDoNotationElement e)
diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs
index 016a318..753326f 100644
--- a/src/Language/PureScript/Kinds.hs
+++ b/src/Language/PureScript/Kinds.hs
@@ -44,3 +44,17 @@ data Kind
-- Function kinds
--
| FunKind Kind Kind deriving (Show, Eq, Data, Typeable)
+
+everywhereOnKinds :: (Kind -> Kind) -> Kind -> Kind
+everywhereOnKinds f = go
+ where
+ go (Row k1) = f (Row (go k1))
+ go (FunKind k1 k2) = f (FunKind (go k1) (go k2))
+ go other = f other
+
+everythingOnKinds :: (r -> r -> r) -> (Kind -> r) -> Kind -> r
+everythingOnKinds (<>) f = go
+ where
+ go k@(Row k1) = f k <> go k1
+ go k@(FunKind k1 k2) = f k <> go k1 <> go k2
+ go other = f other
diff --git a/src/Language/PureScript/Optimizer/Blocks.hs b/src/Language/PureScript/Optimizer/Blocks.hs
index 19a5f9c..98d383c 100644
--- a/src/Language/PureScript/Optimizer/Blocks.hs
+++ b/src/Language/PureScript/Optimizer/Blocks.hs
@@ -17,15 +17,13 @@ module Language.PureScript.Optimizer.Blocks (
collapseNestedBlocks
) where
-import Data.Generics
-
import Language.PureScript.CodeGen.JS.AST
-- |
-- Collapse blocks which appear nested directly below another block
--
collapseNestedBlocks :: JS -> JS
-collapseNestedBlocks = everywhere (mkT collapse)
+collapseNestedBlocks = everywhereOnJS collapse
where
collapse :: JS -> JS
collapse (JSBlock sts) = JSBlock (concatMap go sts)
diff --git a/src/Language/PureScript/Optimizer/Common.hs b/src/Language/PureScript/Optimizer/Common.hs
index 546c54f..aec728d 100644
--- a/src/Language/PureScript/Optimizer/Common.hs
+++ b/src/Language/PureScript/Optimizer/Common.hs
@@ -16,27 +16,26 @@
module Language.PureScript.Optimizer.Common where
import Data.Maybe (fromMaybe)
-import Data.Generics
import Language.PureScript.CodeGen.JS.AST
applyAll :: [a -> a] -> a -> a
applyAll = foldl1 (.)
-replaceIdent :: (Data d) => String -> JS -> d -> d
-replaceIdent var1 js = everywhere (mkT replace)
+replaceIdent :: String -> JS -> JS -> JS
+replaceIdent var1 js = everywhereOnJS replace
where
replace (JSVar var2) | var1 == var2 = js
replace other = other
-replaceIdents :: (Data d) => [(String, JS)] -> d -> d
-replaceIdents vars = everywhere (mkT replace)
+replaceIdents :: [(String, JS)] -> JS -> JS
+replaceIdents vars = everywhereOnJS replace
where
replace v@(JSVar var) = fromMaybe v $ lookup var vars
replace other = other
-isReassigned :: (Data d) => String -> d -> Bool
-isReassigned var1 = everything (||) (mkQ False check)
+isReassigned :: String -> JS -> Bool
+isReassigned var1 = everythingOnJS (||) check
where
check :: JS -> Bool
check (JSFunction _ args _) | var1 `elem` args = True
@@ -46,14 +45,14 @@ isReassigned var1 = everything (||) (mkQ False check)
check (JSForIn arg _ _) | var1 == arg = True
check _ = False
-isRebound :: (Data d) => JS -> d -> Bool
-isRebound js d = any (\v -> isReassigned v d || isUpdated v d) (everything (++) (mkQ [] variablesOf) js)
+isRebound :: JS -> JS -> Bool
+isRebound js d = any (\v -> isReassigned v d || isUpdated v d) (everythingOnJS (++) variablesOf js)
where
variablesOf (JSVar var) = [var]
variablesOf _ = []
-isUsed :: (Data d) => String -> d -> Bool
-isUsed var1 = everything (||) (mkQ False check)
+isUsed :: String -> JS -> Bool
+isUsed var1 = everythingOnJS (||) check
where
check :: JS -> Bool
check (JSVar var2) | var1 == var2 = True
@@ -66,8 +65,8 @@ targetVariable (JSAccessor _ tgt) = targetVariable tgt
targetVariable (JSIndexer _ tgt) = targetVariable tgt
targetVariable _ = error "Invalid argument to targetVariable"
-isUpdated :: (Data d) => String -> d -> Bool
-isUpdated var1 = everything (||) (mkQ False check)
+isUpdated :: String -> JS -> Bool
+isUpdated var1 = everythingOnJS (||) check
where
check :: JS -> Bool
check (JSAssignment target _) | var1 == targetVariable target = True
diff --git a/src/Language/PureScript/Optimizer/Inliner.hs b/src/Language/PureScript/Optimizer/Inliner.hs
index d8a8b55..65dc217 100644
--- a/src/Language/PureScript/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/Optimizer/Inliner.hs
@@ -22,8 +22,6 @@ module Language.PureScript.Optimizer.Inliner (
evaluateIifes
) where
-import Data.Generics
-
import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.CodeGen.Common (identToJs)
import Language.PureScript.Optimizer.Common
@@ -41,42 +39,42 @@ shouldInline (JSIndexer index val) = shouldInline index && shouldInline val
shouldInline _ = False
etaConvert :: JS -> JS
-etaConvert = everywhere (mkT convert)
+etaConvert = everywhereOnJS convert
where
convert :: JS -> JS
convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])
| all shouldInline args &&
not (any (`isRebound` block) (map JSVar idents)) &&
not (any (`isRebound` block) args)
- = JSBlock (replaceIdents (zip idents args) body)
+ = JSBlock (map (replaceIdents (zip idents args)) body)
convert js = js
unThunk :: JS -> JS
-unThunk = everywhere (mkT convert)
+unThunk = everywhereOnJS convert
where
convert :: JS -> JS
convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) [])]) = JSBlock body
convert js = js
evaluateIifes :: JS -> JS
-evaluateIifes = everywhere (mkT convert)
+evaluateIifes = everywhereOnJS convert
where
convert :: JS -> JS
convert (JSApp (JSFunction Nothing [] (JSBlock [JSReturn ret])) []) = ret
convert js = js
inlineVariables :: JS -> JS
-inlineVariables = everywhere (mkT $ removeFromBlock go)
+inlineVariables = everywhereOnJS $ removeFromBlock go
where
go :: [JS] -> [JS]
go [] = []
go (JSVariableIntroduction var (Just js) : sts)
- | shouldInline js && not (isReassigned var sts) && not (isRebound js sts) && not (isUpdated var sts) =
- go (replaceIdent var js sts)
+ | shouldInline js && not (any (isReassigned var) sts) && not (any (isRebound js) sts) && not (any (isUpdated var) sts) =
+ go (map (replaceIdent var js) sts)
go (s:sts) = s : go sts
inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS
-inlineOperator (m, op) f = everywhere (mkT convert)
+inlineOperator (m, op) f = everywhereOnJS convert
where
convert :: JS -> JS
convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y
@@ -122,7 +120,7 @@ inlineCommonOperators = applyAll
]
where
binary :: String -> String -> BinaryOperator -> JS -> JS
- binary dictName opString op = everywhere (mkT convert)
+ binary dictName opString op = everywhereOnJS convert
where
convert :: JS -> JS
convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y
@@ -131,7 +129,7 @@ inlineCommonOperators = applyAll
isOp (JSIndexer (JSStringLiteral op') (JSVar prelude)) = prelude == C.prelude && opString == op'
isOp _ = False
binaryFunction :: String -> String -> BinaryOperator -> JS -> JS
- binaryFunction dictName fnName op = everywhere (mkT convert)
+ binaryFunction dictName fnName op = everywhereOnJS convert
where
convert :: JS -> JS
convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y
@@ -139,7 +137,7 @@ inlineCommonOperators = applyAll
isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName == fnName'
isOp _ = False
unary :: String -> String -> UnaryOperator -> JS -> JS
- unary dictName fnName op = everywhere (mkT convert)
+ unary dictName fnName op = everywhereOnJS convert
where
convert :: JS -> JS
convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict dictName dict = JSUnary op x
diff --git a/src/Language/PureScript/Optimizer/MagicDo.hs b/src/Language/PureScript/Optimizer/MagicDo.hs
index 4c7c0e3..9976ff6 100644
--- a/src/Language/PureScript/Optimizer/MagicDo.hs
+++ b/src/Language/PureScript/Optimizer/MagicDo.hs
@@ -20,7 +20,6 @@ module Language.PureScript.Optimizer.MagicDo (
import Data.List (nub)
import Data.Maybe (fromJust, isJust)
-import Data.Generics
import Language.PureScript.Options
import Language.PureScript.CodeGen.JS.AST
@@ -50,7 +49,7 @@ magicDo opts | optionsNoMagicDo opts = id
-- }
--
magicDo' :: JS -> JS
-magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
+magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert
where
-- The name of the function block which is added to denote a do block
fnName = "__do"
@@ -106,7 +105,7 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
-- Inline functions in the ST module
--
inlineST :: JS -> JS
-inlineST = everywhere (mkT convertBlock)
+inlineST = everywhereOnJS convertBlock
where
-- Look for runST blocks and inline the STRefs there.
-- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then
@@ -116,7 +115,7 @@ inlineST = everywhere (mkT convertBlock)
usages = findAllSTUsagesIn arg
allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages
localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs
- in everywhere (mkT $ convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg
+ in everywhereOnJS (convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg
convertBlock other = other
-- Convert a block in a safe way, preserving object wrappers of references,
-- or in a more aggressive way, turning wrappers into local variables depending on the
@@ -138,18 +137,18 @@ inlineST = everywhere (mkT convertBlock)
isSTFunc name (JSAccessor name' (JSVar st)) = st == C.st && name == name'
isSTFunc _ _ = False
-- Find all ST Refs initialized in this block
- findSTRefsIn = everything (++) (mkQ [] isSTRef)
+ findSTRefsIn = everythingOnJS (++) isSTRef
where
isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [_]) []))) | isSTFunc C.newSTRef f = [ident]
isSTRef _ = []
-- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef
- findAllSTUsagesIn = everything (++) (mkQ [] isSTUsage)
+ findAllSTUsagesIn = everythingOnJS (++) isSTUsage
where
isSTUsage (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f = [ref]
isSTUsage (JSApp (JSApp (JSApp f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]
isSTUsage _ = []
-- Find all uses of a variable
- appearingIn ref = everything (++) (mkQ [] isVar)
+ appearingIn ref = everythingOnJS (++) isVar
where
isVar e@(JSVar v) | v == ref = [e]
isVar _ = []
diff --git a/src/Language/PureScript/Optimizer/TCO.hs b/src/Language/PureScript/Optimizer/TCO.hs
index a7ea0ba..4e9e8a3 100644
--- a/src/Language/PureScript/Optimizer/TCO.hs
+++ b/src/Language/PureScript/Optimizer/TCO.hs
@@ -15,8 +15,6 @@
module Language.PureScript.Optimizer.TCO (tco) where
-import Data.Generics
-
import Language.PureScript.Options
import Language.PureScript.CodeGen.JS.AST
@@ -28,7 +26,7 @@ tco opts | optionsNoTco opts = id
| otherwise = tco'
tco' :: JS -> JS
-tco' = everywhere (mkT convert)
+tco' = everywhereOnJS convert
where
tcoLabel :: String
tcoLabel = "tco"
@@ -61,9 +59,9 @@ tco' = everywhere (mkT convert)
isTailCall :: String -> JS -> Bool
isTailCall ident js =
let
- numSelfCalls = everything (+) (mkQ 0 countSelfCalls) js
- numSelfCallsInTailPosition = everything (+) (mkQ 0 countSelfCallsInTailPosition) js
- numSelfCallsUnderFunctions = everything (+) (mkQ 0 countSelfCallsUnderFunctions) js
+ numSelfCalls = everythingOnJS (+) countSelfCalls js
+ numSelfCallsInTailPosition = everythingOnJS (+) countSelfCallsInTailPosition js
+ numSelfCallsUnderFunctions = everythingOnJS (+) countSelfCallsUnderFunctions js
in
numSelfCalls > 0
&& numSelfCalls == numSelfCallsInTailPosition
@@ -75,12 +73,12 @@ tco' = everywhere (mkT convert)
countSelfCallsInTailPosition :: JS -> Int
countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1
countSelfCallsInTailPosition _ = 0
- countSelfCallsUnderFunctions (JSFunction _ _ js') = everything (+) (mkQ 0 countSelfCalls) js'
+ countSelfCallsUnderFunctions (JSFunction _ _ js') = everythingOnJS (+) countSelfCalls js'
countSelfCallsUnderFunctions _ = 0
toLoop :: String -> [String] -> JS -> JS
toLoop ident allArgs js = JSBlock $
map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++
- [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhere (mkT loopify) js ]) ]
+ [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhereOnJS loopify js ]) ]
where
loopify :: JS -> JS
loopify (JSReturn ret) | isSelfCall ident ret =
diff --git a/src/Language/PureScript/Optimizer/Unused.hs b/src/Language/PureScript/Optimizer/Unused.hs
index 4017872..a3e07a0 100644
--- a/src/Language/PureScript/Optimizer/Unused.hs
+++ b/src/Language/PureScript/Optimizer/Unused.hs
@@ -18,23 +18,21 @@ module Language.PureScript.Optimizer.Unused (
removeCodeAfterReturnStatements
) where
-import Data.Generics
-
import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.Optimizer.Common
removeUnusedVariables :: JS -> JS
-removeUnusedVariables = everywhere (mkT $ removeFromBlock withBlock)
+removeUnusedVariables = everywhereOnJS (removeFromBlock withBlock)
where
withBlock :: [JS] -> [JS]
withBlock sts = go sts sts
go :: [JS] -> [JS] -> [JS]
go _ [] = []
- go sts (JSVariableIntroduction var _ : rest) | not (isUsed var sts) = go sts rest
+ go sts (JSVariableIntroduction var _ : rest) | not (any (isUsed var) sts) = go sts rest
go sts (s : rest) = s : go sts rest
removeCodeAfterReturnStatements :: JS -> JS
-removeCodeAfterReturnStatements = everywhere (mkT $ removeFromBlock go)
+removeCodeAfterReturnStatements = everywhereOnJS (removeFromBlock go)
where
go :: [JS] -> [JS]
go jss | not (any isJSReturn jss) = jss
diff --git a/src/Language/PureScript/Pretty/Kinds.hs b/src/Language/PureScript/Pretty/Kinds.hs
index 6c67928..53f8f82 100644
--- a/src/Language/PureScript/Pretty/Kinds.hs
+++ b/src/Language/PureScript/Pretty/Kinds.hs
@@ -21,7 +21,6 @@ import Data.Maybe (fromMaybe)
import Control.Arrow (ArrowPlus(..))
import Control.PatternArrows
-import Control.Monad.Unify
import Language.PureScript.Kinds
import Language.PureScript.Pretty.Common
@@ -31,7 +30,7 @@ typeLiterals = mkPattern match
where
match Star = Just "*"
match Bang = Just "!"
- match (KUnknown (Unknown u)) = Just $ 'u' : show u
+ match (KUnknown u) = Just $ 'u' : show u
match _ = Nothing
matchRow :: Pattern () Kind ((), Kind)
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
index b63c78c..65395f2 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -21,11 +21,9 @@ module Language.PureScript.Pretty.Types (
import Data.Maybe (fromMaybe)
import Data.List (intercalate)
-import Data.Generics (mkT, everywhere, everywhere')
import Control.Arrow ((<+>))
import Control.PatternArrows
-import Control.Monad.Unify
import Language.PureScript.Types
import Language.PureScript.Pretty.Common
@@ -38,7 +36,7 @@ typeLiterals = mkPattern match
match (PrettyPrintObject row) = Just $ "{ " ++ prettyPrintRow row ++ " }"
match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]"
match (TypeConstructor ctor) = Just $ show ctor
- match (TUnknown (Unknown u)) = Just $ 'u' : show u
+ match (TUnknown u) = Just $ 'u' : show u
match (Skolem name s _) = Just $ name ++ show s
match (ConstrainedType deps ty) = Just $ "(" ++ intercalate ", " (map (\(pn, ty') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom ty')) deps) ++ ") => " ++ prettyPrintType ty
match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintTypeAtom args) ++ ">"
@@ -74,7 +72,7 @@ appliedFunction = mkPattern match
match _ = Nothing
insertPlaceholders :: Type -> Type
-insertPlaceholders = everywhere' (mkT convertForAlls) . everywhere (mkT convert)
+insertPlaceholders = everywhereOnTypesTopDown convertForAlls . everywhereOnTypes convert
where
convert (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret
convert (TypeApp a el) | a == tyArray = PrettyPrintArray el
@@ -118,3 +116,4 @@ prettyPrintTypeAtom = fromMaybe (error "Incomplete pattern") . pattern matchType
--
prettyPrintType :: Type -> String
prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType () . insertPlaceholders
+
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index bd1d911..51e2a83 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -48,7 +48,7 @@ import Control.Category ((>>>))
-- * Qualify any unqualified names and types
--
desugar :: [Module] -> Either ErrorStack [Module]
-desugar = removeSignedLiterals
+desugar = map removeSignedLiterals
>>> desugarDo
>=> desugarCasesModule
>=> desugarTypeDeclarationsModule
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index 17682dd..9b89ed3 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -79,7 +79,7 @@ createBindingGroupsForValue moduleName = everywhereM' (mkM go)
-- Collapse all binding groups to individual declarations
--
collapseBindingGroups :: [Declaration] -> [Declaration]
-collapseBindingGroups = everywhere (mkT collapseBindingGroupsForValue) . concatMap go
+collapseBindingGroups = let (f, _, _) = everywhereOnValues id collapseBindingGroupsForValue id in map f . concatMap go
where
go (DataBindingGroupDeclaration ds) = ds
go (BindingGroupDeclaration ds) = map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] Nothing val) ds
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index 5c47504..986a179 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -21,7 +21,7 @@ module Language.PureScript.Sugar.CaseDeclarations (
import Data.Monoid ((<>))
import Data.List (groupBy)
-import Data.Generics (mkM, mkT, everywhere)
+import Data.Generics (mkM)
import Data.Generics.Extras
import Control.Applicative
@@ -43,8 +43,10 @@ desugarCasesModule ms = forM ms $ \(Module name ds exps) ->
Module name <$> (desugarCases . desugarAbs $ ds) <*> pure exps
desugarAbs :: [Declaration] -> [Declaration]
-desugarAbs = everywhere (mkT replace)
+desugarAbs = map f
where
+ (f, _, _) = everywhereOnValues id replace id
+
replace (Abs (Right binder) val) =
let
ident = head $ unusedNames (binder, val)
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index 120f43e..1b28d1b 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -215,7 +215,7 @@ renameInModule imports exports (Module mn decls exps) =
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, binderNames bs ++ bound), c)
+ bindBinders (pos, bound) c@(CaseAlternative bs _ _) = return ((pos, concatMap binderNames bs ++ bound), c)
letBoundVariable :: Declaration -> Maybe Ident
letBoundVariable (ValueDeclaration ident _ _ _ _) = Just ident
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index 424967d..d50be3f 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -57,9 +57,12 @@ rebracket ms = do
let opTable = customOperatorTable $ map (\(i, _, f) -> (i, f)) fixities
mapM (rebracketModule opTable) ms
-removeSignedLiterals :: (D.Data d) => d -> d
-removeSignedLiterals = G.everywhere (G.mkT go)
+
+removeSignedLiterals :: Module -> Module
+removeSignedLiterals (Module mn ds exts) = Module mn (map f' ds) exts
where
+ (f', _, _) = everywhereOnValues id go id
+
go (UnaryMinus (NumericLiteral (Left n))) = NumericLiteral (Left $ negate n)
go (UnaryMinus (NumericLiteral (Right n))) = NumericLiteral (Right $ negate n)
go (UnaryMinus val) = App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.negate))) val
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index d7c4d6b..f44c1b4 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -37,12 +37,23 @@ import Control.Monad.Unify
import Control.Applicative
import qualified Data.Map as M
+import qualified Data.HashMap.Strict as H
import Data.Monoid ((<>))
instance Partial Kind where
unknown = KUnknown
isUnknown (KUnknown u) = Just u
isUnknown _ = Nothing
+ unknowns = everythingOnKinds (++) go
+ where
+ go (KUnknown u) = [u]
+ go _ = []
+ ($?) sub = everywhereOnKinds go
+ where
+ go t@(KUnknown u) = case H.lookup u (runSubstitution sub) of
+ Nothing -> t
+ Just t' -> t'
+ go other = other
instance Unifiable Check Kind where
KUnknown u1 =?= KUnknown u2 | u1 == u2 = return ()
@@ -171,3 +182,4 @@ infer' (ConstrainedType deps ty) = do
infer' _ = error "Invalid argument to infer"
+
diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs
index 9da09fe..1a3be4e 100644
--- a/src/Language/PureScript/TypeChecker/Synonyms.hs
+++ b/src/Language/PureScript/TypeChecker/Synonyms.hs
@@ -14,7 +14,6 @@
-----------------------------------------------------------------------------
module Language.PureScript.TypeChecker.Synonyms (
- saturateTypeSynonym,
saturateAllTypeSynonyms
) where
@@ -23,9 +22,6 @@ import Language.PureScript.Names
import Control.Applicative ((<$>))
import Data.Maybe (fromMaybe)
-import Data.Data
-import Data.Generics
-import Data.Generics.Extras
import Control.Monad.Writer
import Control.Monad.Error
@@ -44,15 +40,15 @@ buildTypeSubstitution name n = go n []
-- |
-- Replace all instances of a specific type synonym with the @SaturatedTypeSynonym@ data constructor
--
-saturateTypeSynonym :: (Data d) => Qualified ProperName -> Int -> d -> Either String d
-saturateTypeSynonym name n = everywhereM' (mkM replace)
+saturateTypeSynonym :: Qualified ProperName -> Int -> Type -> Either String Type
+saturateTypeSynonym name n = everywhereOnTypesTopDownM replace
where
replace t = fromMaybe t <$> buildTypeSubstitution name n t
-- |
-- Replace all type synonyms with the @SaturatedTypeSynonym@ data constructor
--
-saturateAllTypeSynonyms :: (Data d) => [(Qualified ProperName, Int)] -> d -> Either String d
+saturateAllTypeSynonyms :: [(Qualified ProperName, Int)] -> Type -> Either String Type
saturateAllTypeSynonyms syns d = foldM (\result (name, n) -> saturateTypeSynonym name n result) d syns
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 072fcd4..e890eb7 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -43,10 +43,8 @@ module Language.PureScript.TypeChecker.Types (
import Data.List
import Data.Maybe (maybeToList, isNothing, isJust, fromMaybe)
-import qualified Data.Data as D
import Data.Generics
- (everythingWithContext, mkM, everywhereM,
- everything, mkT, something, everywhere, mkQ)
+ (everythingWithContext, mkM, something, mkQ)
import Data.Generics.Extras
import Language.PureScript.Declarations
@@ -70,6 +68,7 @@ import Control.Applicative
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 ((<>))
@@ -78,6 +77,16 @@ instance Partial Type where
unknown = TUnknown
isUnknown (TUnknown u) = Just u
isUnknown _ = Nothing
+ unknowns = everythingOnTypes (++) go
+ where
+ go (TUnknown u) = [u]
+ go _ = []
+ ($?) sub = everywhereOnTypes go
+ where
+ go t@(TUnknown u) = case H.lookup u (runSubstitution sub) of
+ Nothing -> t
+ Just t' -> t'
+ go other = other
instance Unifiable Check Type where
(=?=) = unifyTypes
@@ -253,7 +262,7 @@ isTyped (name, value) = (name, (value, Nothing))
-- Map a function over type annotations appearing inside a value
--
overTypes :: (Type -> Type) -> Value -> Value
-overTypes f = everywhere (mkT g)
+overTypes f = let (_, f', _) = everywhereOnValues id g id in f'
where
g :: Value -> Value
g (TypedValue checkTy val t) = TypedValue checkTy val (f t)
@@ -373,7 +382,7 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
return $ map head grps
-- Apply a substitution to a type
applySubst :: [(String, Type)] -> Type -> Maybe Type
- applySubst subst = everywhereM (mkM replace)
+ applySubst subst = everywhereOnTypesM replace
where
replace (TypeVar v) = lookup v subst
replace other = Just other
@@ -463,7 +472,7 @@ skolemEscapeCheck root@TypedValue{} =
_ -> ([], scos)
where
collectSkolems :: Type -> [SkolemScope]
- collectSkolems = nub . everything (++) (mkQ [] collect)
+ collectSkolems = nub . everythingOnTypes (++) collect
where
collect (Skolem _ _ scope) = [scope]
collect _ = []
@@ -484,8 +493,8 @@ setify = rowFromList . first (M.toList . M.fromList) . rowToList
-- |
-- \"Setify\" all rows occuring inside a value
--
-setifyAll :: (D.Data d) => d -> d
-setifyAll = everywhere (mkT setify)
+setifyAll :: Type -> Type
+setifyAll = everywhereOnTypes setify
-- |
-- Replace outermost unsolved unification variables with named type variables
@@ -494,11 +503,11 @@ varIfUnknown :: Type -> Type
varIfUnknown ty =
let unks = nub $ unknowns ty
toName = (:) 't' . show
- ty' = everywhere (mkT typeToVar) ty
+ ty' = everywhereOnTypes typeToVar ty
typeToVar :: Type -> Type
- typeToVar (TUnknown (Unknown u)) = TypeVar (toName u)
+ typeToVar (TUnknown u) = TypeVar (toName u)
typeToVar t = t
- in mkForAll (sort . map (toName . runUnknown) $ unks) ty'
+ in mkForAll (sort . map toName $ unks) ty'
-- |
-- Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns
@@ -529,14 +538,14 @@ replaceVarWithUnknown ident ty = do
-- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate
-- better error messages during unification.
--
-replaceAllTypeSynonyms' :: (D.Data d) => Environment -> d -> Either String d
+replaceAllTypeSynonyms' :: Environment -> Type -> Either String Type
replaceAllTypeSynonyms' env d =
let
syns = map (\(name, (args, _)) -> (name, length args)) . M.toList $ typeSynonyms env
in
saturateAllTypeSynonyms syns d
-replaceAllTypeSynonyms :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => (D.Data d) => d -> m d
+replaceAllTypeSynonyms :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type
replaceAllTypeSynonyms d = do
env <- getEnv
either (throwError . strMsg) return $ replaceAllTypeSynonyms' env d
@@ -544,8 +553,8 @@ replaceAllTypeSynonyms d = do
-- |
-- \"Desaturate\" @SaturatedTypeSynonym@s
--
-desaturateAllTypeSynonyms :: (D.Data d) => d -> d
-desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)
+desaturateAllTypeSynonyms :: Type -> Type
+desaturateAllTypeSynonyms = everywhereOnTypes replaceSaturatedTypeSynonym
where
replaceSaturatedTypeSynonym (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args
replaceSaturatedTypeSynonym t = t
@@ -566,8 +575,8 @@ expandTypeSynonym name args = do
env <- getEnv
either (throwError . strMsg) return $ expandTypeSynonym' env name args
-expandAllTypeSynonyms :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type
-expandAllTypeSynonyms = everywhereM' (mkM go)
+expandAllTypeSynonyms :: (Error e, Functor m, Applicative m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type
+expandAllTypeSynonyms = everywhereOnTypesTopDownM go
where
go (SaturatedTypeSynonym name args) = expandTypeSynonym name args
go other = return other
@@ -677,6 +686,8 @@ inferLetBinding :: [Declaration] -> [Declaration] -> Value -> (Value -> UnifyT T
inferLetBinding seen [] ret j = (,) seen <$> j ret
inferLetBinding seen (ValueDeclaration ident nameKind [] Nothing tv@(TypedValue checkType val ty) : rest) ret j = do
Just moduleName <- checkCurrentModule <$> get
+ kind <- liftCheck $ kindOf moduleName ty
+ guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
let dict = if isFunction val then M.singleton (moduleName, ident) (ty, nameKind) else M.empty
TypedValue _ val' ty' <- if checkType then bindNames dict (check val ty) else return tv
bindNames (M.singleton (moduleName, ident) (ty', nameKind)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing (TypedValue checkType val' ty')]) rest ret j
@@ -694,7 +705,7 @@ inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
(ident, (val', _)) <- typeForBindingGroupElement moduleName e dict untypedDict
return $ (ident, LocalVariable, val')
bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j
-inferLetBinding seen (PositionedDeclaration pos d : ds) ret j = do
+inferLetBinding seen (PositionedDeclaration pos d : ds) ret j = rethrowWithPosition pos $ do
((d' : ds'), val') <- inferLetBinding seen (d : ds) ret j
return (PositionedDeclaration pos d' : ds', val')
inferLetBinding _ _ _ _ = error "Invalid argument to inferLetBinding"
@@ -791,13 +802,13 @@ checkBinders nvals ret (CaseAlternative binders grd val : bs) = do
-- Generate a new skolem constant
--
newSkolemConstant :: UnifyT Type Check Int
-newSkolemConstant = runUnknown <$> fresh'
+newSkolemConstant = fresh'
-- |
-- Generate a new skolem scope
--
newSkolemScope :: UnifyT Type Check SkolemScope
-newSkolemScope = SkolemScope . runUnknown <$> fresh'
+newSkolemScope = SkolemScope <$> fresh'
-- |
-- Skolemize a type variable by replacing its instances with fresh skolem constants
@@ -811,7 +822,7 @@ skolemize ident sko scope = replaceTypeVars ident (Skolem ident sko scope)
-- only example of scoped type variables.
--
skolemizeTypesInValue :: String -> Int -> SkolemScope -> Value -> Value
-skolemizeTypesInValue ident sko scope = everywhere (mkT go)
+skolemizeTypesInValue ident sko scope = let (_, f, _) = everywhereOnValues id go id in f
where
go (SuperClassDictionary c ts) = SuperClassDictionary c (map (skolemize ident sko scope) ts)
go other = other
@@ -820,7 +831,7 @@ skolemizeTypesInValue ident sko scope = everywhere (mkT go)
-- Introduce skolem scope at every occurence of a ForAll
--
introduceSkolemScope :: Type -> UnifyT Type Check Type
-introduceSkolemScope = everywhereM (mkM go)
+introduceSkolemScope = everywhereOnTypesM go
where
go (ForAll ident ty Nothing) = ForAll ident ty <$> (Just <$> newSkolemScope)
go other = return other
@@ -962,7 +973,7 @@ check' (PositionedValue pos val) ty =
check' val ty = throwError $ mkErrorStack ("Value does not have type " ++ prettyPrintType ty) (Just (ValueError val))
containsTypeSynonyms :: Type -> Bool
-containsTypeSynonyms = everything (||) (mkQ False go) where
+containsTypeSynonyms = everythingOnTypes (||) go where
go (SaturatedTypeSynonym _ _) = True
go _ = False
@@ -1109,3 +1120,4 @@ subsumes' val ty1 ty2 = do
+
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index 2d3e6c4..8eba2fe 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -19,10 +19,11 @@ module Language.PureScript.Types where
import Data.Data
import Data.List (nub)
-import Data.Generics (everything, mkQ)
import Control.Monad.Unify
import Control.Arrow (second)
+import Control.Applicative
+import Control.Monad ((<=<))
import Language.PureScript.Names
@@ -157,7 +158,7 @@ replaceAllTypeVars = foldl (\f (name, ty) -> replaceTypeVars name ty . f) id
-- Collect all type variables appearing in a type
--
usedTypeVariables :: Type -> [String]
-usedTypeVariables = nub . everything (++) (mkQ [] go)
+usedTypeVariables = nub . everythingOnTypes (++) go
where
go (TypeVar v) = [v]
go _ = []
@@ -199,5 +200,79 @@ moveQuantifiersToFront = go [] []
[] -> constrained
qs' -> foldl (\ty' (q, sco) -> ForAll q ty' sco) constrained qs'
+--
+-- Traversals
+--
+
+everywhereOnTypes :: (Type -> Type) -> Type -> Type
+everywhereOnTypes f = go
+ where
+ go (TypeApp t1 t2) = f (TypeApp (go t1) (go t2))
+ go (SaturatedTypeSynonym name tys) = f (SaturatedTypeSynonym name (map go tys))
+ go (ForAll arg ty sco) = f (ForAll arg (go ty) sco)
+ go (ConstrainedType cs ty) = f (ConstrainedType (map (fmap (map go)) cs) (go ty))
+ go (RCons name ty rest) = f (RCons name (go ty) (go rest))
+ go (PrettyPrintFunction t1 t2) = f (PrettyPrintFunction (go t1) (go t2))
+ go (PrettyPrintArray t) = f (PrettyPrintArray (go t))
+ go (PrettyPrintObject t) = f (PrettyPrintObject (go t))
+ go (PrettyPrintForAll args t) = f (PrettyPrintForAll args (go t))
+ go other = f other
+
+everywhereOnTypesTopDown :: (Type -> Type) -> Type -> Type
+everywhereOnTypesTopDown f = go . f
+ where
+ go (TypeApp t1 t2) = TypeApp (go (f t1)) (go (f t2))
+ go (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym name (map (go . f) tys)
+ go (ForAll arg ty sco) = ForAll arg (go (f ty)) sco
+ go (ConstrainedType cs ty) = ConstrainedType (map (fmap (map (go . f))) cs) (go (f ty))
+ go (RCons name ty rest) = RCons name (go (f ty)) (go (f rest))
+ go (PrettyPrintFunction t1 t2) = PrettyPrintFunction (go (f t1)) (go (f t2))
+ go (PrettyPrintArray t) = PrettyPrintArray (go (f t))
+ 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
+ where
+ go (TypeApp t1 t2) = (TypeApp <$> go t1 <*> go t2) >>= f
+ go (SaturatedTypeSynonym name tys) = (SaturatedTypeSynonym name <$> mapM go tys) >>= f
+ go (ForAll arg ty sco) = (ForAll arg <$> go ty <*> pure sco) >>= f
+ go (ConstrainedType cs ty) = (ConstrainedType <$> mapM (sndM (mapM go)) cs <*> go ty) >>= f
+ go (RCons name ty rest) = (RCons name <$> go ty <*> go rest) >>= f
+ go (PrettyPrintFunction t1 t2) = (PrettyPrintFunction <$> go t1 <*> go t2) >>= f
+ go (PrettyPrintArray t) = (PrettyPrintArray <$> go t) >>= f
+ go (PrettyPrintObject t) = (PrettyPrintObject <$> go t) >>= f
+ go (PrettyPrintForAll args t) = (PrettyPrintForAll args <$> go t) >>= f
+ go other = f other
+
+everywhereOnTypesTopDownM :: (Functor m, Applicative m, Monad m) => (Type -> m Type) -> Type -> m Type
+everywhereOnTypesTopDownM f = go <=< f
+ where
+ go (TypeApp t1 t2) = TypeApp <$> (f t1 >>= go) <*> (f t2 >>= go)
+ go (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym name <$> mapM (go <=< f) tys
+ go (ForAll arg ty sco) = ForAll arg <$> (f ty >>= go) <*> pure sco
+ go (ConstrainedType cs ty) = ConstrainedType <$> mapM (sndM (mapM (go <=< f))) cs <*> (f ty >>= go)
+ go (RCons name ty rest) = RCons name <$> (f ty >>= go) <*> (f rest >>= go)
+ go (PrettyPrintFunction t1 t2) = PrettyPrintFunction <$> (f t1 >>= go) <*> (f t2 >>= go)
+ go (PrettyPrintArray t) = PrettyPrintArray <$> (f t >>= go)
+ go (PrettyPrintObject t) = PrettyPrintObject <$> (f t >>= go)
+ go (PrettyPrintForAll args t) = PrettyPrintForAll args <$> (f t >>= go)
+ go other = f other
+
+everythingOnTypes :: (r -> r -> r) -> (Type -> r) -> Type -> r
+everythingOnTypes (<>) f = go
+ where
+ go t@(TypeApp t1 t2) = f t <> go t1 <> go t2
+ go t@(SaturatedTypeSynonym _ tys) = foldl (<>) (f t) (map go tys)
+ go t@(ForAll _ ty _) = f t <> go ty
+ go t@(ConstrainedType cs ty) = foldl (<>) (f t) (map go $ concatMap snd cs) <> go ty
+ go t@(RCons _ ty rest) = f t <> go ty <> go rest
+ go t@(PrettyPrintFunction t1 t2) = f t <> go t1 <> go t2
+ go t@(PrettyPrintArray t1) = f t <> go t1
+ go t@(PrettyPrintObject t1) = f t <> go t1
+ go t@(PrettyPrintForAll _ t1) = f t <> go t1
+ go other = f other
diff --git a/tests/Main.hs b/tests/Main.hs
index 4d9e8b7..4d8e306 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -60,7 +60,6 @@ assertCompiles preludeJs preludeExterns inputFile = do
let options = P.defaultOptions { P.optionsMain = Just "Main", P.optionsModules = ["Main"], P.optionsCodeGenModules = ["Main"], P.optionsBrowserNamespace = Just "Tests" }
assert preludeExterns options inputFile $ either (return . Just) $ \(js, _, _) -> do
process <- findNodeProcess
- putStrLn $ preludeJs ++ js
result <- traverse (\node -> readProcessWithExitCode node [] (preludeJs ++ js)) process
case result of
Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing