diff options
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 |