zephyr 0.3.2 → 0.5.3
raw patch · 21 files changed
+971/−656 lines, 21 filesdep +unordered-containersdep −base-compatdep ~Globdep ~aesondep ~ansi-terminalnew-uploader
Dependencies added: unordered-containers
Dependencies removed: base-compat
Dependency ranges changed: Glob, aeson, ansi-terminal, ansi-wl-pprint, base, boxes, bytestring, containers, directory, filepath, hspec-core, language-javascript, mtl, optparse-applicative, process, purescript, safe, text, transformers, utf8-string, zephyr
Files
- ChangeLog.md +36/−1
- README.md +9/−2
- app/Command/Options.hs +2/−2
- app/Command/Run.hs +22/−21
- app/Main.hs +3/−4
- src/Language/PureScript/DCE.hs +15/−1
- src/Language/PureScript/DCE/Constants.hs +14/−13
- src/Language/PureScript/DCE/CoreFn.hs +134/−22
- src/Language/PureScript/DCE/Errors.hs +3/−3
- src/Language/PureScript/DCE/Eval.hs +77/−76
- src/Language/PureScript/DCE/Foreign.hs +232/−217
- src/Language/PureScript/DCE/Utils.hs +0/−1
- test/Main.hs +6/−10
- test/Test/CoreFn.hs +105/−100
- test/Test/CoreLib.hs +2/−6
- test/Test/Eval.hs +39/−36
- test/Test/Generators.hs +12/−12
- test/Test/Karma.hs +0/−5
- test/Test/Lib.hs +151/−59
- test/Test/Utils.hs +44/−14
- zephyr.cabal +65/−51
ChangeLog.md view
@@ -1,3 +1,38 @@-# Verison v0.3.2+# ChangeLog+All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/)++## [Unreleased]++## [v0.5.3]+### Fixed+- Dead-code elimination of foreign es-modules now works++## [v0.5.2]+### Fixed+- Handling CoreFn generated by purescript since `0.15.3`+- Handling of multibyte UTF-8 characters correctly in foreign imports++## [v0.5.0]+### Added+- Update to PureScript 0.15 (#77 Thanks @i-am-the-slime)+- Migrate tests to es-modules++## [v0.4.0]+### Added+- Use purescript 0.14 for code generation++### Fixed+- DCE of re-exported symbols for purescipt 0.14 modules++## [v0.3.2] - Copy foreign modules from source directories if they are not present in the `output` directory.++[Unreleased]: https://github.com/MaybeJustJames/zephyr/compare/v0.5.3...HEAD+[v0.5.2]: https://github.com/MaybeJustJames/zephyr/compare/v0.5.2...v0.5.3+[v0.5.2]: https://github.com/MaybeJustJames/zephyr/compare/v0.5.0...v0.5.2+[v0.5.0]: https://github.com/MaybeJustJames/zephyr/compare/v0.4.0...v0.5.0+[v0.4.0]: https://github.com/MaybeJustJames/zephyr/compare/v0.3.2...v0.4.0+[v0.3.2]: https://github.com/MaybeJustJames/zephyr/compare/v0.3.1...v0.3.2
README.md view
@@ -1,5 +1,5 @@ # zephyr-[](http://github.com/coot)+[](http://github.com/MaybeJustJames)  A tree-shaking tool for [PureScript](https://github.com/purescript/purescript).@@ -8,6 +8,9 @@ and can substantially reduce the size of PureScript bundles. `zephyr` can also evaluate some expressions (an experimental feature). +# Installation+The simplest option is to download the latest [release](https://github.com/coot/zephyr/releases) binary. You may also build from source (see "Build & Test" section below).+ # Usage ```sh # compile your project@@ -76,7 +79,7 @@ * [parcel](https://github.com/parcel-bundler/parcel) * [spago](https://github.com/purescript/spago). See [this](https://github.com/thomashoneyman/purescript-halogen-realworld)- example. Use `spago build --purs-args '--codegen corefn'` to compile, using+ example. Use `spago build --purs-args '--codegen corefn,js'` to compile, using `spago bundle` is currently affected by [issue](https://github.com/purescript/spago/issues/216). @@ -91,6 +94,10 @@ ```sh cabal run zephyr-test ```++# C Libraries++The released binaries are dynamically linked against `glibc`, so if your system is using `musl` (like Alpine Linux in `docker`) or another alternative C library, you will need to compile `zephyr` from source using `ghc` on that system. # Comments
app/Command/Options.hs view
@@ -62,7 +62,7 @@ Opts.metavar "entry-point" <> Opts.help "Qualified identifier or a module name (it may be prefixed with `ident:` or `module:`). All code which is not a transitive dependency of an entry point (or any exported identifier from a give module) will be removed. You can pass multiple entry points." where- checkIfQualified (EntryPoint q@(P.Qualified Nothing _)) = fail $+ checkIfQualified (EntryPoint q@(P.Qualified (P.BySourcePos _) _)) = fail $ "not a qualified indentifier: '" ++ T.unpack (P.showQualified P.runIdent q) ++ "'" checkIfQualified e = return e @@ -78,7 +78,7 @@ Opts.short 'f' <> Opts.long "dce-foreign" <> Opts.showDefault- <> Opts.help "dce foriegn modules"+ <> Opts.help "dce foreign modules" comments :: Opts.Parser Bool comments = Opts.switch $
app/Command/Run.hs view
@@ -23,16 +23,13 @@ import qualified Data.Aeson.Internal as A import Data.Aeson.Parser (eitherDecodeWith, json) import qualified Data.ByteString.Lazy as BSL-import qualified Data.ByteString.Lazy.Char8 as BSL.Char8 (unpack) import qualified Data.ByteString.Lazy.UTF8 as BU8 import Data.Bool (bool)-import Data.Either (Either, lefts, rights, partitionEithers)+import Data.Either (lefts, rights, partitionEithers) import Data.Foldable (for_, traverse_)-import Data.List (null) import qualified Data.Map as M import qualified Data.Set as S import Data.Maybe (isNothing, listToMaybe)-import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy.Encoding as TE@@ -118,8 +115,8 @@ printWarningsAndErrors verbose True warnings errors = do hPutStrLn stderr . BU8.toString . A.encode $- P.JSONResult (P.toJSONErrors verbose P.Warning warnings)- (either (P.toJSONErrors verbose P.Error) (const []) errors)+ P.JSONResult (P.toJSONErrors verbose P.Warning [] warnings)+ (either (P.toJSONErrors verbose P.Error []) (const []) errors) either (const exitFailure) (const (return ())) errors @@ -147,19 +144,19 @@ 0 -> [] x -> ["... (" <> T.pack (show x) <> " more)"] in sformat- (string%": Failed parsing:\n "%stext)+ (string % ": Failed parsing:\n " % stext) (DCE.colorString DCE.errorColor "Error") (T.intercalate "\n\t" errs') formatDCEAppError _ _ (NoInputs path) = sformat- (stext%": No inputs found under "%string%" directory.\n"- %" Please run `purs compile --codegen corefn ..` or"- %"`pulp build -- --codegen corefn`")+ (stext % ": No inputs found under " % string % " directory.\n"+ % " Please run `purs compile --codegen corefn ..` or"+ % "`pulp build -- --codegen corefn`") (DCE.colorText DCE.errorColor "Error") (DCE.colorString DCE.codeColor path) formatDCEAppError _ _ (InputNotDirectory path) = sformat- (stext%": Directory "%string%" does not exists.")+ (stext % ": Directory "%string%" does not exists.") (DCE.colorText DCE.errorColor "Error") (DCE.colorString DCE.codeColor path) formatDCEAppError _ relPath (DCEAppError err)@@ -185,21 +182,25 @@ modExports :: P.ModuleName -> [CoreFn.Module CoreFn.Ann] -> [Either EntryPoint (P.Qualified P.Ident)] modExports mn [] = [Left (EntryModule mn)]- modExports mn (CoreFn.Module{ CoreFn.moduleName, CoreFn.moduleExports } : ms)+ modExports mn (CoreFn.Module{ CoreFn.moduleName, CoreFn.moduleExports, CoreFn.moduleReExports } : ms) | mn == moduleName- = (Right . flip P.mkQualified mn) `map` moduleExports+ = (Right . flip P.mkQualified mn) `map` (moduleExports ++ (snd =<< M.toList moduleReExports)) | otherwise = modExports mn ms fnd :: P.Qualified P.Ident -> [CoreFn.Module CoreFn.Ann] -> Bool fnd _ [] = False- fnd qi@(P.Qualified (Just mn) i) (CoreFn.Module{ CoreFn.moduleName, CoreFn.moduleExports } : ms)- = if moduleName == mn && i `elem` moduleExports+ fnd qi@(P.Qualified (P.ByModuleName mn) i) (pModule@CoreFn.Module{ CoreFn.moduleName } : ms)+ = if moduleName == mn && i `elem` (allExports pModule) then True else fnd qi ms fnd _ _ = False + allExports :: CoreFn.Module CoreFn.Ann -> [P.Ident]+ allExports CoreFn.Module{ CoreFn.moduleExports, CoreFn.moduleReExports } =+ moduleExports ++ (M.toList moduleReExports >>= snd) + dceCommand :: Options -> ExceptT DCEAppError IO () dceCommand Options { optEntryPoints , optInputDir@@ -243,7 +244,7 @@ fn _ acc = acc in throwError (DCEAppError $ EntryPointsNotParsed (foldr fn [] perrs)) - when (null $ entryPoints) $+ when (null entryPoints) $ throwError (DCEAppError NoEntryPoint) -- run `evaluate` and `runDeadCodeElimination` on `CoreFn` representation@@ -268,12 +269,12 @@ case moduleName `M.lookup` foreigns of -- run `runForeignModuleDeadCodeElimination` Just path | optForeign -> do- jsCode <- BSL.Char8.unpack <$> BSL.readFile path- case JS.parse jsCode path of+ jsCode <- BU8.toString <$> BSL.readFile path+ case JS.parseModule jsCode path of Left _ -> return ()- Right (JS.JSAstProgram ss ann) ->- let ss' = DCE.runForeignModuleDeadCodeElimination moduleForeign ss- jsAst' = JS.JSAstProgram ss' ann+ Right (JS.JSAstModule items ann) ->+ let items' = DCE.runForeignModuleDeadCodeElimination moduleForeign items+ jsAst' = JS.JSAstModule items' ann foreignFile = optOutputDir </> T.unpack (P.runModuleName moduleName) </> "foreign.js"
app/Main.hs view
@@ -1,14 +1,13 @@ module Main (main) where -import Data.Monoid ((<>)) import Data.Version (showVersion) import qualified Options.Applicative as Opts import qualified Paths_zephyr as Paths import System.Environment (getArgs) import qualified System.IO as IO -import Command.Run-import Command.Options+import Command.Run ( runZephyr )+import Command.Options ( parseOptions ) main :: IO ()@@ -23,7 +22,7 @@ where execParserPure :: Opts.ParserInfo a -> [String] -> Opts.ParserResult a execParserPure pinfo [] = Opts.Failure $- Opts.parserFailure Opts.defaultPrefs pinfo Opts.ShowHelpText mempty+ Opts.parserFailure Opts.defaultPrefs pinfo (Opts.ShowHelpText Nothing) mempty execParserPure pinfo args = Opts.execParserPure Opts.defaultPrefs pinfo args versionOpt :: Opts.Parser (a -> a)
src/Language/PureScript/DCE.hs view
@@ -2,6 +2,20 @@ ( module DCE ) where import Language.PureScript.DCE.CoreFn as DCE+ ( runDeadCodeElimination, runBindDeadCodeElimination ) import Language.PureScript.DCE.Foreign as DCE+ ( runForeignModuleDeadCodeElimination ) import Language.PureScript.DCE.Errors as DCE-import Language.PureScript.DCE.Eval as DCE+ ( Level(..),+ DCEError(..),+ EntryPoint(..),+ isEntryParseError,+ showEntryPoint,+ displayDCEError,+ displayDCEWarning,+ errorColor,+ warnColor,+ codeColor,+ colorString,+ colorText )+import Language.PureScript.DCE.Eval as DCE ( evaluate )
src/Language/PureScript/DCE/Constants.hs view
@@ -1,49 +1,50 @@--- |--- Various constants used by zephyr.+-- | Various constants used by zephyr.+-- module Language.PureScript.DCE.Constants where import Prelude hiding (maybe) import Language.PureScript.Names + unit :: ModuleName unit = ModuleName "Data.Unit" pattern Unit :: ModuleName pattern Unit = ModuleName "Data.Unit" -semigroup :: ModuleName-semigroup = ModuleName "Data.Semigroup"- maybeMod :: ModuleName maybeMod = ModuleName "Data.Maybe" +semigroup :: ModuleName+semigroup = ModuleName "Data.Semigroup"+ pattern Semigroup :: ModuleName pattern Semigroup = ModuleName "Data.Semigroup" semiring :: ModuleName semiring = ModuleName "Data.Semiring" -pattern Ring :: ModuleName-pattern Ring = ModuleName "Data.Ring"- ring :: ModuleName ring = ModuleName "Data.Ring" +pattern Ring :: ModuleName+pattern Ring = ModuleName "Data.Ring"+ pattern Semiring :: ModuleName pattern Semiring = ModuleName "Data.Semiring" -pattern HeytingAlgebra :: ModuleName-pattern HeytingAlgebra = ModuleName "Data.HeytingAlgebra"- heytingAlgebra :: ModuleName heytingAlgebra = ModuleName "Data.HeytingAlgebra" -pattern UnsafeCoerce :: ModuleName-pattern UnsafeCoerce = ModuleName "Unsafe.Coerce"+pattern HeytingAlgebra :: ModuleName+pattern HeytingAlgebra = ModuleName "Data.HeytingAlgebra" unsafeCoerce :: ModuleName unsafeCoerce = ModuleName "Unsafe.Coerce"++pattern UnsafeCoerce :: ModuleName+pattern UnsafeCoerce = ModuleName "Unsafe.Coerce" eqMod :: ModuleName eqMod = ModuleName "Data.Eq"
src/Language/PureScript/DCE/CoreFn.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE NoImplicitPrelude #-}+ -- | -- Dead code elimination for `CoreFn`. module Language.PureScript.DCE.CoreFn@@ -5,17 +7,35 @@ , runBindDeadCodeElimination ) where -import Prelude.Compat hiding (mod)+import Prelude hiding (mod) import Control.Arrow ((***))-import Control.Monad-import Data.Graph+import Control.Monad ( guard )+import Data.Graph ( graphFromEdges, reachable, Vertex ) import Data.Foldable (foldl', foldr')-import Data.List (any, elem, filter, groupBy, sortBy)+import Data.List (groupBy, sortBy)+import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, mapMaybe) import qualified Data.Set as S-import Language.PureScript.CoreFn+import Language.PureScript.CoreFn+ ( Literal(ObjectLiteral, ArrayLiteral),+ Ann,+ everywhereOnValues,+ Binder(VarBinder, LiteralBinder, ConstructorBinder, NamedBinder),+ Bind(..),+ CaseAlternative(CaseAlternative),+ Expr(..),+ Module(Module, moduleImports, moduleExports, moduleForeign,+ moduleDecls, moduleName, moduleReExports) ) import Language.PureScript.DCE.Utils (bindIdents, unBind)-import Language.PureScript.Names+import Language.PureScript.Names+ ( getQual,+ isQualified,+ mkQualified,+ Ident(Ident),+ ModuleName,+ ProperName(runProperName),+ Qualified(..),+ QualifiedBy(..) ) type Key = Qualified Ident @@ -23,6 +43,7 @@ data DCEVertex = BindVertex (Bind Ann) | ForeignVertex (Qualified Ident)+ | ReExportedVertex (Qualified Ident) -- | Dead code elimination of a list of modules module@@ -40,15 +61,16 @@ -- DCE of a single module. runModuleDeadCodeElimination :: [(DCEVertex, Key, [Key])]- -- list of qualified names that has to be preserved+ -- list of qualified names that need to be preserved -> Module Ann -> Module Ann runModuleDeadCodeElimination vs mod@Module{ moduleDecls , moduleExports+ , moduleReExports , moduleImports , moduleName , moduleForeign- } = + } = let -- | filter declarations preserving the order moduleDecls' :: [Bind Ann]@@ -71,6 +93,17 @@ moduleExports' = filter (`elem` (idents ++ moduleForeign')) moduleExports + moduleReExports' :: M.Map ModuleName [Ident]+ moduleReExports' =+ filter (`elem` rexpIdents) <$> moduleReExports+ where+ toRexpIdents :: (DCEVertex, Key, [Key]) -> [Ident]+ toRexpIdents (ReExportedVertex (Qualified _ i), _, _) = [i]+ toRexpIdents _ = []++ rexpIdents :: [Ident]+ rexpIdents = concatMap toRexpIdents vs+ mods :: [ModuleName] mods = mapMaybe getQual (concatMap (\(_, _, ks) -> ks) vs) @@ -79,7 +112,7 @@ moduleForeign' :: [Ident] moduleForeign' = filter- ((`S.member` reachableSet) . Qualified (Just moduleName))+ ((`S.member` reachableSet) . Qualified (ByModuleName moduleName)) moduleForeign where reachableSet = foldr'@@ -88,6 +121,7 @@ in mod { moduleImports = moduleImports' , moduleExports = moduleExports'+ , moduleReExports = moduleReExports' , moduleForeign = moduleForeign' , moduleDecls = moduleDecls' }@@ -97,9 +131,10 @@ -- | The Vertex set. verts :: [(DCEVertex, Key, [Key])] verts = do- Module _ _ mn _ _ _ mf ds <- modules- concatMap (toVertices mn) ds- ++ ((\q -> (ForeignVertex q, q, [])) . flip mkQualified mn) `map` mf+ Module _ _ mn _ _ _ rexp mf ds <- modules+ concatMap (toVertices mn) ds -- Module local bindings+ ++ ((\q -> (ForeignVertex q, q, [])) . flip mkQualified mn) `map` mf -- Foreign bindings+ ++ reExportedVertices mn rexp -- Re-exported bindings where toVertices :: ModuleName -> Bind Ann -> [(DCEVertex, Key, [Key])] toVertices mn b@(NonRec _ i e) =@@ -109,26 +144,103 @@ ks = map (\((_, i), e) -> (mkQualified i mn, deps e)) bs in map (\(k, ks') -> (BindVertex b, k, map fst ks ++ ks')) ks + reExportedVertices :: ModuleName -> M.Map ModuleName [Ident] -> [(DCEVertex, Key, [Key])]+ reExportedVertices parent rexp =+ filter (isReExported rexp) modules >>= rexpsFor+ where+ rexpsFor :: Module Ann -> [(DCEVertex, Key, [Key])]+ rexpsFor (Module _ _ mn _ _ _ _ _ _) = case M.lookup mn rexp of+ Nothing -> []+ Just ids -> (\i -> (ReExportedVertex (mkQualified i parent)+ , mkQualified i parent+ , [mkQualified i mn])+ ) <$> ids+++ isReExported :: M.Map ModuleName [Ident] -> Module Ann -> Bool+ isReExported rexps (Module _ _ name _ _ _ _ _ _) =+ M.member name rexps+ -- | Find dependencies of an expression. deps :: Expr Ann -> [Key]- deps = go+ deps = traverseExpr where- (_, go, _, _) = everythingOnValues (++)- (const [])- onExpr- onBinder- (const [])- -- | Build graph from qualified identifiers. onExpr :: Expr Ann -> [Key] onExpr (Var _ i) = [i | isQualified i] onExpr _ = [] + traverseExpr :: Expr Ann -> [Key]+ traverseExpr v@(Literal _ l) =+ foldl'+ (++)+ (onExpr v)+ (map traverseExpr (extractLiteral l))+ traverseExpr v@Constructor {} = onExpr v+ traverseExpr v@(Accessor _ _ e1) = onExpr v ++ traverseExpr e1+ traverseExpr v@(ObjectUpdate _ obj vs) =+ foldl'+ (++)+ (onExpr v ++ traverseExpr obj)+ (map (traverseExpr . snd) vs)+ traverseExpr v@(Abs _ _ e1) = onExpr v ++ traverseExpr e1+ traverseExpr v@(App _ e1 e2) =+ onExpr v ++ traverseExpr e1 ++ traverseExpr e2+ traverseExpr v@(Var _ _) = onExpr v+ traverseExpr v@(Case _ vs alts) =+ foldl'+ (++)+ (foldl' (++) (onExpr v) (map traverseExpr vs))+ (map onCaseAlternative alts)+ traverseExpr v@(Let _ ds e1) =+ foldl'+ (++)+ (onExpr v)+ (map onBind ds)+ +++ traverseExpr e1++ onBind :: Bind Ann -> [Key]+ onBind (NonRec _ _ e) = traverseExpr e+ onBind (Rec es) = concatMap (traverseExpr . snd) es+ onBinder :: Binder Ann -> [Key]- onBinder (ConstructorBinder _ _ c _) =+ onBinder b@(LiteralBinder _ l) =+ foldl'+ (++)+ (onBinder' b)+ (map onBinder (extractLiteral l))+ onBinder b@(ConstructorBinder _ _ _ bs) =+ foldl'+ (++)+ (onBinder' b)+ (map onBinder bs)+ onBinder b@(NamedBinder _ _ b1) = onBinder' b ++ onBinder b1+ onBinder b = onBinder' b++ onBinder' :: Binder Ann -> [Key]+ onBinder' (ConstructorBinder _ _ c _) = [fmap (Ident . runProperName) c]- onBinder _ = []+ onBinder' _ = [] + onCaseAlternative :: CaseAlternative Ann -> [Key]+ onCaseAlternative (CaseAlternative bs (Right val)) =+ concatMap onBinder bs ++ traverseExpr val+ onCaseAlternative (CaseAlternative bs (Left gs)) =+ concat+ (map+ onBinder+ bs ++ concatMap+ (\(grd, val) ->+ [traverseExpr grd, traverseExpr val]) gs)++ -- @f@ is either 'Expr' or 'Binder'+ extractLiteral :: Literal (f Ann) -> [f Ann]+ extractLiteral (ArrayLiteral xs) = xs+ extractLiteral (ObjectLiteral xs) = map snd xs+ extractLiteral _ = []++ -- | Vertices corresponding to the entry points which we want to keep. entryPointVertices :: [Vertex] entryPointVertices = catMaybes $ do@@ -222,7 +334,7 @@ else isUsedInExpr i e isUsedInExpr i (App _ l r) = isUsedInExpr i l || isUsedInExpr i r isUsedInExpr i (Abs _ i' e) = i /= i' && isUsedInExpr i e- isUsedInExpr i (Var _ qi) = qi == Qualified Nothing i+ isUsedInExpr i (Var _ qi@(Qualified by _)) = qi == Qualified by i isUsedInExpr i (Case _ es alts) = any (isUsedInExpr i) es || any (isUsedInCaseAlternative i) alts isUsedInExpr i (Let _ bs e) =
src/Language/PureScript/DCE/Errors.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE NoImplicitPrelude #-}+ -- | -- Errors used in dead call elimination. module Language.PureScript.DCE.Errors@@ -16,11 +18,9 @@ ) where -import Prelude.Compat-+import Prelude hiding (mod) import Data.Char (isLower, isUpper, isSpace) import Data.List (dropWhileEnd, findIndex, intersperse)-import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import Formatting (sformat, string, stext, (%))
src/Language/PureScript/DCE/Eval.hs view
@@ -1,26 +1,27 @@+{-# LANGUAGE NoImplicitPrelude #-}+ -- | Evaluation of PureScript's expressions used in dead call elimnation. -- module Language.PureScript.DCE.Eval ( evaluate ) where +import Prelude hiding (mod)+ import Control.Applicative ((<|>)) import Control.Exception (Exception (..), throw) import Control.Monad import Control.Monad.Writer import Data.List (find)-import Data.Maybe (Maybe(..), fromMaybe)-import Data.Monoid (First(..))+import Data.Maybe (fromMaybe) import qualified Data.Text as T import qualified Language.PureScript.DCE.Constants as C-import Prelude.Compat hiding (mod) import Safe (atMay) import Language.PureScript.AST.Literals import Language.PureScript.CoreFn---import Language.PureScript.DCE.Errors import Language.PureScript.DCE.Utils-import Language.PureScript.Names+import Language.PureScript.Names (Ident(..), ModuleName(..), Qualified(..), QualifiedBy(..)) import Language.PureScript.PSString @@ -243,13 +244,13 @@ -- eval _ _ _ _ = Nothing -- TODO: testing without evaluation -eval mods mn st (Var _ (Qualified Nothing i)) = +eval mods mn st (Var _ (Qualified (BySourcePos _) i)) = case lookupStack i st of Nothing -> Nothing Just ((_, e), Done) -> Just e Just ((_, e), NotYet) -> eval mods mn (markDone i st) e -eval mods mn st (Var ann qi@(Qualified (Just imn) i)) =+eval mods mn st (Var ann qi@(Qualified (ByModuleName imn) i)) = case lookupQualifiedExpr mods imn i of Nothing -> throw (QualifiedExpresionError ann qi (moduleName `map` mods)) Just (FoundExpr e) -> eval mods mn st e@@ -284,19 +285,19 @@ (App _ (Var _ (Qualified- (Just C.Eq)+ (ByModuleName C.Eq) (Ident "eq"))) (Var _ inst)) e1) e2) = if inst `elem`- [ Qualified (Just C.eqMod) (Ident "eqBoolean")- , Qualified (Just C.eqMod) (Ident "eqInt")- , Qualified (Just C.eqMod) (Ident "eqNumber")- , Qualified (Just C.eqMod) (Ident "eqChar")- , Qualified (Just C.eqMod) (Ident "eqString")- , Qualified (Just C.eqMod) (Ident "eqUnit")- , Qualified (Just C.eqMod) (Ident "eqVoid")+ [ Qualified (ByModuleName C.eqMod) (Ident "eqBoolean")+ , Qualified (ByModuleName C.eqMod) (Ident "eqInt")+ , Qualified (ByModuleName C.eqMod) (Ident "eqNumber")+ , Qualified (ByModuleName C.eqMod) (Ident "eqChar")+ , Qualified (ByModuleName C.eqMod) (Ident "eqString")+ , Qualified (ByModuleName C.eqMod) (Ident "eqUnit")+ , Qualified (ByModuleName C.eqMod) (Ident "eqVoid") ] then case (eval mods mn st e1, eval mods mn st e2) of (Just (Literal _ l1), Just (Literal _ l2))@@ -312,7 +313,7 @@ (App _ (Var ann@(ss, _, _, _) (Qualified- (Just (ModuleName "Data.Array"))+ (ByModuleName (ModuleName "Data.Array")) (Ident "index"))) (Literal _ (ArrayLiteral as))) (Literal _ (NumericLiteral (Left x)))) =@@ -324,7 +325,7 @@ Just $ App ann (Var (ss, [], Nothing, Just (IsConstructor SumType [Ident "value0"])) (Qualified- (Just C.maybeMod)+ (ByModuleName C.maybeMod) (Ident "Just"))) e' --@@ -334,22 +335,22 @@ (App ann (App _ (App _- (Var _ (Qualified (Just C.Semigroup) (Ident "append")))+ (Var _ (Qualified (ByModuleName C.Semigroup) (Ident "append"))) (Var _ qi)) e1) e2)- | qi == Qualified (Just C.semigroup) (Ident "semigroupArray")+ | qi == Qualified (ByModuleName C.semigroup) (Ident "semigroupArray") , Literal _ (ArrayLiteral a1) <- e1 , Literal _ (ArrayLiteral a2) <- e2 = Just $ Literal ann (ArrayLiteral $ a1 ++ a2)- | qi == Qualified (Just C.semigroup) (Ident "semigroupString")+ | qi == Qualified (ByModuleName C.semigroup) (Ident "semigroupString") , Literal _ (StringLiteral s1) <- e1 , Just t1 <- decodeString s1 , Literal _ (StringLiteral s2) <- e2 , Just t2 <- decodeString s2 = Just $ Literal ann (StringLiteral (mkString $ t1 <> t2) )- | qi == Qualified (Just C.semigroup) (Ident "semigroupUnit")- = Just $ Var ann (Qualified (Just C.unit) (Ident "unit"))+ | qi == Qualified (ByModuleName C.semigroup) (Ident "semigroupUnit")+ = Just $ Var ann (Qualified (ByModuleName C.unit) (Ident "unit")) | otherwise = Nothing @@ -360,66 +361,66 @@ (App (ss, c, _, _) (App _ (App _- (Var _ (Qualified (Just C.Semiring) (Ident "add")))+ (Var _ (Qualified (ByModuleName C.Semiring) (Ident "add"))) (Var _ qi)) e1) e2)- | qi == Qualified (Just C.semiring) (Ident "semiringInt")+ | qi == Qualified (ByModuleName C.semiring) (Ident "semiringInt") , Literal _ (NumericLiteral (Left a1)) <- e1 , Literal _ (NumericLiteral (Left a2)) <- e2 = Just $ Literal (ss, c, Nothing, Nothing) (NumericLiteral (Left (a1 + a2)))- | qi == Qualified (Just C.semiring) (Ident "semiringNumber")+ | qi == Qualified (ByModuleName C.semiring) (Ident "semiringNumber") , Literal _ (NumericLiteral (Right a1)) <- e1 , Literal _ (NumericLiteral (Right a2)) <- e2 = Just $ Literal (ss, c, Nothing, Nothing) (NumericLiteral (Right (a1 + a2)))- | qi == Qualified (Just C.semiring) (Ident "semiringUnit")+ | qi == Qualified (ByModuleName C.semiring) (Ident "semiringUnit") = Just $ Var (ss, c, Nothing, Nothing)- (Qualified (Just C.unit) (Ident "unit"))+ (Qualified (ByModuleName C.unit) (Ident "unit")) | otherwise = Nothing eval _ _mn _st (App (ss, c, _, _)- (Var _ (Qualified (Just C.Semiring) (Ident "zero")))+ (Var _ (Qualified (ByModuleName C.Semiring) (Ident "zero"))) (Var _ qi))- | qi == Qualified (Just C.semiring) (Ident "semiringInt")+ | qi == Qualified (ByModuleName C.semiring) (Ident "semiringInt") = Just $ Literal (ss, c, Nothing, Nothing) (NumericLiteral (Left 0)) | qi == Qualified- (Just C.semiring)+ (ByModuleName C.semiring) (Ident "semiringNumber") = Just $ Literal (ss, c, Nothing, Nothing) (NumericLiteral (Right 0.0))- | qi == Qualified (Just C.semiring) (Ident "semiringUnit")+ | qi == Qualified (ByModuleName C.semiring) (Ident "semiringUnit") = Just $ Var (ss, c, Nothing, Nothing)- (Qualified (Just C.unit) (Ident "unit"))+ (Qualified (ByModuleName C.unit) (Ident "unit")) | otherwise = Nothing eval _ _mn _st (App (ss, c, _, _)- (Var _ (Qualified (Just C.Semiring) (Ident "one")))+ (Var _ (Qualified (ByModuleName C.Semiring) (Ident "one"))) (Var _ qi))- | qi == Qualified (Just C.semiring) (Ident "semiringInt")+ | qi == Qualified (ByModuleName C.semiring) (Ident "semiringInt") = Just $ Literal (ss, c, Nothing, Nothing) (NumericLiteral (Left 1))- | qi == Qualified (Just C.semiring) (Ident "semiringNumber")+ | qi == Qualified (ByModuleName C.semiring) (Ident "semiringNumber") = Just $ Literal (ss, c, Nothing, Nothing) (NumericLiteral (Right 1.0))- | qi == Qualified (Just C.semiring) (Ident "semiringUnit")+ | qi == Qualified (ByModuleName C.semiring) (Ident "semiringUnit") = Just $ Var (ss, c, Nothing, Nothing)- (Qualified (Just C.unit) (Ident "unit"))+ (Qualified (ByModuleName C.unit) (Ident "unit")) | otherwise = Nothing @@ -427,26 +428,26 @@ (App (ss, c, _, _) (App _ (App _- (Var _ (Qualified (Just C.Semiring) (Ident "mul")))+ (Var _ (Qualified (ByModuleName C.Semiring) (Ident "mul"))) (Var _ qi)) e1) e2)- | qi == Qualified (Just C.semiring) (Ident "semiringInt")+ | qi == Qualified (ByModuleName C.semiring) (Ident "semiringInt") , Literal _ (NumericLiteral (Left a1)) <- e1 , Literal _ (NumericLiteral (Left a2)) <- e2 = Just $ Literal (ss, c, Nothing, Nothing) (NumericLiteral (Left (a1 * a2)))- | qi == Qualified (Just C.semiring) (Ident "semiringNumber")+ | qi == Qualified (ByModuleName C.semiring) (Ident "semiringNumber") , Literal _ (NumericLiteral (Right a1)) <- e1 , Literal _ (NumericLiteral (Right a2)) <- e2 = Just $ Literal (ss, c, Nothing, Nothing) (NumericLiteral (Right (a1 * a2)))- | qi == Qualified (Just C.semiring) (Ident "semiringUnit")+ | qi == Qualified (ByModuleName C.semiring) (Ident "semiringUnit") = Just $ Var (ss, c, Nothing, Nothing)- (Qualified (Just C.unit) (Ident "unit"))+ (Qualified (ByModuleName C.unit) (Ident "unit")) | otherwise = Nothing @@ -457,92 +458,92 @@ (App (ss, c, _, _) (App _ (App _- (Var _ (Qualified (Just C.Ring) (Ident "sub")))+ (Var _ (Qualified (ByModuleName C.Ring) (Ident "sub"))) (Var _ qi)) e1) e2)- | qi == Qualified (Just C.ring) (Ident "ringInt")+ | qi == Qualified (ByModuleName C.ring) (Ident "ringInt") , Literal _ (NumericLiteral (Left a1)) <- e1 , Literal _ (NumericLiteral (Left a2)) <- e2 = Just $ Literal (ss, c, Nothing, Nothing) (NumericLiteral (Left (quot a1 a2)))- | qi == Qualified (Just C.ring) (Ident "ringNumber")+ | qi == Qualified (ByModuleName C.ring) (Ident "ringNumber") , Literal _ (NumericLiteral (Right a1)) <- e1 , Literal _ (NumericLiteral (Right a2)) <- e2 = Just $ Literal (ss, c, Nothing, Nothing) (NumericLiteral (Right (a1 / a2)))- | qi == Qualified (Just C.ring) (Ident "unitRing")+ | qi == Qualified (ByModuleName C.ring) (Ident "unitRing") = Just $ Var (ss, c, Nothing, Nothing)- (Qualified (Just C.unit) (Ident "unit"))+ (Qualified (ByModuleName C.unit) (Ident "unit")) eval _ _mn _st (App (ss, c, _, _) (App _- (Var _ (Qualified (Just C.Ring) (Ident "negate")))+ (Var _ (Qualified (ByModuleName C.Ring) (Ident "negate"))) (Var _ qi)) e)- | qi == Qualified (Just C.ring) (Ident "ringInt")+ | qi == Qualified (ByModuleName C.ring) (Ident "ringInt") , Literal _ (NumericLiteral (Left a)) <- e = Just $ Literal (ss, c, Nothing, Nothing) (NumericLiteral (Left (-a)))- | qi == Qualified (Just C.ring) (Ident "ringNumber")+ | qi == Qualified (ByModuleName C.ring) (Ident "ringNumber") , Literal _ (NumericLiteral (Right a)) <- e = Just $ Literal (ss, c, Nothing, Nothing) (NumericLiteral (Right (-a)))- | qi == Qualified (Just C.ring) (Ident "unitRing")+ | qi == Qualified (ByModuleName C.ring) (Ident "unitRing") = Just $ Var (ss, c, Nothing, Nothing)- (Qualified (Just C.unit) (Ident "unit"))+ (Qualified (ByModuleName C.unit) (Ident "unit")) -- -- evaluate Heyting algebras operations -- eval _ _mn _st (App (ss, c, _, _)- (Var _ (Qualified (Just C.HeytingAlgebra) (Ident "ff")))+ (Var _ (Qualified (ByModuleName C.HeytingAlgebra) (Ident "ff"))) (Var _ qi))- | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraBoolean")+ | qi == Qualified (ByModuleName C.heytingAlgebra) (Ident "heytingAlgebraBoolean") = Just $ Literal (ss, c, Nothing, Nothing) (BooleanLiteral False)- | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraUnit")+ | qi == Qualified (ByModuleName C.heytingAlgebra) (Ident "heytingAlgebraUnit") = Just $ Var (ss, c, Nothing, Nothing)- (Qualified (Just C.unit) (Ident "unit"))+ (Qualified (ByModuleName C.unit) (Ident "unit")) | otherwise = Nothing eval _ _mn _st (App (ss, c, _, _)- (Var _ (Qualified (Just C.HeytingAlgebra) (Ident "tt")))+ (Var _ (Qualified (ByModuleName C.HeytingAlgebra) (Ident "tt"))) (Var _ qi))- | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraBoolean")+ | qi == Qualified (ByModuleName C.heytingAlgebra) (Ident "heytingAlgebraBoolean") = Just $ Literal (ss, c, Nothing, Nothing) (BooleanLiteral True)- | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraUnit")+ | qi == Qualified (ByModuleName C.heytingAlgebra) (Ident "heytingAlgebraUnit") = Just $ Var (ss, c, Nothing, Nothing)- (Qualified (Just C.unit) (Ident "unit"))+ (Qualified (ByModuleName C.unit) (Ident "unit")) | otherwise = Nothing eval _mods _mn _st (App (ss, c, _, _) (App _- (Var _ (Qualified (Just C.HeytingAlgebra) (Ident "not")))+ (Var _ (Qualified (ByModuleName C.HeytingAlgebra) (Ident "not"))) (Var _ qi)) e)- | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraBoolean")+ | qi == Qualified (ByModuleName C.heytingAlgebra) (Ident "heytingAlgebraBoolean") , Literal _ (BooleanLiteral b) <- e = Just $ Literal (ss, c, Nothing, Nothing) (BooleanLiteral (not b))- | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraUnit")+ | qi == Qualified (ByModuleName C.heytingAlgebra) (Ident "heytingAlgebraUnit") = Just $ Var (ss, c, Nothing, Nothing)- (Qualified (Just C.unit) (Ident "unit"))+ (Qualified (ByModuleName C.unit) (Ident "unit")) | otherwise = Nothing @@ -550,20 +551,20 @@ (App (ss, c, _, _) (App _ (App _- (Var _ (Qualified (Just C.HeytingAlgebra) (Ident "implies")))+ (Var _ (Qualified (ByModuleName C.HeytingAlgebra) (Ident "implies"))) (Var _ qi)) e1) e2)- | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraBoolean")+ | qi == Qualified (ByModuleName C.heytingAlgebra) (Ident "heytingAlgebraBoolean") , Literal _ (BooleanLiteral b1) <- e1 , Literal _ (BooleanLiteral b2) <- e2 = Just $ Literal (ss, c, Nothing, Nothing) (BooleanLiteral (not b1 && b2))- | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraUnit")+ | qi == Qualified (ByModuleName C.heytingAlgebra) (Ident "heytingAlgebraUnit") = Just $ Var (ss, c, Nothing, Nothing)- (Qualified (Just C.unit) (Ident "unit"))+ (Qualified (ByModuleName C.unit) (Ident "unit")) | otherwise = Nothing @@ -571,20 +572,20 @@ (App (ss, c, _, _) (App _ (App _- (Var _ (Qualified (Just C.HeytingAlgebra) (Ident "disj")))+ (Var _ (Qualified (ByModuleName C.HeytingAlgebra) (Ident "disj"))) (Var _ qi)) e1) e2)- | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraBoolean")+ | qi == Qualified (ByModuleName C.heytingAlgebra) (Ident "heytingAlgebraBoolean") , Literal _ (BooleanLiteral b1) <- e1 , Literal _ (BooleanLiteral b2) <- e2 = Just $ Literal (ss, c, Nothing, Nothing) (BooleanLiteral (b1 || b2))- | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraUnit")+ | qi == Qualified (ByModuleName C.heytingAlgebra) (Ident "heytingAlgebraUnit") = Just $ Var (ss, c, Nothing, Nothing)- (Qualified (Just C.unit) (Ident "unit"))+ (Qualified (ByModuleName C.unit) (Ident "unit")) | otherwise = Nothing @@ -592,20 +593,20 @@ (App (ss, c, _, _) (App _ (App _- (Var _ (Qualified (Just C.HeytingAlgebra) (Ident "conj")))+ (Var _ (Qualified (ByModuleName C.HeytingAlgebra) (Ident "conj"))) (Var _ qi)) e1) e2)- | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraBoolean")+ | qi == Qualified (ByModuleName C.heytingAlgebra) (Ident "heytingAlgebraBoolean") , Literal _ (BooleanLiteral b1) <- e1 , Literal _ (BooleanLiteral b2) <- e2 = Just $ Literal (ss, c, Nothing, Nothing) (BooleanLiteral (b1 && b2))- | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraUnit")+ | qi == Qualified (ByModuleName C.heytingAlgebra) (Ident "heytingAlgebraUnit") = Just $ Var (ss, c, Nothing, Nothing)- (Qualified (Just C.unit) (Ident "unit"))+ (Qualified (ByModuleName C.unit) (Ident "unit")) | otherwise = Nothing
src/Language/PureScript/DCE/Foreign.hs view
@@ -3,252 +3,267 @@ -- | -- Simple dead call elimination in foreign modules. module Language.PureScript.DCE.Foreign- ( runForeignModuleDeadCodeElimination- ) where+ ( runForeignModuleDeadCodeElimination,+ )+where -import Prelude.Compat-import Control.Monad-import Data.Graph-import Data.Foldable (foldr')-import Data.List (any, elem, filter)-import Data.Maybe (catMaybes, fromMaybe, mapMaybe)-import Data.Text (Text)+import Data.Foldable (foldr')+import Data.Graph (graphFromEdges, reachable, transposeG)+import Data.List (nub)+import Data.Maybe (catMaybes, mapMaybe)+import Data.Text (Text) import qualified Data.Text as T-import Language.JavaScript.Parser.AST- ( JSStatement(..)- , JSExpression(..)- , JSCommaList(..)- , JSBlock(..)- , JSSwitchParts(..)- , JSTryCatch(..)- , JSTryFinally(..)- , JSArrayElement(..)- , JSObjectProperty(..)- , JSCommaTrailingList(..)- , JSCommaList(..)- , JSMethodDefinition(..)- , JSClassElement(..)- , JSClassHeritage(..)- , JSTemplatePart(..)- )-import Language.PureScript.Names---- | foldr over `JSCommaList`-foldrJSCommaList :: (a -> b -> b) -> JSCommaList a -> b -> b-foldrJSCommaList _ JSLNil b = b-foldrJSCommaList fn (JSLOne a) !b = fn a b-foldrJSCommaList fn (JSLCons as _ a) !b = foldrJSCommaList fn as (fn a b)+import Language.JavaScript.Parser.AST+ ( JSArrayElement (..),+ JSBlock (..),+ JSClassElement (..),+ JSClassHeritage (..),+ JSCommaList (..),+ JSCommaTrailingList (..),+ JSExportClause (..),+ JSExportDeclaration (..),+ JSExportSpecifier (..),+ JSExpression (..),+ JSIdent (..),+ JSMethodDefinition (..),+ JSModuleItem (..),+ JSObjectProperty (..),+ JSStatement (..),+ JSSwitchParts (..),+ JSTemplatePart (..),+ JSTryCatch (..),+ JSTryFinally (..),+ JSVarInitializer (..),+ )+import Language.PureScript.Names (Ident, runIdent) -- | Filter export statements in a foreign module. This is not 100% safe. It -- might remove declarations that are used somewhere in the foreign module (for -- example by using @'eval'@).----runForeignModuleDeadCodeElimination :: [Ident] -> [JSStatement] -> [JSStatement]-runForeignModuleDeadCodeElimination is stmts = filter filterExports stmts+runForeignModuleDeadCodeElimination :: [Ident] -> [JSModuleItem] -> [JSModuleItem]+runForeignModuleDeadCodeElimination is items = nub allReachable where- filterExports :: JSStatement -> Bool- filterExports (JSAssignStatement (JSMemberSquare (JSIdentifier _ "exports") _ (JSStringLiteral _ x) _) _ _ _)- = fltr (unquote . T.pack $ x)- filterExports (JSAssignStatement (JSMemberDot (JSIdentifier _ "exports") _ (JSIdentifier _ x)) _ _ _)- = fltr (T.pack x)- filterExports _ = True-- fltr :: Text -> Bool- fltr t = any (fromMaybe True . (path graph <$> vertexForKey t <*>) . Just) entryPointVertices- -- one of `entryPointVertices` depend on this vertex- || any (isUsedInStmt t) nonExps- -- it is used in any non export statements+ allReachable :: [JSModuleItem]+ allReachable = do+ ePoint <- mapMaybe (vertexForKey . runIdent) is+ reachableNode <- reachable (transposeG graph) ePoint+ pure $ jsM $ fromVertex reachableNode -- Build a graph of exports statements. Its initial set of edges point from -- an export statement to all other export statements that are using it. -- When checking if we need to include that vartex we just check if there is -- a path from a vertex to one of `entryPointVertices`.- exps :: [JSStatement]- exps = filter isExportStatement stmts+ exps :: [JSModuleItem]+ exps = filter isExportModuleItem items - nonExps = filter (not . isExportStatement) stmts+ (graph, fromVertex, vertexForKey) = graphFromEdges verts - (graph, _, vertexForKey) = graphFromEdges verts+ jsM :: (JSModuleItem, Text, [Text]) -> JSModuleItem+ jsM (a, _, _) = a - verts :: [(JSStatement, Text, [Text])]- verts = mapMaybe toVert exps+ verts :: [(JSModuleItem, Text, [Text])]+ verts = items >>= toVert where- toVert :: JSStatement -> Maybe (JSStatement, Text, [Text])- toVert s- | Just name <- exportStatementName s = Just (s, name, foldr' (fn name) [] exps)- | otherwise = Nothing+ toVert :: JSModuleItem -> [(JSModuleItem, Text, [Text])]+ toVert item@(JSModuleExportDeclaration _ jsExportDec) = mkVertex item <$> exportNames jsExportDec+ toVert item@(JSModuleStatementListItem stmt) = mkVertex item <$> toplevelNames stmt+ toVert _ = [] - fn name s' nms- | isUsedInStmt name s'- , Just n <- exportStatementName s' = n:nms- | otherwise = nms+ mkVertex :: JSModuleItem -> Text -> (JSModuleItem, Text, [Text])+ mkVertex item name =+ (item, name, foldr' (accumulateDependents name) [] exps) - entryPointVertices :: [Vertex]- entryPointVertices = catMaybes $ do- (_, k, _) <- verts- guard $ k `elem` ns- return (vertexForKey k)- where- ns = runIdent <$> is+ accumulateDependents :: Text -> JSModuleItem -> [Text] -> [Text]+ accumulateDependents name item acc =+ if isNameUsedByItem name item+ then exportedModuleItemName item ++ acc+ else acc - unquote :: Text -> Text- unquote = T.drop 1 . T.dropEnd 1+-- | foldr over `JSCommaList`+foldrJSCommaList :: (a -> b -> b) -> JSCommaList a -> b -> b+foldrJSCommaList _ JSLNil b = b+foldrJSCommaList fn (JSLOne a) !b = fn a b+foldrJSCommaList fn (JSLCons as _ a) !b = foldrJSCommaList fn as (fn a b) - isExportStatement :: JSStatement -> Bool- isExportStatement (JSAssignStatement (JSMemberDot (JSIdentifier _ "exports") _ (JSIdentifier _ _)) _ _ _) = True- isExportStatement (JSAssignStatement (JSMemberSquare (JSIdentifier _ "exports") _ (JSStringLiteral _ _) _) _ _ _) = True- isExportStatement _ = False+toList :: JSCommaList a -> [a]+toList ls = foldrJSCommaList (:) ls [] - exportStatementName :: JSStatement -> Maybe Text- exportStatementName (JSAssignStatement (JSMemberDot (JSIdentifier _ "exports") _ (JSIdentifier _ i)) _ _ _) = Just . T.pack $ i- exportStatementName (JSAssignStatement (JSMemberSquare (JSIdentifier _ "exports") _ (JSStringLiteral _ i) _) _ _ _) = Just . unquote . T.pack $ i- exportStatementName _ = Nothing+toplevelNames :: JSStatement -> [Text]+toplevelNames (JSFunction _ (JSIdentName _ name) _ _ _ _ _) = [T.pack name]+toplevelNames (JSConstant _ exprs _) = catMaybes $ foldrJSCommaList (\name acc -> jsIdent name : acc) exprs []+toplevelNames _ = [] - -- Check if (export) identifier is used within a JSStatement.- isUsedInStmt :: Text -> JSStatement -> Bool- isUsedInStmt n (JSStatementBlock _ ss _ _) = any (isUsedInStmt n) ss- isUsedInStmt n (JSLet _ es _) = isUsedInExprs n es- isUsedInStmt n (JSClass _ _ h _ cs _ _) =- isUsedInClassHeritage n h || any (isUsedInClassElement n) cs- isUsedInStmt n (JSDoWhile _ stm _ _ e _ _) = isUsedInStmt n stm || isUsedInExpr n e- isUsedInStmt n (JSFor _ _ es1 _ es2 _ es3 _ s) = isUsedInExprs n es1 || isUsedInExprs n es2 || isUsedInExprs n es3 || isUsedInStmt n s- isUsedInStmt n (JSForIn _ _ e1 _ e2 _ s) = isUsedInExpr n e1 || isUsedInExpr n e2 || isUsedInStmt n s- isUsedInStmt n (JSForVar _ _ _ es1 _ es2 _ es3 _ s) = isUsedInExprs n es1 || isUsedInExprs n es2 || isUsedInExprs n es3 || isUsedInStmt n s- isUsedInStmt n (JSForVarIn _ _ _ e1 _ e2 _ s) = isUsedInExpr n e1 || isUsedInExpr n e2 || isUsedInStmt n s- isUsedInStmt n (JSForLet _ _ _ es1 _ es2 _ es3 _ s) =- isUsedInExprs n es1 || isUsedInExprs n es2 || isUsedInExprs n es3 ||- isUsedInStmt n s- isUsedInStmt n (JSForLetIn _ _ _ e1 _ e2 _ s) =- isUsedInExpr n e1 || isUsedInExpr n e2 || isUsedInStmt n s- isUsedInStmt n (JSForLetOf _ _ _ e1 _ e2 _ s) =- isUsedInExpr n e1 || isUsedInExpr n e2 || isUsedInStmt n s- isUsedInStmt n (JSForConst _ _ _ es1 _ es2 _ es3 _ s) =- isUsedInExprs n es1 || isUsedInExprs n es2 || isUsedInExprs n es3 || isUsedInStmt n s- isUsedInStmt n (JSForConstIn _ _ _ e1 _ e2 _ s) =- isUsedInExpr n e1 || isUsedInExpr n e2 || isUsedInStmt n s- isUsedInStmt n (JSForConstOf _ _ _ e1 _ e2 _ s) =- isUsedInExpr n e1 || isUsedInExpr n e2 || isUsedInStmt n s- isUsedInStmt n (JSForOf _ _ e1 _ e2 _ s) =- isUsedInExpr n e1 || isUsedInExpr n e2 || isUsedInStmt n s- isUsedInStmt n (JSForVarOf _ _ _ e1 _ e2 _ s) =- isUsedInExpr n e1 || isUsedInExpr n e2 || isUsedInStmt n s- isUsedInStmt n (JSAsyncFunction _ _ _ _ es _ (JSBlock _ ss _) _) =- isUsedInExprs n es || any (isUsedInStmt n) ss- isUsedInStmt n (JSFunction _ _ _ es _ (JSBlock _ ss _) _) =- isUsedInExprs n es || any (isUsedInStmt n) ss- isUsedInStmt n (JSGenerator _ _ _ _ es _ (JSBlock _ ss _) _) =- isUsedInExprs n es || any (isUsedInStmt n) ss- isUsedInStmt n (JSIf _ _ e _ s) = isUsedInExpr n e || isUsedInStmt n s- isUsedInStmt n (JSIfElse _ _ e _ s1 _ s2) = isUsedInExpr n e || isUsedInStmt n s1 || isUsedInStmt n s2- isUsedInStmt n (JSLabelled _ _ s) = isUsedInStmt n s- isUsedInStmt _ (JSEmptyStatement _) = False- isUsedInStmt n (JSExpressionStatement e _) = isUsedInExpr n e- isUsedInStmt n (JSAssignStatement e1 _ e2 _) = isUsedInExpr n e1 || isUsedInExpr n e2- isUsedInStmt n (JSMethodCall e _ es _ _) = isUsedInExpr n e || isUsedInExprs n es- isUsedInStmt n (JSReturn _ me _) = fromMaybe False (isUsedInExpr n <$> me)- isUsedInStmt n (JSSwitch _ _ e _ _ sps _ _) = isUsedInExpr n e || any (isUsedInSwitchParts n) sps- isUsedInStmt n (JSThrow _ e _) = isUsedInExpr n e- isUsedInStmt n (JSTry _ (JSBlock _ ss _) cs f) = any (isUsedInStmt n) ss || any (isUsedInTryCatch n) cs || isUsedInFinally n f- isUsedInStmt n (JSVariable _ es _) = isUsedInExprs n es- isUsedInStmt n (JSWhile _ _ e _ s) = isUsedInExpr n e || isUsedInStmt n s- isUsedInStmt n (JSWith _ _ e _ s _) = isUsedInExpr n e || isUsedInStmt n s- isUsedInStmt _ JSBreak{} = False- isUsedInStmt _ JSConstant{} = False- isUsedInStmt _ JSContinue{} = False+exportName' :: JSExportSpecifier -> Maybe Text+exportName' (JSExportSpecifier (JSIdentName _ name)) = Just $ T.pack name+exportName' _ = Nothing - -- Check if an exported identifier is used within a 'JSExpression'- isUsedInExpr :: Text -> JSExpression -> Bool- isUsedInExpr n (JSMemberDot (JSIdentifier _ "exports") _ (JSIdentifier _ i)) = n == T.pack i- isUsedInExpr n (JSMemberDot e1 _ e2) = isUsedInExpr n e1 || isUsedInExpr n e2- isUsedInExpr n (JSArrayLiteral _ as _) = any (isUsedInArrayElement n) as- isUsedInExpr n (JSAssignExpression e1 _ e2) = isUsedInExpr n e1 || isUsedInExpr n e2- isUsedInExpr n (JSAwaitExpression _ e) = isUsedInExpr n e- isUsedInExpr n (JSCallExpression e _ es _) = isUsedInExpr n e || isUsedInExprs n es- isUsedInExpr n (JSCallExpressionDot e1 _ e2) = isUsedInExpr n e1 || isUsedInExpr n e2- isUsedInExpr n (JSCallExpressionSquare e1 _ e2 _) = isUsedInExpr n e1 || isUsedInExpr n e2- isUsedInExpr n (JSClassExpression _ _ h _ cs _) =- isUsedInClassHeritage n h || any (isUsedInClassElement n) cs- isUsedInExpr n (JSExpressionBinary e1 _ e2) = isUsedInExpr n e1 || isUsedInExpr n e2- isUsedInExpr n (JSExpressionParen _ e _) = isUsedInExpr n e- isUsedInExpr n (JSExpressionPostfix e _) = isUsedInExpr n e- isUsedInExpr n (JSExpressionTernary e1 _ e2 _ e3) = isUsedInExpr n e1 || isUsedInExpr n e2 || isUsedInExpr n e3- isUsedInExpr n (JSArrowExpression _ _ s) = isUsedInStmt n s- isUsedInExpr n (JSFunctionExpression _ _ _ _ _ (JSBlock _ ss _)) = any (isUsedInStmt n) ss- isUsedInExpr n (JSGeneratorExpression _ _ _ _ es _ (JSBlock _ ss _)) =- isUsedInExprs n es || any (isUsedInStmt n) ss- isUsedInExpr n (JSMemberExpression e _ es _) = isUsedInExpr n e || isUsedInExprs n es- isUsedInExpr n (JSMemberNew _ e _ es _) = isUsedInExpr n e || isUsedInExprs n es- isUsedInExpr n (JSMemberSquare (JSIdentifier _ "exports") _ (JSStringLiteral _ i) _) = n == (unquote .T.pack $ i)- isUsedInExpr n (JSMemberSquare e1 _ e2 _) = isUsedInExpr n e1 || isUsedInExpr n e2- isUsedInExpr n (JSNewExpression _ e) = isUsedInExpr n e- isUsedInExpr n (JSObjectLiteral _ ops _) = foldrJSCommaList (\p b -> isUsedInObjectProperty n p || b) (fromCTList ops) False- where- fromCTList (JSCTLComma as _) = as- fromCTList (JSCTLNone as) = as- isUsedInExpr n (JSSpreadExpression _ e) = isUsedInExpr n e- isUsedInExpr n (JSTemplateLiteral me _ _ tps) =- any (isUsedInExpr n) me || any (\(JSTemplatePart e _ _) -> isUsedInExpr n e) tps- isUsedInExpr n (JSUnaryExpression _ e) = isUsedInExpr n e- isUsedInExpr n (JSVarInitExpression e _) = isUsedInExpr n e- isUsedInExpr _ JSIdentifier{} = False- isUsedInExpr _ JSDecimal{} = False- isUsedInExpr _ JSLiteral{} = False- isUsedInExpr _ JSHexInteger{} = False- isUsedInExpr _ JSOctal{} = False- isUsedInExpr _ JSStringLiteral{} = False- isUsedInExpr _ JSRegEx{} = False- isUsedInExpr n (JSCommaExpression e1 _ e2) = isUsedInExpr n e1 || isUsedInExpr n e2- isUsedInExpr n (JSYieldExpression _ me) = any (isUsedInExpr n) me- isUsedInExpr n (JSYieldFromExpression _ _ e) = isUsedInExpr n e+jsIdent :: JSExpression -> Maybe Text+jsIdent (JSVarInitExpression ident _) = jsIdent ident+jsIdent (JSIdentifier _ i) = Just $ T.pack i+jsIdent (JSStringLiteral _ s) = Just $ T.pack s+jsIdent _ = Nothing - isUsedInExprs :: Text -> JSCommaList JSExpression -> Bool- isUsedInExprs n es = foldrJSCommaList fn es False- where- fn :: JSExpression -> Bool -> Bool- fn e b = isUsedInExpr n e || b+exportNames :: JSExportDeclaration -> [Text]+exportNames (JSExportLocals (JSExportClause _ names _) _) = catMaybes $ foldrJSCommaList (\ex exs -> exportName' ex : exs) names []+exportNames (JSExportFrom (JSExportClause _ names _) _ _) = catMaybes $ foldrJSCommaList (\ex exs -> exportName' ex : exs) names []+exportNames (JSExport (JSConstant _ names _) _) = catMaybes $ foldrJSCommaList (\name nms -> jsIdent name : nms) names []+exportNames (JSExport (JSFunction _ (JSIdentName _ name) _ _ _ _ _) _) = [T.pack name]+exportNames _ = [] - -- Check if (export) identifier is used withing a JSSitchParts- isUsedInSwitchParts :: Text -> JSSwitchParts -> Bool- isUsedInSwitchParts n (JSCase _ e _ ss) = isUsedInExpr n e || any (isUsedInStmt n) ss- isUsedInSwitchParts n (JSDefault _ _ ss) = any (isUsedInStmt n) ss+isExportModuleItem :: JSModuleItem -> Bool+isExportModuleItem (JSModuleExportDeclaration _ _) = True+isExportModuleItem _ = False - -- Check if (export) identifier is used withing a JSTryCatch- isUsedInTryCatch :: Text -> JSTryCatch -> Bool- isUsedInTryCatch n (JSCatch _ _ e _ (JSBlock _ ss _)) = isUsedInExpr n e || any (isUsedInStmt n) ss- isUsedInTryCatch n (JSCatchIf _ _ e1 _ e2 _ (JSBlock _ ss _)) = isUsedInExpr n e1 || isUsedInExpr n e2 || any (isUsedInStmt n) ss+exportedModuleItemName :: JSModuleItem -> [Text]+exportedModuleItemName (JSModuleExportDeclaration _ jsModuleExport) = exportNames jsModuleExport+exportedModuleItemName _ = [] - -- |- -- Check if (export) identifier is used withing a JSTryFinally- isUsedInFinally :: Text -> JSTryFinally -> Bool- isUsedInFinally n (JSFinally _ (JSBlock _ ss _)) = any (isUsedInStmt n) ss- isUsedInFinally _ JSNoFinally = False+isNameUsedByItem :: Text -> JSModuleItem -> Bool+isNameUsedByItem _ (JSModuleImportDeclaration _ _) = False+isNameUsedByItem _ (JSModuleExportDeclaration _ (JSExportFrom _ _ _)) = False+isNameUsedByItem name (JSModuleExportDeclaration _ decl@(JSExportLocals _ _)) = name `elem` exportNames decl+isNameUsedByItem name (JSModuleExportDeclaration _ (JSExport statement _)) = isNameUsedByStatement name statement+isNameUsedByItem name (JSModuleStatementListItem stmt) = isNameUsedByStatement name stmt - -- |- -- Check if (export) identifier is used withing a JSArrayElement- isUsedInArrayElement :: Text -> JSArrayElement -> Bool- isUsedInArrayElement n (JSArrayElement e) = isUsedInExpr n e- isUsedInArrayElement _ JSArrayComma{} = False+isNameUsedByStatement :: Text -> JSStatement -> Bool+isNameUsedByStatement name (JSStatementBlock _ block _ _) =+ any (isNameUsedByStatement name) block+isNameUsedByStatement _ (JSBreak _ _ _) = False+isNameUsedByStatement name (JSLet _ exprs _) =+ any (isNameUsedByExpr name) (toList exprs)+isNameUsedByStatement name (JSClass _ _ heritage _ cls _ _) =+ isNameUsedInHeritage name heritage || any (isNameUsedByClassElement name) cls+isNameUsedByStatement name (JSConstant _ exprs _) =+ any (isNameUsedByExpr name) (toList exprs)+isNameUsedByStatement _ (JSContinue _ _ _) = False+isNameUsedByStatement name (JSDoWhile _ stmt _ _ expr _ _) =+ isNameUsedByStatement name stmt || isNameUsedByExpr name expr+isNameUsedByStatement name (JSFor _ _ exprs1 _ exprs2 _ exprs3 _ stmt) =+ isNameUsedByStatement name stmt || any (isNameUsedByExpr name) (toList exprs1 ++ toList exprs2 ++ toList exprs3)+isNameUsedByStatement name (JSForIn _ _ expr1 _ expr2 _ stmt) =+ isNameUsedByStatement name stmt || any (isNameUsedByExpr name) [expr1, expr2]+isNameUsedByStatement name (JSForVar _ _ _ exprs1 _ exprs2 _ exprs3 _ stmt) =+ isNameUsedByStatement name stmt || any (isNameUsedByExpr name) (toList exprs1 ++ toList exprs2 ++ toList exprs3)+isNameUsedByStatement name (JSForLet _ _ _ exprs1 _ exprs2 _ exprs3 _ stmt) =+ isNameUsedByStatement name stmt || any (isNameUsedByExpr name) (toList exprs1 ++ toList exprs2 ++ toList exprs3)+isNameUsedByStatement name (JSForConst _ _ _ exprs1 _ exprs2 _ exprs3 _ stmt) =+ isNameUsedByStatement name stmt || any (isNameUsedByExpr name) (toList exprs1 ++ toList exprs2 ++ toList exprs3)+isNameUsedByStatement name (JSForVarIn _ _ _ expr1 _ expr2 _ stmt) =+ isNameUsedByStatement name stmt || any (isNameUsedByExpr name) [expr1, expr2]+isNameUsedByStatement name (JSForLetIn _ _ _ expr1 _ expr2 _ stmt) =+ isNameUsedByStatement name stmt || any (isNameUsedByExpr name) [expr1, expr2]+isNameUsedByStatement name (JSForConstIn _ _ _ expr1 _ expr2 _ stmt) =+ isNameUsedByStatement name stmt || any (isNameUsedByExpr name) [expr1, expr2]+isNameUsedByStatement name (JSForVarOf _ _ _ expr1 _ expr2 _ stmt) =+ isNameUsedByStatement name stmt || any (isNameUsedByExpr name) [expr1, expr2]+isNameUsedByStatement name (JSForLetOf _ _ _ expr1 _ expr2 _ stmt) =+ isNameUsedByStatement name stmt || any (isNameUsedByExpr name) [expr1, expr2]+isNameUsedByStatement name (JSForConstOf _ _ _ expr1 _ expr2 _ stmt) =+ isNameUsedByStatement name stmt || any (isNameUsedByExpr name) [expr1, expr2]+isNameUsedByStatement name (JSForOf _ _ expr1 _ expr2 _ stmt) =+ isNameUsedByStatement name stmt || any (isNameUsedByExpr name) [expr1, expr2]+isNameUsedByStatement name (JSFunction _ _ _ exprs _ (JSBlock _ stmts _) _) =+ any (isNameUsedByExpr name) (toList exprs) || any (isNameUsedByStatement name) stmts+isNameUsedByStatement name (JSGenerator _ _ _ _ exprs _ (JSBlock _ stmts _) _) =+ any (isNameUsedByExpr name) (toList exprs) || any (isNameUsedByStatement name) stmts+isNameUsedByStatement name (JSIf _ _ expr _ stmt) = isNameUsedByExpr name expr || isNameUsedByStatement name stmt+isNameUsedByStatement name (JSIfElse _ _ expr _ stmtIf _ stmtElse) =+ isNameUsedByExpr name expr || any (isNameUsedByStatement name) [stmtIf, stmtElse]+isNameUsedByStatement name (JSLabelled _ _ stmt) = isNameUsedByStatement name stmt+isNameUsedByStatement _ (JSEmptyStatement _) = False+isNameUsedByStatement name (JSExpressionStatement expr _) = isNameUsedByExpr name expr+isNameUsedByStatement name (JSAssignStatement lhs _ rhs _) = any (isNameUsedByExpr name) [lhs, rhs]+isNameUsedByStatement name (JSMethodCall expr _ exprs _ _) = any (isNameUsedByExpr name) (expr : toList exprs)+isNameUsedByStatement _ (JSReturn _ Nothing _) = False+isNameUsedByStatement name (JSReturn _ (Just expr) _) = isNameUsedByExpr name expr+isNameUsedByStatement name (JSSwitch _ _ expr _ _ cases _ _) =+ isNameUsedByExpr name expr || any (isNameUsedByCase name) cases+isNameUsedByStatement name (JSThrow _ expr _) = isNameUsedByExpr name expr+isNameUsedByStatement name (JSTry _ (JSBlock _ stmts _) tryCatch tryFinally) =+ any (isNameUsedByStatement name) stmts || any (isNameUsedByTryCatch name) tryCatch || isNameUsedByTryFinally name tryFinally+isNameUsedByStatement name (JSVariable _ exprs _) = any (isNameUsedByExpr name) (toList exprs)+isNameUsedByStatement name (JSWhile _ _ expr _ stmt) = isNameUsedByExpr name expr || isNameUsedByStatement name stmt+isNameUsedByStatement name (JSWith _ _ expr _ stmt _) = isNameUsedByExpr name expr || isNameUsedByStatement name stmt - -- |- -- Check if (export) identifier is used withing a JSObjectProperty- isUsedInObjectProperty :: Text -> JSObjectProperty -> Bool- isUsedInObjectProperty n (JSPropertyNameandValue _ _ es) = any (isUsedInExpr n) es- isUsedInObjectProperty _ JSPropertyIdentRef{} = False- isUsedInObjectProperty n (JSObjectMethod m) = isUsedInMethodDefinition n m+isNameUsedByExpr :: Text -> JSExpression -> Bool+isNameUsedByExpr name (JSIdentifier _ ident) = name == T.pack ident+isNameUsedByExpr _ (JSDecimal _ _) = False+isNameUsedByExpr _ (JSLiteral _ _) = False+isNameUsedByExpr _ (JSHexInteger _ _) = False+isNameUsedByExpr _ (JSOctal _ _) = False+isNameUsedByExpr _ (JSStringLiteral _ _) = False+isNameUsedByExpr _ (JSRegEx _ _) = False+isNameUsedByExpr name (JSArrayLiteral _ elems _) = any (isNameUsedByArrayElement name) elems+isNameUsedByExpr name (JSAssignExpression lhs _ rhs) = any (isNameUsedByExpr name) [lhs, rhs]+isNameUsedByExpr name (JSCallExpression expr _ exprs _) = any (isNameUsedByExpr name) (expr : toList exprs)+isNameUsedByExpr name (JSCallExpressionDot expr1 _ expr2) = any (isNameUsedByExpr name) [expr1, expr2]+isNameUsedByExpr name (JSCallExpressionSquare expr1 _ expr2 _) = any (isNameUsedByExpr name) [expr1, expr2]+isNameUsedByExpr name (JSClassExpression _ _ heritage _ cls _) =+ isNameUsedInHeritage name heritage || any (isNameUsedByClassElement name) cls+isNameUsedByExpr name (JSCommaExpression expr1 _ expr2) = isNameUsedByExpr name expr1 || isNameUsedByExpr name expr2+isNameUsedByExpr name (JSExpressionBinary expr1 _ expr2) = isNameUsedByExpr name expr1 || isNameUsedByExpr name expr2+isNameUsedByExpr name (JSExpressionParen _ expr _) = isNameUsedByExpr name expr+isNameUsedByExpr name (JSExpressionPostfix expr _) = isNameUsedByExpr name expr+isNameUsedByExpr name (JSExpressionTernary cond _ yes _ no) = any (isNameUsedByExpr name) [cond, yes, no]+isNameUsedByExpr name (JSArrowExpression _ _ stmt) = isNameUsedByStatement name stmt+isNameUsedByExpr name (JSFunctionExpression _ _ _ exprs _ (JSBlock _ stmts _)) =+ any (isNameUsedByExpr name) (toList exprs) || any (isNameUsedByStatement name) stmts+isNameUsedByExpr name (JSGeneratorExpression _ _ _ _ exprs _ (JSBlock _ stmts _)) =+ any (isNameUsedByExpr name) (toList exprs) || any (isNameUsedByStatement name) stmts+isNameUsedByExpr name (JSMemberDot expr1 _ expr2) = isNameUsedByExpr name expr1 || isNameUsedByExpr name expr2+isNameUsedByExpr name (JSMemberExpression expr _ exprs _) = any (isNameUsedByExpr name) (expr : toList exprs)+isNameUsedByExpr name (JSMemberNew _ expr _ exprs _) = any (isNameUsedByExpr name) (expr : toList exprs)+isNameUsedByExpr name (JSMemberSquare expr1 _ expr2 _) = isNameUsedByExpr name expr1 || isNameUsedByExpr name expr2+isNameUsedByExpr name (JSNewExpression _ expr) = isNameUsedByExpr name expr+isNameUsedByExpr name (JSObjectLiteral _ (JSCTLComma props _) _) = any (isNameUsedByObjectProperty name) (toList props)+isNameUsedByExpr name (JSObjectLiteral _ (JSCTLNone props) _) = any (isNameUsedByObjectProperty name) (toList props)+isNameUsedByExpr name (JSSpreadExpression _ expr) = isNameUsedByExpr name expr+isNameUsedByExpr name (JSTemplateLiteral Nothing _ _ parts) = any (isNameUsedByTemplatePart name) parts+isNameUsedByExpr name (JSTemplateLiteral (Just expr) _ _ parts) = isNameUsedByExpr name expr || any (isNameUsedByTemplatePart name) parts+isNameUsedByExpr name (JSUnaryExpression _ expr) = isNameUsedByExpr name expr+isNameUsedByExpr name (JSVarInitExpression expr initializer) = isNameUsedByExpr name expr || isNameUsedByVarInit name initializer+isNameUsedByExpr _ (JSYieldExpression _ Nothing) = False+isNameUsedByExpr name (JSYieldExpression _ (Just expr)) = isNameUsedByExpr name expr+isNameUsedByExpr name (JSYieldFromExpression _ _ expr) = isNameUsedByExpr name expr - isUsedInMethodDefinition :: Text -> JSMethodDefinition -> Bool- isUsedInMethodDefinition n (JSMethodDefinition _ _ es _ (JSBlock _ ss _))- = isUsedInExprs n es || any (isUsedInStmt n) ss- isUsedInMethodDefinition n (JSGeneratorMethodDefinition _ _ _ es _ (JSBlock _ ss _))- = isUsedInExprs n es || any (isUsedInStmt n) ss- isUsedInMethodDefinition n (JSPropertyAccessor _ _ _ es _ (JSBlock _ ss _))- = isUsedInExprs n es || any (isUsedInStmt n) ss+isNameUsedInHeritage :: Text -> JSClassHeritage -> Bool+isNameUsedInHeritage _ JSExtendsNone = False+isNameUsedInHeritage name (JSExtends _ expr) = isNameUsedByExpr name expr - isUsedInClassElement :: Text -> JSClassElement -> Bool- isUsedInClassElement n (JSClassInstanceMethod m) = isUsedInMethodDefinition n m- isUsedInClassElement n (JSClassStaticMethod _ m) = isUsedInMethodDefinition n m- isUsedInClassElement _ JSClassSemi{} = False+isNameUsedByClassElement :: Text -> JSClassElement -> Bool+isNameUsedByClassElement _ (JSClassSemi _) = False+isNameUsedByClassElement name (JSClassInstanceMethod defn) = isNameUsedByMethodDefinition name defn+isNameUsedByClassElement name (JSClassStaticMethod _ defn) = isNameUsedByMethodDefinition name defn - isUsedInClassHeritage :: Text -> JSClassHeritage -> Bool- isUsedInClassHeritage n (JSExtends _ e) = isUsedInExpr n e- isUsedInClassHeritage _ JSExtendsNone = False+isNameUsedByMethodDefinition :: Text -> JSMethodDefinition -> Bool+isNameUsedByMethodDefinition name (JSMethodDefinition _ _ exprs _ _) = any (isNameUsedByExpr name) (toList exprs)+isNameUsedByMethodDefinition name (JSGeneratorMethodDefinition _ _ _ exprs _ _) = any (isNameUsedByExpr name) (toList exprs)+isNameUsedByMethodDefinition name (JSPropertyAccessor _ _ _ exprs _ _) = any (isNameUsedByExpr name) (toList exprs)++isNameUsedByCase :: Text -> JSSwitchParts -> Bool+isNameUsedByCase name (JSDefault _ _ stmts) = any (isNameUsedByStatement name) stmts+isNameUsedByCase name (JSCase _ expr _ stmts) = isNameUsedByExpr name expr || any (isNameUsedByStatement name) stmts++isNameUsedByTryCatch :: Text -> JSTryCatch -> Bool+isNameUsedByTryCatch name (JSCatch _ _ expr _ (JSBlock _ stmts _)) = isNameUsedByExpr name expr || any (isNameUsedByStatement name) stmts+isNameUsedByTryCatch name (JSCatchIf _ _ expr1 _ expr2 _ (JSBlock _ stmts _)) = any (isNameUsedByExpr name) [expr1, expr2] || any (isNameUsedByStatement name) stmts++isNameUsedByTryFinally :: Text -> JSTryFinally -> Bool+isNameUsedByTryFinally name (JSFinally _ (JSBlock _ stmts _)) = any (isNameUsedByStatement name) stmts+isNameUsedByTryFinally _ JSNoFinally = False++isNameUsedByArrayElement :: Text -> JSArrayElement -> Bool+isNameUsedByArrayElement _ (JSArrayComma _) = False+isNameUsedByArrayElement name (JSArrayElement expr) = isNameUsedByExpr name expr++isNameUsedByObjectProperty :: Text -> JSObjectProperty -> Bool+isNameUsedByObjectProperty name (JSPropertyNameandValue _ _ exprs) = any (isNameUsedByExpr name) exprs+isNameUsedByObjectProperty name (JSPropertyIdentRef _ ref) = name == T.pack ref+isNameUsedByObjectProperty name (JSObjectMethod mDef) = isNameUsedByMethodDefinition name mDef++isNameUsedByTemplatePart :: Text -> JSTemplatePart -> Bool+isNameUsedByTemplatePart name (JSTemplatePart expr _ _) = isNameUsedByExpr name expr++isNameUsedByVarInit :: Text -> JSVarInitializer -> Bool+isNameUsedByVarInit name (JSVarInit _ expr) = isNameUsedByExpr name expr+isNameUsedByVarInit _ JSVarInitNone = False
src/Language/PureScript/DCE/Utils.hs view
@@ -2,7 +2,6 @@ -- Helper module for dead call elimination. module Language.PureScript.DCE.Utils where -import Prelude.Compat import Control.Arrow (first, second, (***), (+++)) import Language.PureScript.CoreFn import Language.PureScript.Names
test/Main.hs view
@@ -1,31 +1,27 @@ {-# LANGUAGE CPP #-}-module Main (main) where -import Prelude ()-import Prelude.Compat hiding (exp)-import System.IO (hSetEncoding, stdout, stderr, utf8)-import System.Process (readProcess)-import Test.Hspec+module Main (main) where +import System.IO (hSetEncoding, stderr, stdout, utf8) import qualified Test.CoreFn import qualified Test.Eval+import Test.Hspec import qualified Test.Lib--- TODO: it shouldn't be a CPP FLAG #ifdef TEST_CORE_LIBS import qualified Test.CoreLib #endif - main :: IO () main = do- readProcess "purs" ["--version"] "" >>= putStrLn . (\v -> "\npurs version: " ++ v)- hSetEncoding stdout utf8 hSetEncoding stderr utf8 hspec Test.CoreFn.spec hspec Test.Eval.spec hspec Test.Lib.spec++-- Tree shaking of core libraries is disabled by default because it's not+-- reliable. #ifdef TEST_CORE_LIBS hspec Test.CoreLib.spec #endif
test/Test/CoreFn.hs view
@@ -1,16 +1,13 @@ module Test.CoreFn (spec) where -import Prelude ()-import Prelude.Compat--import Data.List (concatMap, foldl', intersect)+import Data.List (foldl', intersect) import qualified Data.List as L import Language.PureScript.AST.Literals-import Language.PureScript.AST.SourcePos+import Language.PureScript.AST.SourcePos (SourceSpan (..), SourcePos (..)) import Language.PureScript.CoreFn import Language.PureScript.DCE-import Language.PureScript.Names+import Language.PureScript.Names (Ident (..), Qualified (..), QualifiedBy (..)) import Language.PureScript.PSString import Test.Hspec@@ -26,13 +23,18 @@ hasIdent :: Ident -> [Bind Ann] -> Bool hasIdent i = (i `elem`) . concatMap getNames +sp :: SourcePos+sp = SourcePos 0 0+ ann :: Ann-ann = ssAnn (SourceSpan "src/Test.purs" (SourcePos 0 0) (SourcePos 0 0))+ann = ssAnn (SourceSpan "src/Test.purs" sp sp) prop_exprDepth :: PSExpr Ann -> Property prop_exprDepth (PSExpr e) = let b = NonRec ann (Ident "x") e- NonRec _ _ e' = runBindDeadCodeElimination b+ e' = case runBindDeadCodeElimination b of+ NonRec _ _ a -> a+ _ -> error "runBindDeadCodeElimination: recursive binds are unsupported" d = exprDepth e d' = exprDepth e' in collect (10 * (d' * 100 `div` (10 * d)))@@ -42,7 +44,9 @@ prop_lets :: PSExpr Ann -> Property prop_lets (PSExpr f) = let b = NonRec ann (Ident "x") f- NonRec _ _ f' = runBindDeadCodeElimination b+ f' = case runBindDeadCodeElimination b of+ NonRec _ _ a -> a+ _ -> error "runBindDeadCodeElimination: recursive binds are unsupported" d = countLets f d' = countLets f' idents = findBindIdents f'@@ -90,99 +94,100 @@ spec = do context "generators" $ do specify "should generate Expr" $ property $ prop_exprDistribution- context "runBindDeadCodeElimination" $ do- specify "should reduce the depth of the tree" $ property $ withMaxSuccess 10000 prop_exprDepth- specify "should reduce the number of let bindings" $ property $ withMaxSuccess 10000 prop_lets- specify "should remove unused identifier" $ do- let e :: Expr Ann- e = Let ann- [ NonRec ann (Ident "notUsed") (Literal ann (CharLiteral 'a'))- , NonRec ann (Ident "used") (Literal ann (CharLiteral 'b'))- ]- (Var ann (Qualified Nothing (Ident "used")))- case runBindDeadCodeElimination (NonRec ann (Ident "v") e) of- NonRec _ _ (Let _ bs _) -> do- bs `shouldSatisfy` not . hasIdent (Ident "notUsed")- bs `shouldSatisfy` hasIdent (Ident "used")- _ -> return ()+ context "corefn" $ + context "runBindDeadCodeElimination" $ do+ specify "should reduce the depth of the tree" $ property $ withMaxSuccess 10000 prop_exprDepth+ specify "should reduce the number of let bindings" $ property $ withMaxSuccess 10000 prop_lets+ specify "should remove unused identifier" $ do+ let e :: Expr Ann+ e = Let ann+ [ NonRec ann (Ident "notUsed") (Literal ann (CharLiteral 'a'))+ , NonRec ann (Ident "used") (Literal ann (CharLiteral 'b'))+ ]+ (Var ann (Qualified (BySourcePos sp) (Ident "used")))+ case runBindDeadCodeElimination (NonRec ann (Ident "v") e) of+ NonRec _ _ (Let _ bs _) -> do+ bs `shouldSatisfy` not . hasIdent (Ident "notUsed")+ bs `shouldSatisfy` hasIdent (Ident "used")+ _ -> return () - specify "should not remove transitive dependency" $ do- let e :: Expr Ann- e = Let ann- [ NonRec ann (Ident "used") (Abs ann (Ident "x") (Var ann (Qualified Nothing (Ident "trDep"))))- , NonRec ann (Ident "trDep") (Literal ann (CharLiteral 'a'))- ]- (Var ann (Qualified Nothing (Ident "used")))- case runBindDeadCodeElimination (NonRec ann (Ident "v") e) of- NonRec _ _ (Let _ bs _) -> do- bs `shouldSatisfy` hasIdent (Ident "trDep")- bs `shouldSatisfy` hasIdent (Ident "used")- _ -> return ()+ specify "should not remove transitive dependency" $ do+ let e :: Expr Ann+ e = Let ann+ [ NonRec ann (Ident "used") (Abs ann (Ident "x") (Var ann (Qualified (BySourcePos sp) (Ident "trDep"))))+ , NonRec ann (Ident "trDep") (Literal ann (CharLiteral 'a'))+ ]+ (Var ann (Qualified (BySourcePos sp) (Ident "used")))+ case runBindDeadCodeElimination (NonRec ann (Ident "v") e) of+ NonRec _ _ (Let _ bs _) -> do+ bs `shouldSatisfy` hasIdent (Ident "trDep")+ bs `shouldSatisfy` hasIdent (Ident "used")+ _ -> return () - specify "should include all used recursive binds" $ do- let e :: Expr Ann- e = Let ann- [ NonRec ann (Ident "entry") (Abs ann (Ident "x") (Var ann (Qualified Nothing (Ident "mutDep1"))))- , Rec- [ ((ann, Ident "mutDep1"), Abs ann (Ident "x") (Var ann (Qualified Nothing (Ident "mutDep2"))))- , ((ann, Ident "mutDep2"), Abs ann (Ident "x") (Var ann (Qualified Nothing (Ident "mutDep1"))))+ specify "should include all used recursive binds" $ do+ let e :: Expr Ann+ e = Let ann+ [ NonRec ann (Ident "entry") (Abs ann (Ident "x") (Var ann (Qualified (BySourcePos sp) (Ident "mutDep1"))))+ , Rec+ [ ((ann, Ident "mutDep1"), Abs ann (Ident "x") (Var ann (Qualified (BySourcePos sp) (Ident "mutDep2"))))+ , ((ann, Ident "mutDep2"), Abs ann (Ident "x") (Var ann (Qualified (BySourcePos sp) (Ident "mutDep1"))))+ ] ]- ]- (App ann (Var ann (Qualified Nothing (Ident "entry"))) (Literal ann (CharLiteral 'a')))- case runBindDeadCodeElimination (NonRec ann (Ident "v") e) of- NonRec _ _ (Let _ bs _) -> do- bs `shouldSatisfy` hasIdent (Ident "entry")- bs `shouldSatisfy` hasIdent (Ident "mutDep1")- bs `shouldSatisfy` hasIdent (Ident "mutDep2")- _ -> return ()+ (App ann (Var ann (Qualified (BySourcePos sp) (Ident "entry"))) (Literal ann (CharLiteral 'a')))+ case runBindDeadCodeElimination (NonRec ann (Ident "v") e) of+ NonRec _ _ (Let _ bs _) -> do+ bs `shouldSatisfy` hasIdent (Ident "entry")+ bs `shouldSatisfy` hasIdent (Ident "mutDep1")+ bs `shouldSatisfy` hasIdent (Ident "mutDep2")+ _ -> return () - specify "should dce case expressions" $ do- let e :: Expr Ann- e = Let ann- [ NonRec ann (Ident "usedInExpr") (Literal ann (CharLiteral 'a'))- , NonRec ann (Ident "notUsed") (Literal ann (CharLiteral 'a'))- , NonRec ann (Ident "usedInGuard") (Literal ann (CharLiteral 'a'))- , NonRec ann (Ident "usedInResult1") (Literal ann (CharLiteral 'a'))- , NonRec ann (Ident "usedInResult2") (Literal ann (CharLiteral 'a'))- ]- (Case ann- [Var ann (Qualified Nothing (Ident "usedInExpr"))]- [ CaseAlternative- [NullBinder ann]- (Left- [ ( Var ann (Qualified Nothing (Ident "usedInGuard"))- , Var ann (Qualified Nothing (Ident "usedInResult1"))- )- ])- , CaseAlternative- [NullBinder ann]- (Right $ Var ann (Qualified Nothing (Ident "usedInResult2")))- ])- case runBindDeadCodeElimination (NonRec ann (Ident "v") e) of- NonRec _ _ (Let _ bs _) -> do- bs `shouldSatisfy` hasIdent (Ident "usedInExpr")- bs `shouldSatisfy` not . hasIdent (Ident "notUsed")- bs `shouldSatisfy` hasIdent (Ident "usedInGuard")- bs `shouldSatisfy` hasIdent (Ident "usedInResult1")- bs `shouldSatisfy` hasIdent (Ident "usedInResult2")- _ -> return ()+ specify "should dce case expressions" $ do+ let e :: Expr Ann+ e = Let ann+ [ NonRec ann (Ident "usedInExpr") (Literal ann (CharLiteral 'a'))+ , NonRec ann (Ident "notUsed") (Literal ann (CharLiteral 'a'))+ , NonRec ann (Ident "usedInGuard") (Literal ann (CharLiteral 'a'))+ , NonRec ann (Ident "usedInResult1") (Literal ann (CharLiteral 'a'))+ , NonRec ann (Ident "usedInResult2") (Literal ann (CharLiteral 'a'))+ ]+ (Case ann+ [Var ann (Qualified (BySourcePos sp) (Ident "usedInExpr"))]+ [ CaseAlternative+ [NullBinder ann]+ (Left+ [ ( Var ann (Qualified (BySourcePos sp) (Ident "usedInGuard"))+ , Var ann (Qualified (BySourcePos sp) (Ident "usedInResult1"))+ )+ ])+ , CaseAlternative+ [NullBinder ann]+ (Right $ Var ann (Qualified (BySourcePos sp) (Ident "usedInResult2")))+ ])+ case runBindDeadCodeElimination (NonRec ann (Ident "v") e) of+ NonRec _ _ (Let _ bs _) -> do+ bs `shouldSatisfy` hasIdent (Ident "usedInExpr")+ bs `shouldSatisfy` not . hasIdent (Ident "notUsed")+ bs `shouldSatisfy` hasIdent (Ident "usedInGuard")+ bs `shouldSatisfy` hasIdent (Ident "usedInResult1")+ bs `shouldSatisfy` hasIdent (Ident "usedInResult2")+ _ -> return () - specify "should not remove shadowed identifiers" $ do- let e :: Expr Ann- e = Let ann- [ NonRec ann (Ident "shadow") (Literal ann (CharLiteral 'a'))- , NonRec ann (Ident "sunny") (Literal ann (CharLiteral 'a'))- ]- $ Let ann- [ NonRec ann (Ident "shadow") (Literal ann (CharLiteral 'a')) ]- $ Literal ann- $ ObjectLiteral - [ ( mkString "a", Var ann (Qualified Nothing (Ident "shadow")) )- , ( mkString "b", Var ann (Qualified Nothing (Ident "sunny")) )- ]- case runBindDeadCodeElimination (NonRec ann (Ident "v") e) of- NonRec _ _ (Let _ bs (Let _ cs _)) -> do- bs `shouldSatisfy` hasIdent (Ident "sunny")- bs `shouldSatisfy` not . hasIdent (Ident "shadow")- cs `shouldSatisfy` hasIdent (Ident "shadow")- _ -> undefined+ specify "should not remove shadowed identifiers" $ do+ let e :: Expr Ann+ e = Let ann+ [ NonRec ann (Ident "shadow") (Literal ann (CharLiteral 'a'))+ , NonRec ann (Ident "sunny") (Literal ann (CharLiteral 'a'))+ ]+ $ Let ann+ [ NonRec ann (Ident "shadow") (Literal ann (CharLiteral 'a')) ]+ $ Literal ann+ $ ObjectLiteral + [ ( mkString "a", Var ann (Qualified (BySourcePos sp) (Ident "shadow")) )+ , ( mkString "b", Var ann (Qualified (BySourcePos sp) (Ident "sunny")) )+ ]+ case runBindDeadCodeElimination (NonRec ann (Ident "v") e) of+ NonRec _ _ (Let _ bs (Let _ cs _)) -> do+ bs `shouldSatisfy` hasIdent (Ident "sunny")+ bs `shouldSatisfy` not . hasIdent (Ident "shadow")+ cs `shouldSatisfy` hasIdent (Ident "shadow")+ _ -> error "runBindDeadCodeElimination: recursive binds are unsupported"
test/Test/CoreLib.hs view
@@ -1,12 +1,8 @@ module Test.CoreLib (spec) where -import Prelude ()-import Prelude.Compat hiding (exp)-import Control.Monad (when) import Control.Monad.Trans.Class import Control.Monad.Except-import Data.Foldable (forM_)-import Data.Maybe (fromJust, isJust, maybe)+import Data.Maybe (fromJust, isJust) import Data.Text (Text) import qualified Data.Text as T import System.Directory (setCurrentDirectory)@@ -123,7 +119,7 @@ (ecNode, stdNode, errNode) <- lift $ readProcessWithExitCode- "node"+ nodeExe [ "-e" , T.unpack $ maybe defaultJsCmd fst coreLibTestJsCmd ]
test/Test/Eval.hs view
@@ -2,15 +2,14 @@ module Test.Eval (spec) where -import Prelude ()-import Prelude.Compat+import qualified Data.Map as Map import Language.PureScript.AST.Literals-import Language.PureScript.AST.SourcePos+import Language.PureScript.AST.SourcePos (SourceSpan(..), SourcePos(..)) import Language.PureScript.CoreFn import Language.PureScript.DCE import qualified Language.PureScript.DCE.Constants as C-import Language.PureScript.Names+import Language.PureScript.Names (Ident(..), ModuleName(..), Qualified(..), QualifiedBy(..)) import Language.PureScript.PSString import Language.PureScript.DCE.Utils (showExpr)@@ -18,18 +17,20 @@ import Test.Hspec import Test.HUnit (assertFailure) +sp :: SourcePos+sp = SourcePos 0 0 ss :: SourceSpan-ss = SourceSpan "src/Test.purs" (SourcePos 0 0) (SourcePos 0 0)+ss = SourceSpan "src/Test.purs" sp sp ann :: Ann ann = ssAnn ss eq :: Qualified Ident-eq = Qualified (Just C.eqMod) (Ident "eq")+eq = Qualified (ByModuleName C.eqMod) (Ident "eq") eqBoolean :: Qualified Ident-eqBoolean = Qualified (Just eqModName) (Ident "eqBoolean")+eqBoolean = Qualified (ByModuleName eqModName) (Ident "eqBoolean") eqModName :: ModuleName eqModName = ModuleName "Data.Eq"@@ -42,15 +43,15 @@ dceEvalExpr' :: Expr Ann -> [Module Ann] -> Expr Ann dceEvalExpr' e mods = case evaluate ([testMod , eqMod , booleanMod , arrayMod, unsafeCoerceMod] ++ mods) of- ((Module _ _ _ _ _ _ _ [NonRec _ _ e', _]) : _) -> e'+ ((Module _ _ _ _ _ _ _ _ [NonRec _ _ e', _]) : _) -> e' _ -> error "not supported" where- testMod = Module ss [] mn mp [] [] []+ testMod = Module ss [] mn mp [] [] Map.empty [] [ NonRec ann (Ident "v") e , NonRec ann (Ident "f")- (Abs ann (Ident "x") (Var ann (Qualified Nothing (Ident "x"))))+ (Abs ann (Ident "x") (Var ann (Qualified (BySourcePos sp) (Ident "x")))) ]- eqMod = Module ss [] C.eqMod "" [] []+ eqMod = Module ss [] C.eqMod "" [] [] Map.empty [ Ident "refEq" ] [ NonRec ann (Ident "eq") (Abs ann (Ident "dictEq")@@ -59,26 +60,26 @@ (Literal ann (BooleanLiteral True))))) , NonRec ann (Ident "eqBoolean") (App ann- (Var ann (Qualified (Just C.eqMod) (Ident "Eq")))- (Var ann (Qualified (Just C.eqMod) (Ident "refEq"))))+ (Var ann (Qualified (ByModuleName C.eqMod) (Ident "Eq")))+ (Var ann (Qualified (ByModuleName C.eqMod) (Ident "refEq")))) , NonRec ann (Ident "Eq") (Abs ann (Ident "eq")- (Literal ann (ObjectLiteral [(mkString "eq", Var ann (Qualified Nothing (Ident "eq")))])))+ (Literal ann (ObjectLiteral [(mkString "eq", Var ann (Qualified (BySourcePos sp) (Ident "eq")))]))) ]- booleanMod = Module ss [] (ModuleName "Data.Boolean") "" [] [] []+ booleanMod = Module ss [] (ModuleName "Data.Boolean") "" [] [] Map.empty [] [ NonRec ann (Ident "otherwise") (Literal ann (BooleanLiteral True)) ] arrayMod = Module ss [] (ModuleName "Data.Array") ""- [] [] []+ [] [] Map.empty [] [ NonRec ann (Ident "index") (Abs ann (Ident "as") (Abs ann (Ident "ix") (Literal ann (CharLiteral 'f')))) ] unsafeCoerceMod = Module ss [] C.unsafeCoerce ""- [] [] []+ [] [] Map.empty [] [ NonRec ann (Ident "unsafeCoerce") (Abs ann (Ident "x")- (Var ann (Qualified Nothing (Ident "x"))))+ (Var ann (Qualified (BySourcePos sp) (Ident "x")))) ] dceEvalExpr :: Expr Ann -> Expr Ann@@ -154,7 +155,7 @@ (Literal ann (BooleanLiteral True)) e :: Expr Ann e = Let ann [NonRec ann (Ident "v") v]- (Case ann [Var ann (Qualified Nothing (Ident "v"))]+ (Case ann [Var ann (Qualified (BySourcePos sp) (Ident "v"))] [ CaseAlternative [ LiteralBinder ann (BooleanLiteral True) ] (Right (Literal ann (CharLiteral 't')))@@ -174,7 +175,7 @@ App ann (App ann (App ann- (Var ann (Qualified (Just mn) (Ident "f")))+ (Var ann (Qualified (ByModuleName mn) (Ident "f"))) (Var ann eqBoolean)) (Literal ann (BooleanLiteral True))) (Literal ann (BooleanLiteral True))@@ -196,10 +197,10 @@ (App ann (Var ann eq) (Var ann eqBoolean))- (Var ann (Qualified Nothing (Ident "x"))))+ (Var ann (Qualified (BySourcePos sp) (Ident "x")))) (Literal ann (BooleanLiteral True)) , Literal ann (CharLiteral 't'))- , ( Var ann (Qualified (Just (ModuleName "Data.Boolean")) (Ident "otherwise"))+ , ( Var ann (Qualified (ByModuleName (ModuleName "Data.Boolean")) (Ident "otherwise")) , (Literal ann (CharLiteral 'f')) ) ])@@ -222,11 +223,12 @@ "src/Utils.purs" [] [Ident "isProduction"]+ Map.empty [] [NonRec ann (Ident "isProduction") (Literal ann (BooleanLiteral True))] e :: Expr Ann e = Case ann- [ Var ann (Qualified (Just (ModuleName "Utils")) (Ident "isProduction"))]+ [ Var ann (Qualified (ByModuleName (ModuleName "Utils")) (Ident "isProduction"))] [ CaseAlternative [LiteralBinder ann (BooleanLiteral True)] (Right (Literal ann (CharLiteral 't'))) , CaseAlternative [LiteralBinder ann (BooleanLiteral False)] (Right (Literal ann (CharLiteral 'f'))) ]@@ -238,11 +240,12 @@ "src/Main.purs" [] []+ Map.empty [] [NonRec ann (Ident "main") e] -- TODO case evaluate [mm, um] of- ((Module _ _ _ _ _ _ _ [NonRec _ (Ident "main") (Literal _ (CharLiteral 't'))]) : _) -> return ()+ ((Module _ _ _ _ _ _ _ _ [NonRec _ (Ident "main") (Literal _ (CharLiteral 't'))]) : _) -> return () r -> assertFailure $ "unexpected result:\n" ++ show r -- Left err -> assertFailure $ "compilation error: " ++ show err @@ -258,11 +261,11 @@ let e :: Expr Ann e = (App ann (App ann- (Var ann (Qualified (Just (ModuleName "Data.Array")) (Ident "index")))+ (Var ann (Qualified (ByModuleName (ModuleName "Data.Array")) (Ident "index"))) (Literal ann (ArrayLiteral [Literal ann (CharLiteral 't')]))) (Literal ann (NumericLiteral (Left 0)))) case dceEvalExpr e of- (App _ (Var _ (Qualified (Just (ModuleName "Data.Maybe")) (Ident "Just"))) (Literal _ (CharLiteral 't'))) -> return ()+ (App _ (Var _ (Qualified (ByModuleName (ModuleName "Data.Maybe")) (Ident "Just"))) (Literal _ (CharLiteral 't'))) -> return () x -> assertFailure $ "unexpected expression:\n" ++ showExpr x -- Left err -> assertFailure $ "compilation error: " ++ show err @@ -274,7 +277,7 @@ e :: Expr Ann e = Let ann [ NonRec ann (Ident "a") (Literal ann (CharLiteral 'a')) ] (Let ann [ NonRec ann (Ident "a") (Literal ann (CharLiteral 'b')) ]- (Var ann (Qualified Nothing (Ident "a"))))+ (Var ann (Qualified (BySourcePos sp) (Ident "a")))) case dceEvalExpr e of Let _ _ (Let _ _ (Literal _ (CharLiteral 'b'))) -> return () x -> assertFailure $ "unexpected expression:\n" ++ showExpr x@@ -282,9 +285,9 @@ context "Var inlining" $ do let oModName = ModuleName "Other"- oMod = Module ss [] oModName "" [] [] []- [ NonRec ann (Ident "o") $ Literal ann (ObjectLiteral [(mkString "a", Var ann (Qualified (Just C.eqMod) (Ident "eq"))) ])- , NonRec ann (Ident "a") $ Literal ann (ArrayLiteral [ Var ann (Qualified (Just C.eqMod) (Ident "eq")) ])+ oMod = Module ss [] oModName "" [] [] Map.empty []+ [ NonRec ann (Ident "o") $ Literal ann (ObjectLiteral [(mkString "a", Var ann (Qualified (ByModuleName C.eqMod) (Ident "eq"))) ])+ , NonRec ann (Ident "a") $ Literal ann (ArrayLiteral [ Var ann (Qualified (ByModuleName C.eqMod) (Ident "eq")) ]) , NonRec ann (Ident "s") $ Literal ann (StringLiteral (mkString "very-long-string")) , NonRec ann (Ident "b") $ Literal ann (BooleanLiteral True) , NonRec ann (Ident "c") $ Literal ann (CharLiteral 'a')@@ -292,7 +295,7 @@ ] specify "should not inline Var linking to an object literal" $ do let e :: Expr Ann- e = Var ann (Qualified (Just oModName) (Ident "o"))+ e = Var ann (Qualified (ByModuleName oModName) (Ident "o")) case dceEvalExpr' e [oMod] of Var{} -> return () e' -> assertFailure $ "unexpected expression: " ++ showExpr e'@@ -300,7 +303,7 @@ specify "should not inline Var linking to an array literal" $ do let e :: Expr Ann- e = Var ann (Qualified (Just oModName) (Ident "a"))+ e = Var ann (Qualified (ByModuleName oModName) (Ident "a")) case dceEvalExpr' e [oMod] of Var{} -> return () e' -> assertFailure $ "unexpected expression: " ++ showExpr e'@@ -308,7 +311,7 @@ specify "should not inline Var linking to a string literal" $ do let e :: Expr Ann- e = Var ann (Qualified (Just oModName) (Ident "s"))+ e = Var ann (Qualified (ByModuleName oModName) (Ident "s")) case dceEvalExpr' e [oMod] of Var{} -> return () e' -> assertFailure $ "unexpected expression: " ++ showExpr e'@@ -316,7 +319,7 @@ specify "should inline Var lining to a boolean literal" $ do let e :: Expr Ann- e = Var ann (Qualified (Just oModName) (Ident "b"))+ e = Var ann (Qualified (ByModuleName oModName) (Ident "b")) case dceEvalExpr' e [oMod] of (Literal _ (BooleanLiteral{})) -> return () e' -> assertFailure $ "wront expression: " ++ showExpr e'@@ -324,7 +327,7 @@ specify "should inline Var lining to a char literal" $ do let e :: Expr Ann- e = Var ann (Qualified (Just oModName) (Ident "c"))+ e = Var ann (Qualified (ByModuleName oModName) (Ident "c")) case dceEvalExpr' e [oMod] of (Literal _ (CharLiteral{})) -> return () e' -> assertFailure $ "wront expression: " ++ showExpr e'@@ -332,7 +335,7 @@ specify "should inline Var lining to a numeric literal" $ do let e :: Expr Ann- e = Var ann (Qualified (Just oModName) (Ident "n"))+ e = Var ann (Qualified (ByModuleName oModName) (Ident "n")) case dceEvalExpr' e [oMod] of (Literal _ (NumericLiteral{})) -> return () e' -> assertFailure $ "wront expression: " ++ showExpr e'
test/Test/Generators.hs view
@@ -7,7 +7,7 @@ import Data.String (IsString (..)) import Test.QuickCheck -import Language.PureScript.Names (Ident (..), ModuleName (..), ProperName (..), Qualified (..))+import Language.PureScript.Names (Ident (..), ModuleName (..), ProperName (..), Qualified (..), QualifiedBy (..)) import Language.PureScript.PSString (PSString) import Language.PureScript.AST.SourcePos (SourceSpan (..), SourcePos (..)) import Language.PureScript.AST (Literal (..))@@ -50,20 +50,20 @@ genQualifiedIdent :: Gen (Qualified Ident) genQualifiedIdent = oneof- [ Qualified <$> liftArbitrary genModuleName <*> genIdent- , return (Qualified (Just C.unit) (Ident "unit"))- , return (Qualified (Just C.semiring) (Ident "add"))- , return (Qualified (Just C.semiring) (Ident "semiringInt"))- , return (Qualified (Just C.semiring) (Ident "semiringUnit"))- , return (Qualified (Just C.maybeMod) (Ident "Just"))- , return (Qualified (Just C.eqMod) (Ident "eq"))- , return (Qualified (Just C.ring) (Ident "negate"))- , return (Qualified (Just C.ring) (Ident "ringNumber"))- , return (Qualified (Just C.ring) (Ident "unitRing"))+ [ (Qualified . ByModuleName <$> genModuleName) <*> genIdent+ , return (Qualified (ByModuleName C.unit) (Ident "unit"))+ , return (Qualified (ByModuleName C.semiring) (Ident "add"))+ , return (Qualified (ByModuleName C.semiring) (Ident "semiringInt"))+ , return (Qualified (ByModuleName C.semiring) (Ident "semiringUnit"))+ , return (Qualified (ByModuleName C.maybeMod) (Ident "Just"))+ , return (Qualified (ByModuleName C.eqMod) (Ident "eq"))+ , return (Qualified (ByModuleName C.ring) (Ident "negate"))+ , return (Qualified (ByModuleName C.ring) (Ident "ringNumber"))+ , return (Qualified (ByModuleName C.ring) (Ident "unitRing")) ] genQualified :: Gen a -> Gen (Qualified a)-genQualified gen = Qualified <$> liftArbitrary genModuleName <*> gen+genQualified gen = Qualified . ByModuleName <$> genModuleName <*> gen genLiteral :: Gen (Literal (Expr Ann)) genLiteral = oneof
test/Test/Karma.hs view
@@ -1,12 +1,7 @@ module Test.Karma (spec) where -import Prelude ()-import Prelude.Compat hiding (exp)-import Control.Monad (when) import Control.Monad.Trans.Class import Control.Monad.Except-import Data.List (init)-import Data.Foldable (forM_) import Data.Text (Text) import qualified Data.Text as T import System.Directory (setCurrentDirectory)
test/Test/Lib.hs view
@@ -1,84 +1,176 @@+{-# LANGUAGE NoImplicitPrelude #-}+ module Test.Lib (spec) where -import Prelude ()-import Prelude.Compat hiding (exp)-import Control.Monad (when)-import Control.Monad.Trans.Class-import Control.Monad.Except-import Data.Foldable (forM_)-import Data.Text (Text)+import Control.Monad.Except+import Data.Text (Text) import qualified Data.Text as T-import Data.Semigroup ((<>))-import System.Exit (ExitCode(..))-import System.Process (readProcessWithExitCode)-import Test.Hspec-import Test.HUnit (assertEqual)--import Test.Utils-+import System.Exit (ExitCode (..))+import System.Process (readProcessWithExitCode)+import Test.HUnit (assertEqual)+import Test.Hspec+import Test.Utils+import Prelude hiding (exp) data LibTest = LibTest- { libTestEntries :: [Text]- , libTestZephyrOptions :: Maybe [Text]- , libTestJsCmd :: Text- , libTestShouldPass :: Bool- -- ^ true if it should run without error, false if it should error+ { libTestEntries :: [Text],+ libTestZephyrOptions :: Maybe [Text],+ libTestJs :: Text,+ -- | true if it should run without error, false if it should error+ libTestShouldPass :: Bool } - libTests :: [LibTest] libTests =- [ LibTest ["Unsafe.Coerce.Test.unsafeX"] Nothing "require('./dce-output/Unsafe.Coerce.Test').unsafeX(1)(1);" True- , LibTest ["Foreign.Test.add"] Nothing "require('./dce-output/Foreign.Test').add(1)(1);" True- , LibTest ["Foreign.Test.add"] Nothing "require('./dce-output/Foreign.Test/foreign.js').mult(1)(1);" False- , LibTest ["Eval.makeAppQueue"] Nothing "require('./dce-output/Eval').makeAppQueue;" True- , LibTest ["Eval.evalUnderArrayLiteral"] Nothing "require('./dce-output/Eval').evalUnderArrayLiteral;" True- , LibTest ["Eval.evalUnderObjectLiteral"] Nothing "require('./dce-output/Eval').evalUnderObjectLiteral;" True- , LibTest ["Eval.evalVars"] Nothing "require('./dce-output/Eval').evalVars;" True- , LibTest ["Eval"] Nothing "require('./dce-output/Eval').evalVars;" True- , LibTest ["Eval.recordUpdate"] Nothing- ( " var eval = require('./dce-output/Eval');\n"- <> " var foo = eval.recordUpdate({foo: '', bar: 0})(eval.Foo.create('foo'));\n"- <> " if (foo.foo != 'foo') {\n"- <> " console.error(foo)\n"- <> " throw('Error')\n"- <> " }\n"+ [ LibTest+ ["Unsafe.Coerce.Test.unsafeX"]+ Nothing+ ( "import { unsafeX } from './dce-output/Unsafe.Coerce.Test/index.js';"+ <> "unsafeX(1)(1);" )+ True,+ LibTest+ ["Foreign.Test.add"]+ Nothing+ ( "import { add } from './dce-output/Foreign.Test/index.js';"+ <> "add(1)(1);"+ )+ True,+ LibTest+ ["Foreign.Test.add"]+ Nothing+ ( "import { mult } from './dce-output/Foreign.Test/index.js';"+ <> "mult(1)(1);"+ )+ False,+ LibTest+ ["Foreign.Test.add"]+ Nothing+ "import { mult } from './dce-output/Foreign.Test/foreign.js';"+ False,+ LibTest+ ["Foreign.Test.snowflake"]+ Nothing+ ( "import { snowflake } from './dce-output/Foreign.Test/index.js';"+ <> "if(snowflake !== '❄'){console.error(`'${snowflake}' !== '❄'`); throw 'Error';}"+ )+ True,+ LibTest+ ["Foreign.Test.b"]+ Nothing+ ( "import { b } from './dce-output/Foreign.Test/index.js';"+ <> "if(b() !== 5) throw 'Error';"+ )+ True,+ LibTest+ ["Eval.makeAppQueue"]+ Nothing+ "import { makeAppQueue } from './dce-output/Eval/index.js';"+ True,+ LibTest+ ["Eval.evalUnderArrayLiteral"]+ Nothing+ "import { evalUnderArrayLiteral } from './dce-output/Eval/index.js';"+ True,+ LibTest+ ["Eval.evalUnderObjectLiteral"]+ Nothing+ "import { evalUnderObjectLiteral } from './dce-output/Eval/index.js';"+ True,+ LibTest+ ["Eval.evalVars"]+ Nothing+ "import { evalVars } from './dce-output/Eval/index.js';"+ True,+ LibTest+ ["Eval"]+ Nothing+ "import { evalVars } from './dce-output/Eval/index.js';"+ True,+ LibTest+ ["Eval.recordUpdate"]+ Nothing+ ( "import * as E from './dce-output/Eval/index.js';"+ <> "var foo = E.recordUpdate({ foo: '', bar: 0 })(E.Foo.create('foo'));"+ <> "if (foo.foo != 'foo') {"+ <> " console.error(foo);"+ <> " throw 'Error';"+ <> "}"+ )+ True,+ LibTest+ ["Literals.fromAnArray"]+ Nothing+ ( "import * as lits from './dce-output/Literals/index.js';"+ <> "if (lits.fromAnArray == null || lits.AStr == null || lits.AInt != null) {"+ <> " throw 'Error';"+ <> "}"+ )+ True,+ LibTest+ ["Literals.fromAnObject"]+ Nothing+ ( "import * as lits from './dce-output/Literals/index.js';"+ <> "if (lits.fromAnObject == null || lits.AStr == null || lits.AInt != null) {"+ <> " throw 'Error';"+ <> "}"+ )+ True,+ -- Control.Alt re-exports map from Data.Functor+ LibTest+ ["Control.Alt.map"]+ Nothing+ "import { map } from './dce-output/Control.Alt/index.js';"+ True,+ LibTest+ ["Data.Array.span"]+ Nothing+ ( "import { span } from './dce-output/Data.Array/index.js';"+ <> "const a = [1, 3, 2, 4, 5];"+ <> "const p = (x) => x % 2 === 1;"+ <> "const r = span(p)(a);"+ <> "const expected = { init: [1, 3], rest: [2, 4, 5] };"+ <> "console.log(r);"+ <> "if (!r.init.every((e, i) => e === expected.init[i])) throw 'Error';"+ <> "if (!r.rest.every((e, i) => e === expected.rest[i])) throw 'Error';"+ ) True ] - assertLib :: LibTest -> Expectation assertLib l = do res <- runExceptT . runLibTest $ l assertEqual "lib should run" (Right ()) res - runLibTest :: LibTest -> ExceptT TestError IO ()-runLibTest LibTest { libTestEntries- , libTestZephyrOptions- , libTestJsCmd- , libTestShouldPass- } = do- bowerInstall "LibTest"- pursCompile "LibTest"- runZephyr "LibTest" libTestEntries libTestZephyrOptions- (ecNode, stdNode, errNode) <- lift- $ readProcessWithExitCode- "node"- [ "-e"- , T.unpack libTestJsCmd- ]- ""- when (libTestShouldPass && ecNode /= ExitSuccess)- (throwError $ NodeError "LibTest (should pass)" ecNode stdNode errNode)- when (not libTestShouldPass && ecNode == ExitSuccess)- (throwError $ NodeError "LibTest (should fail)" ecNode stdNode errNode)-+runLibTest+ LibTest+ { libTestEntries,+ libTestZephyrOptions,+ libTestJs,+ libTestShouldPass+ } = do+ spagoBuild "LibTest"+ runZephyr "LibTest" libTestEntries libTestZephyrOptions+ (ecNode, stdNode, errNode) <-+ lift $+ readProcessWithExitCode+ "node"+ [ "--input-type=module",+ "-e",+ T.unpack libTestJs+ ]+ ""+ when+ (libTestShouldPass && ecNode /= ExitSuccess)+ (throwError $ NodeError "LibTest (should pass)" ecNode stdNode errNode)+ when+ (not libTestShouldPass && ecNode == ExitSuccess)+ (throwError $ NodeError "LibTest (should fail)" ecNode stdNode errNode) spec :: Spec spec = changeDir "test/lib-tests" $- context "TestLib" $+ context "test-lib" $ forM_ libTests $ \l -> specify (T.unpack $ T.intercalate (T.pack " ") $ libTestEntries l) $ assertLib l
test/Test/Utils.hs view
@@ -1,13 +1,12 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE NoImplicitPrelude #-} module Test.Utils where -import Prelude ()-import Prelude.Compat hiding (exp)-import Control.Monad (when)+import Prelude hiding (exp)+import Control.Exception (bracket) import Control.Monad.Trans.Class import Control.Monad.Except-import Data.List (last) import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T@@ -33,15 +32,30 @@ test_args = ["exec", "zephyr", "--"] #endif +pursExe, bowerExe, npmExe, nodeExe, gitExe, spagoExe :: String+#if !defined(mingw32_HOST_OS)+pursExe = "purs"+gitExe = "git"+nodeExe = "node"+#else+pursExe = "purs.exe"+gitExe = "git.exe"+nodeExe = "node.exe"+#endif+bowerExe = "bower"+npmExe = "npm"+spagoExe = "spago" + changeDir :: FilePath -> Spec -> Spec changeDir path = around_ $ \runTests -> do createDirectoryIfMissing False path cwd <- getCurrentDirectory- setCurrentDirectory path- runTests- setCurrentDirectory cwd+ bracket+ (setCurrentDirectory path)+ (\_ -> setCurrentDirectory cwd)+ (\_ -> runTests) bowerInstall@@ -50,9 +64,23 @@ bowerInstall coreLibTestRepo = do bowerComponentsExists <- lift $ doesDirectoryExist "bower_components" when (not bowerComponentsExists) $ do- (ecBower, _, errBower) <- lift $ readProcessWithExitCode "bower" ["install"] ""+ (ecBower, _, errBower) <- lift $ readProcessWithExitCode bowerExe ["install"] "" when (ecBower /= ecBower) (throwError (BowerError coreLibTestRepo ecBower errBower)) +spagoBuild+ :: Text+ -> ExceptT TestError IO ()+spagoBuild coreLibTestRepo = do+ outputDirExists <- lift $ doesDirectoryExist "output"+ unless outputDirExists $ do+ (ecSpago, _, errSpago) <- lift+ $ readProcessWithExitCode+ spagoExe+ [ "build"+ , "--purs-args" , "--codegen corefn,js"+ ]+ ""+ when (ecSpago /= ExitSuccess) (throwError $ SpagoError coreLibTestRepo ecSpago errSpago) pursCompile :: Text@@ -62,12 +90,11 @@ when (not outputDirExists) $ do (ecPurs, _, errPurs) <- lift $ readProcessWithExitCode- "purs"+ pursExe [ "compile" , "--codegen" , "corefn" , "bower_components/purescript-*/src/**/*.purs" , "src/**/*.purs"- , "test/**/*.purs" ] "" when (ecPurs /= ExitSuccess) (throwError $ PursError coreLibTestRepo ecPurs errPurs)@@ -81,7 +108,7 @@ repoExist <- lift $ doesDirectoryExist $ T.unpack dir unless repoExist $ do- (ecGit, _, errGc) <- lift $ readProcessWithExitCode "git" ["clone", "--depth", "1", T.unpack coreLibTestRepo, T.unpack dir] ""+ (ecGit, _, errGc) <- lift $ readProcessWithExitCode gitExe ["clone", "--depth", "1", T.unpack coreLibTestRepo, T.unpack dir] "" when (ecGit /= ExitSuccess) (throwError (GitError coreLibTestRepo ecGit errGc)) return (T.unpack dir) @@ -94,10 +121,10 @@ pkgJson <- lift $ doesFileExist "package.json" nodeModulesExists <- lift $ doesDirectoryExist "node_modules" when ((pkgJson || not (null npmModules)) && not nodeModulesExists) $ do- when (not $ null $ npmModules) $ do- (ecNpm, _, errNpm) <- lift $ readProcessWithExitCode "npm" (["install"] ++ T.unpack `map` npmModules) ""+ unless (null npmModules) $ do+ (ecNpm, _, errNpm) <- lift $ readProcessWithExitCode npmExe (["install"] ++ T.unpack `map` npmModules) "" when (ecNpm /= ExitSuccess) (throwError (NpmError coreLibTestRepo ecNpm errNpm))- (ecNpm, _, errNpm) <- lift $ readProcessWithExitCode "npm" ["install"] ""+ (ecNpm, _, errNpm) <- lift $ readProcessWithExitCode npmExe ["install"] "" when (ecNpm /= ExitSuccess) (throwError (NpmError coreLibTestRepo ecNpm errNpm)) @@ -128,6 +155,7 @@ | ZephyrError Text ExitCode String | NodeError Text ExitCode String String | JsCmdError Text Text+ | SpagoError Text ExitCode String deriving (Eq) instance Show TestError where@@ -148,3 +176,5 @@ show (NodeError repo ec std err) = "node failed \"" ++ T.unpack repo ++ "\" (" ++ show ec ++ ")\n\n" ++ std ++ "\n\n" ++ err show (JsCmdError exp got) = "expected:\n\n" ++ T.unpack exp ++ "\n\nbut got:\n\n" ++ T.unpack got ++ "\n"+ show (SpagoError repo ec err)+ = "spago build failed \"" ++ T.unpack repo ++ "\" (" ++ show ec ++ ")\n" ++ err
zephyr.cabal view
@@ -1,23 +1,23 @@ cabal-version: 2.0-version: 0.3.2+version: 0.5.3 name: zephyr synopsis: Zephyr, tree-shaking for the PureScript language description: Tree shaking tool and partial evaluator for PureScript CoreFn AST.-homepage: https://github.com/coot/zephyr#readme+homepage: https://github.com/MaybeJustJames/zephyr#readme license: MPL-2.0 license-file: LICENSE author: Marcin Szamotulski <profunctor@pm.me>-maintainer: Marcin Szamotulski <profunctor@pm.me>-copyright: (c) 2017-2018 Marcin Szamotulski+maintainer: James Collier <jhc_at_home@proton.me>+copyright: (c) 2017-2021 Marcin Szamotulski, (c) 2022-2023 James Collier build-type: Simple extra-source-files: ChangeLog.md README.md category: Development-tested-with: ghc+tested-with: GHC==9.2.7 flag test-with-stack description: use `stack exec zephyr` in tests@@ -40,7 +40,6 @@ KindSignatures LambdaCase MultiParamTypeClasses- NoImplicitPrelude NamedFieldPuns OverloadedStrings PatternGuards@@ -51,7 +50,12 @@ ViewPatterns ghc-options: -Wall- -fmax-pmcheck-iterations=4000000+ -Wcompat+ -Widentities+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wpartial-fields+ -Wredundant-constraints exposed-modules: Language.PureScript.DCE , Language.PureScript.DCE.Constants@@ -61,18 +65,18 @@ , Language.PureScript.DCE.Eval , Language.PureScript.DCE.Utils build-depends:- aeson >=1.0 && <1.5- , ansi-terminal >=0.7.1 && <0.11- , base >=4.8 && <5- , base-compat >=0.6.0- , boxes ^>=0.1.4- , containers+ aeson >=2.0.3.0 && <2.1+ , ansi-terminal >=0.11 && <0.12+ , base >=4.16.2 && <4.17+ , boxes >=0.1.5 && <0.2+ , containers >=0.6.5.1 && <0.7 , formatting- , language-javascript ^>=0.7.1- , mtl >=2.1.0 && <2.3.0- , purescript ^>=0.13.8- , safe ^>=0.3.9- , text+ , language-javascript ==0.7.0.0+ , mtl >=2.2.2 && <2.3+ , purescript >=0.15.4 && <0.16+ , safe >=0.3.19 && <0.4+ , text >=1.2.5.0 && <1.3+ , unordered-containers == 0.2.19.1 default-language: Haskell2010 executable zephyr@@ -91,30 +95,36 @@ OverloadedStrings ghc-options: -Wall+ -Wcompat+ -Widentities+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wpartial-fields+ -Wredundant-constraints -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts -N2 build-depends:- aeson >=1.0 && <1.5+ aeson >=2.0.3.0 && <2.1 , async- , ansi-terminal >=0.7.1 && <0.11- , ansi-wl-pprint- , base- , bytestring- , containers- , directory >=1.2.3- , filepath+ , ansi-terminal >=0.11 && <0.12+ , ansi-wl-pprint >=0.6.9 && <0.7+ , base >=4.16.2 && <4.17+ , bytestring >=0.11.3.1 && <0.12+ , containers >=0.6.5.1 && <0.7+ , directory >=1.3.6.2 && <1.4+ , filepath >=1.4.2.2 && <1.5 , formatting- , Glob >=0.9 && <0.11- , language-javascript ^>=0.7- , mtl >=2.1.0 && <2.3.0- , optparse-applicative >=0.13.0- , purescript ^>=0.13.8- , text- , transformers >=0.3.0 && <0.6- , utf8-string >=1 && <2- , zephyr+ , Glob >=0.10.2 && <0.11+ , language-javascript ==0.7.0.0+ , mtl >=2.2.2 && <2.3+ , optparse-applicative >=0.17.0.0 && <0.18+ , purescript >=0.15.4 && <0.16+ , text >=1.2.5.0 && <1.3+ , transformers >=0.5.6.2 && <0.6+ , utf8-string >=1.0.2 && <1.1+ , zephyr >=0.5 && <0.6 default-language: Haskell2010 test-suite zephyr-test@@ -137,24 +147,22 @@ , Test.Karma , Test.Utils build-depends:- aeson >=1.0 && <1.5- , base >=4.8 && <5- , base-compat >=0.6.0- , containers- , directory >=1.2.3+ aeson >=2.0.3.0 && <2.1+ , base >=4.16.2 && <4.17+ , containers >=0.6.5.1 && <0.7+ , directory >=1.3.6.2 && <1.4 , hspec- , hspec-core+ , hspec-core <2.9.3 , HUnit- , language-javascript ^>=0.7- , mtl >=2.1.0 && <2.3.0- , optparse-applicative >=0.13.0- , process <1.7.0.0- , purescript ^>=0.13.8+ , language-javascript ==0.7.0.0+ , mtl >=2.2.2 && <2.3+ , optparse-applicative ==0.17.0.0+ , process ==1.6.13.1+ , purescript >=0.15.4 && <0.16 , QuickCheck >=2.12.1- , text- , transformers >=0.3.0 && <0.6- , utf8-string >=1 && <2- , zephyr+ , text >=1.2.5.0 && <1.3+ , transformers >=0.5.6.2 && <0.6+ , zephyr >=0.5 && <0.6 build-tool-depends: purescript:purs if flag(test-with-stack)@@ -165,6 +173,12 @@ -DTEST_CORE_LIBS=1 ghc-options: -Wall+ -Wcompat+ -Widentities+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wpartial-fields+ -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N@@ -172,4 +186,4 @@ source-repository head type: git- location: https://github.com/coot/zephyr+ location: https://github.com/MaybeJustJames/zephyr