24826e7 · rowtype-yoga/purescript-native

examples/passing/Operators.purs+2−1

compare with golang

unifiedsplit

@@ -15,6 +15,7 @@ module Operators1 where

15module Operators2 where

16

17 import Prelude

18+ import Operators1 ((@@))

18

19

19 test1 :: forall n. (Num n) => n -> n -> (n -> n -> n) -> n

20 test1 :: forall n. (Num n) => n -> n -> (n -> n -> n) -> n

20 test1 x y z = x * y + z x y

21 test1 x y z = x * y + z x y

@@ -40,7 +41,7 @@ module Operators2 where

40

41

41 test7 = "Hello" <> "World!"

42 test7 = "Hello" <> "World!"

42

43

43− test9 = Operators1.foo Operators1.@@ "Hello World"

44+ test9 = Operators1.foo @@ "Hello World"

44

45

45 test10 = "Hello" `Operators1.bar` "World"

46 test10 = "Hello" `Operators1.bar` "World"

46

47

prelude/tests/Eff.purs+1−1

@@ -58,4 +58,4 @@ module Main where

58

59import Tests

60

61−main = test9 {}

61+main = test5 {}

prelude/tests/build.sh+1−1

@@ -1,2 +1,2 @@

1−psc ../prelude.purs Eff.purs --magic-do --run-main --no-prelude -o Eff.js

1+psc ../prelude.purs Eff.purs --magic-do --tco --run-main --no-prelude --entry-point Main -o Eff.js

2

psc/Main.hs+5−1

@@ -98,8 +98,12 @@ browserNamespace :: Term String

98browserNamespace = value $ opt "PS" $ (optInfo [ "browser-namespace" ])

99 { optDoc = "Specify the namespace that PureScript modules will be exported to when running in the browser." }

100

101+entryPoint :: Term (Maybe String)

102+entryPoint = value $ opt Nothing $ (optInfo [ "entry-point" ])

103+ { optDoc = "Specify the module which is the entry point. All code which is not a transitive dependency of this module will be removed." }

104+

101options :: Term P.Options

105options :: Term P.Options

102−options = P.Options <$> tco <*> performRuntimeTypeChecks <*> magicDo <*> runMain <*> noOpts <*> browserNamespace

106+options = P.Options <$> tco <*> performRuntimeTypeChecks <*> magicDo <*> runMain <*> noOpts <*> browserNamespace <*> entryPoint

103

107

104stdInOrInputFiles :: FilePath -> Term (Maybe [FilePath])

108stdInOrInputFiles :: FilePath -> Term (Maybe [FilePath])

105stdInOrInputFiles prelude = combine <$> useStdIn <*> (not <$> noPrelude) <*> inputFiles

109stdInOrInputFiles prelude = combine <$> useStdIn <*> (not <$> noPrelude) <*> inputFiles

psci/Main.hs+1−1

@@ -35,7 +35,7 @@ getPreludeFilename :: IO FilePath

35getPreludeFilename = Paths.getDataFileName "prelude/prelude.purs"

36

37options :: P.Options

38−options = P.Options True False True True True "PS"

38+options = P.Options True False True True True "PS" Nothing

39

40completion :: [P.Module] -> CompletionFunc IO

41completion ms = completeWord Nothing " \t\n\r" findCompletions

purescript.cabal+1

@@ -27,6 +27,7 @@ library

27 Language.PureScript.Types

28 Language.PureScript.Values

29 Language.PureScript.Scope

30+ Language.PureScript.DeadCodeElimination

30 Language.PureScript.Sugar

31 Language.PureScript.Sugar

31 Language.PureScript.ModuleDependencies

32 Language.PureScript.ModuleDependencies

32 Language.PureScript.Sugar.CaseDeclarations

33 Language.PureScript.Sugar.CaseDeclarations

src/Language/PureScript.hs+8−2

@@ -27,8 +27,10 @@ import Language.PureScript.Pretty as P

27import Language.PureScript.Sugar as P

28import Language.PureScript.Options as P

29import Language.PureScript.ModuleDependencies as P

30+import Language.PureScript.DeadCodeElimination as P

30

31

31import Data.List (intercalate)

32import Data.List (intercalate)

33+import Data.Maybe (mapMaybe)

32import Control.Monad (when, forM)

34import Control.Monad (when, forM)

33import Control.Monad.State.Lazy

35import Control.Monad.State.Lazy

34import Control.Applicative ((<$>))

36import Control.Applicative ((<$>))

@@ -47,6 +49,8 @@ import qualified Data.Map as M

47--

49--

48-- * Regroup values to take into account new value dependencies introduced by elaboration

50-- * Regroup values to take into account new value dependencies introduced by elaboration

49--

51--

52+-- * Eliminate dead code

53+--

50-- * Generate Javascript, and perform optimization passes.

54-- * Generate Javascript, and perform optimization passes.

51--

55--

52-- * Pretty-print the generated Javascript

56-- * Pretty-print the generated Javascript

@@ -59,8 +63,10 @@ compile opts ms = do

59 modify (\s -> s { checkCurrentModule = Just (ModuleName moduleName) })

63 modify (\s -> s { checkCurrentModule = Just (ModuleName moduleName) })

60 Module moduleName <$> typeCheckAll (ModuleName moduleName) decls

64 Module moduleName <$> typeCheckAll (ModuleName moduleName) decls

61 regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

65 regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

66+ let entryPoint = optionsEntryPoint opts

67+ let elim = maybe regrouped (\ep -> eliminateDeadCode env ep regrouped) entryPoint

62− let js = map (flip (moduleToJs opts) env) $ regrouped

68+ let js = mapMaybe (flip (moduleToJs opts) env) elim

63− let exts = intercalate "\n" . map (flip moduleToPs env) $ regrouped

69+ let exts = intercalate "\n" . map (flip moduleToPs env) $ elim

64 js' <- case () of

70 js' <- case () of

65 _ | optionsRunMain opts -> do

71 _ | optionsRunMain opts -> do

66 when ((ModuleName (ProperName "Main"), Ident "main") `M.notMember` (names env)) $

72 when ((ModuleName (ProperName "Main"), Ident "main") `M.notMember` (names env)) $

src/Language/PureScript/CodeGen/JS.hs+6−4

@@ -51,11 +51,13 @@ import Language.PureScript.TypeChecker.Monad (canonicalizeDataConstructor)

51-- Generate code in the simplified Javascript intermediate representation for all declarations in a

52-- module.

53--

54−moduleToJs :: Options -> Module -> Environment -> JS

54+moduleToJs :: Options -> Module -> Environment -> Maybe JS

55moduleToJs opts (Module pname@(ProperName name) decls) env =

56+ case jsDecls of

57+ [] -> Nothing

56− JSAssignment (JSAccessor name (JSVar "_ps")) $ JSApp (JSFunction Nothing ["module"]

58+ _ -> Just $ JSAssignment (JSAccessor name (JSVar "_ps")) $

57− (JSBlock $ jsDecls ++ [JSReturn $ JSVar "module"]))

59+ JSApp (JSFunction Nothing ["module"] (JSBlock $ jsDecls ++ [JSReturn $ JSVar "module"]))

58− [(JSBinary Or (JSAccessor name (JSVar "_ps")) (JSObjectLiteral []))]

60+ [(JSBinary Or (JSAccessor name (JSVar "_ps")) (JSObjectLiteral []))]

59 where

61 where

60 jsDecls = (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts (ModuleName pname) decl env) (decls))

62 jsDecls = (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts (ModuleName pname) decl env) (decls))

61

63

src/Language/PureScript/CodeGen/Optimize.hs+1−1

@@ -382,7 +382,7 @@ inlineCommonOperators = applyAll

382 isOpDict className ty (JSApp (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == dictName = True

383 where

384 Right (Ident dictName) = mkDictionaryValueName

385− (ModuleName (ProperName "Prelude"))

385+ (ModuleName (ProperName "Prim"))

386 (Qualified (Just (ModuleName (ProperName "Prelude"))) (ProperName className))

387 ty

388 isOpDict _ _ _ = False

src/Language/PureScript/DeadCodeElimination.hsnew file+76

@@ -0,0 +1,76 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.DeadCodeElimination

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module Language.PureScript.DeadCodeElimination (

16+ eliminateDeadCode

17+) where

18+

19+import Data.Data

20+import Data.List

21+import Data.Graph

22+import Data.Generics

23+import Data.Maybe (mapMaybe)

24+

25+import Language.PureScript.Names

26+import Language.PureScript.Values

27+import Language.PureScript.Declarations

28+import Language.PureScript.TypeChecker.Monad

29+

30+-- |

31+-- Eliminate all declarations which are not a transitive dependency of the entry point module

32+--

33+eliminateDeadCode :: Environment -> String -> [Module] -> [Module]

34+eliminateDeadCode env entryPoint ms =

35+ let declarations = concatMap (declarationsByModule env) ms

36+ (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations

37+ entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((ModuleName (ProperName mn), _), _) -> mn == entryPoint) $ declarations

38+ in flip map ms $ \(Module moduleName ds) -> Module moduleName (filter (isUsed (ModuleName moduleName) graph vertexFor entryPointVertices) ds)

39+

40+type Key = (ModuleName, Either Ident ProperName)

41+

42+declarationsByModule :: Environment -> Module -> [(Key, [Key])]

43+declarationsByModule env (Module moduleName ds) = concatMap go $ ds

44+ where

45+ go :: Declaration -> [(Key, [Key])]

46+ go d@(ValueDeclaration name _ _ _) = [((ModuleName moduleName, Left name), dependencies env (ModuleName moduleName) d)]

47+ go (DataDeclaration _ _ dctors) = map (\(name, _) -> ((ModuleName moduleName, Right name), [])) dctors

48+ go (ExternDeclaration _ name _ _) = [((ModuleName moduleName, Left name), [])]

49+ go d@(BindingGroupDeclaration names) = map (\(name, _) -> ((ModuleName moduleName, Left name), dependencies env (ModuleName moduleName) d)) names

50+ go (DataBindingGroupDeclaration ds) = concatMap go ds

51+ go _ = []

52+

53+dependencies :: (Data d) => Environment -> ModuleName -> d -> [Key]

54+dependencies env moduleName = nub . everything (++) (mkQ [] values)

55+ where

56+ values :: Value -> [Key]

57+ values (Var ident) = let (mn, name) = canonicalize moduleName env ident in [(mn, Left name)]

58+ values (Constructor pn) = let (mn, name) = canonicalizeDataConstructor moduleName env pn in [(mn, Right name)]

59+ values _ = []

60+

61+isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Declaration -> Bool

62+isUsed moduleName graph vertexFor entryPointVertices (ValueDeclaration name _ _ _) =

63+ let Just v' = vertexFor (moduleName, Left name)

64+ in any (\v -> path graph v v') entryPointVertices

65+isUsed moduleName graph vertexFor entryPointVertices (DataDeclaration _ _ dctors) =

66+ any (\(pn, _) -> let Just v' = vertexFor (moduleName, Right pn)

67+ in any (\v -> path graph v v') entryPointVertices) dctors

68+isUsed moduleName graph vertexFor entryPointVertices (ExternDeclaration _ name _ _) =

69+ let Just v' = vertexFor (moduleName, Left name)

70+ in any (\v -> path graph v v') entryPointVertices

71+isUsed moduleName graph vertexFor entryPointVertices (BindingGroupDeclaration ds) =

72+ any (\(name, _) -> let Just v' = vertexFor (moduleName, Left name)

73+ in any (\v -> path graph v v') entryPointVertices) ds

74+isUsed moduleName graph vertexFor entryPointVertices (DataBindingGroupDeclaration ds) =

75+ any (isUsed moduleName graph vertexFor entryPointVertices) ds

76+isUsed _ _ _ _ _ = True

src/Language/PureScript/Names.hs+13−1

@@ -18,6 +18,7 @@

18module Language.PureScript.Names where

19

20import Data.Data

21+import Data.Function (on)

21

22

22-- |

23-- |

23-- Names for value identifiers

24-- Names for value identifiers

@@ -34,13 +35,24 @@ data Ident

34 -- |

35 -- |

35 -- An escaped name

36 -- An escaped name

36 --

37 --

37− | Escaped String deriving (Eq, Ord, Data, Typeable)

38+ | Escaped String deriving (Data, Typeable)

38

39

39instance Show Ident where

40instance Show Ident where

40 show (Ident s) = s

41 show (Ident s) = s

41 show (Op op) = '(':op ++ ")"

42 show (Op op) = '(':op ++ ")"

42 show (Escaped s) = s

43 show (Escaped s) = s

43

44

45+instance Eq Ident where

46+ Ident s1 == Ident s2 = s1 == s2

47+ Op s1 == Op s2 = s1 == s2

48+ Escaped s1 == Escaped s2 = s1 == s2

49+ Ident s1 == Escaped s2 = s1 == s2

50+ Escaped s1 == Ident s2 = s1 == s2

51+ _ == _ = False

52+

53+instance Ord Ident where

54+ compare = compare `on` show

55+

44-- |

56-- |

45-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.

57-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.

46--

58--

src/Language/PureScript/Options.hs+5−1

@@ -44,10 +44,14 @@ data Options = Options {

44 -- browser.

45 --

46 , optionsBrowserNamespace :: String

47+ -- |

48+ -- The entry point module, for dead code elimination

49+ --

50+ , optionsEntryPoint :: Maybe String

47 } deriving Show

51 } deriving Show

48

52

49-- |

53-- |

50-- Default compiler options

54-- Default compiler options

51--

55--

52defaultOptions :: Options

56defaultOptions :: Options

53−defaultOptions = Options False False False False False "PS"

57+defaultOptions = Options False False False False False "PS" Nothing

src/Language/PureScript/Parser/Common.hs+1−1

@@ -319,7 +319,7 @@ buildPostfixParser fs first = do

319-- Parse an identifier in backticks or an operator

320--

321parseIdentInfix :: P.Parsec String ParseState (Qualified Ident)

322−parseIdentInfix = (P.between tick tick (parseQualified (Ident <$> identifier))) <|> parseQualified (Op <$> operator)

322+parseIdentInfix = (P.between tick tick (parseQualified (Ident <$> identifier))) <|> Qualified Nothing <$> (Op <$> operator)

323

324-- |

325-- Mark the current indentation level

src/Language/PureScript/Sugar/Operators.hs+5−4

@@ -58,7 +58,11 @@ removeParens val = val

58customOperatorTable :: M.Map (Qualified Ident) Fixity -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]]

59customOperatorTable fixities =

60 let

61+ -- We make the assumption here that infix operators are not qualified. The parser currently enforces this.

62+ -- The fixity map can therefore map from module name/ident pairs to fixities, where the module name is the name

63+ -- of the module imported into, not from. This is useful in matchOp, but here we have to discard the module name to

64+ -- make sure that the generated code is correct.

61− applyUserOp name t1 t2 = App (App (Var name) t1) t2

65+ applyUserOp (Qualified _ name) t1 t2 = App (App (Var (Qualified Nothing name)) t1) t2

62 userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) . M.toList $ fixities

66 userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) . M.toList $ fixities

63 sorted = reverse $ sortBy (compare `on` (\(_, _, p, _) -> p)) userOps

67 sorted = reverse $ sortBy (compare `on` (\(_, _, p, _) -> p)) userOps

64 groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted

68 groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted

@@ -108,6 +112,3 @@ collectFixities m moduleName (ImportDeclaration importedModule _ : rest) = do

108 collectFixities (M.union m' m) moduleName rest

112 collectFixities (M.union m' m) moduleName rest

109collectFixities m moduleName (_:ds) = collectFixities m moduleName ds

113collectFixities m moduleName (_:ds) = collectFixities m moduleName ds

110

114

111−globalOp :: String -> Qualified Ident

112−globalOp = Qualified Nothing . Op

113−

src/Language/PureScript/TypeChecker/Monad.hs+5−5

@@ -224,11 +224,11 @@ canonicalizeType mn env (Qualified Nothing nm) = case (mn, nm) `M.lookup` types

224-- |

225-- Canonicalize a data constructor by resolving any aliases introduced by module imports

226--

227−canonicalizeDataConstructor :: ModuleName -> Environment -> Qualified ProperName -> (ModuleName, Ident)

227+canonicalizeDataConstructor :: ModuleName -> Environment -> Qualified ProperName -> (ModuleName, ProperName)

228−canonicalizeDataConstructor _ _ (Qualified (Just mn) i) = (mn, Ident $ show i)

228+canonicalizeDataConstructor _ _ (Qualified (Just mn) pn) = (mn, pn)

229−canonicalizeDataConstructor mn env (Qualified Nothing i) = case (mn, i) `M.lookup` dataConstructors env of

229+canonicalizeDataConstructor mn env (Qualified Nothing pn) = case (mn, pn) `M.lookup` dataConstructors env of

230− Just (_, Alias mn' i') -> (mn', i')

230+ Just (_, Alias mn' (Ident pn')) -> (mn', ProperName pn')

231− _ -> (mn, Ident $ show i)

231+ _ -> (mn, pn)

232

233-- |

234-- State required for type checking:

tests/Main.hs+1−1

@@ -66,7 +66,7 @@ assertCompiles :: FilePath -> IO ()

66assertCompiles inputFile = do

67 putStrLn $ "assert " ++ inputFile ++ " compiles successfully"

68 prelude <- preludeFilename

69− assert (P.defaultOptions { P.optionsRunMain = True, P.optionsNoOptimizations = True }) [prelude, inputFile] $ either (return . Just) $ \js -> do

69+ assert (P.defaultOptions { P.optionsRunMain = True, P.optionsNoOptimizations = True, P.optionsEntryPoint = Just "Main" }) [prelude, inputFile] $ either (return . Just) $ \js -> do

70 args <- getArgs

71 if "--run-js" `elem` args

72 then do