8e56f00 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Better capture avoiding function argument names

commit8e56f00903d0ad2134fedf4dda13d48634e64079 authorPhil Freeman <paf31@cantab.net> dateThu 26 Dec 2013, 13:33 (13 years ago) parent6206aed

7 files changed+101−20

compare with golang

unifiedsplit

examples/passing/TopLevelCase.purs+5−5 purescript.cabal+6−6 src/Language/PureScript/CaseDeclarations.hs+8−8 src/Language/PureScript/CodeGen/JS.hs+2 src/Language/PureScript/CodeGen/JS/AST.hs+2 src/Language/PureScript/CodeGen/Monad.hs+7−1 src/Language/PureScript/Scope.hs+71

examples/passing/TopLevelCase.purs+5−5

@@ -1,8 +1,8 @@

1−gcd :: (Number, Number) -> Number

2−gcd (0, x) = x

3−gcd (x, 0) = x

4−gcd (x, y) | x > y = gcd (x % y, y)

5−gcd (x, y) = gcd (y % x, x)

1+_1 :: (Number, Number) -> Number

2+_1 (0, x) = x

3+_1 (x, 0) = x

4+_1 (x, y) | x > y = _1 (x % y, y)

5+_1 (x, y) = _1 (y % x, x)

77guardsTest (x:xs) | x > 0 = guardsTest xs

88guardsTest xs = xs

purescript.cabal+6−6

@@ -12,12 +12,12 @@ description: A small compile-to-JS language with extensible records and type-saf

1212category: Language

1313author: Phil Freeman <paf31@cantab.net>

1414data-dir: ""

15−

15+

1616library

1717 build-depends: base >=4 && <5, cmdtheline -any, containers -any,

1818 directory -any, filepath -any, mtl -any, parsec -any, syb -any,

1919 transformers -any, utf8-string -any

20− exposed-modules: Data.Generics.Extras

20+ exposed-modules: Language.PureScript.Scope Data.Generics.Extras

2121 Language.PureScript Language.PureScript.CodeGen

2222 Language.PureScript.CodeGen.Externs Language.PureScript.CodeGen.JS

2323 Language.PureScript.CodeGen.JS.AST

@@ -41,7 +41,7 @@ library

4141 exposed: True

4242 buildable: True

4343 hs-source-dirs: src

44−

44+

4545executable psc

4646 build-depends: base >=4 && <5, cmdtheline -any, containers -any,

4747 directory -any, filepath -any, mtl -any, parsec -any,

@@ -49,9 +49,9 @@ executable psc

4949 main-is: Main.hs

5050 buildable: True

5151 hs-source-dirs: src

52−-- other-modules:

52+ other-modules: Language.PureScript.Scope

5353 ghc-options: -Wall -O2 -fno-warn-unused-do-bind

54−

54+

5555test-suite tests

5656 build-depends: base >=4 && <5, cmdtheline -any, containers -any,

5757 directory -any, filepath -any, mtl -any, parsec -any,

@@ -59,4 +59,4 @@ test-suite tests

5959 type: exitcode-stdio-1.0

6060 main-is: Main.hs

6161 buildable: True

62− hs-source-dirs: tests

62+ hs-source-dirs: tests

src/Language/PureScript/CaseDeclarations.hs+8−8

@@ -19,9 +19,11 @@ module Language.PureScript.CaseDeclarations (

1919import Data.List (groupBy)

2020import Control.Monad (join, unless)

2121import Control.Monad.Error.Class

22+

2223import Language.PureScript.Names

2324import Language.PureScript.Values

2425import Language.PureScript.Declarations

26+import Language.PureScript.Scope

2527

2628desugarCases :: [Declaration] -> Either String [Declaration]

2729desugarCases = fmap join . mapM toDecls . groupBy inSameGroup

@@ -47,16 +49,14 @@ makeCaseDeclaration :: Ident -> [([[Binder]], (Maybe Guard, Value))] -> Declarat

4749makeCaseDeclaration ident alternatives =

4850 let

4951 argPattern = map length . fst . head $ alternatives

50− args = map (map (('_' :) . show)) $ toArgs argPattern

51− vars = concatMap (map (\arg -> Var (Qualified global (Ident arg)))) args

52+ args = take (sum argPattern) $ unusedNames (ident, alternatives)

53+ vars = map (\arg -> Var (Qualified global arg)) args

5254 binders = [ (join bs, g, val) | (bs, (g, val)) <- alternatives ]

53− value = foldr (\args' ret -> Abs (map Ident args') ret) (Case vars binders) args

55+ value = foldr (\args' ret -> Abs args' ret) (Case vars binders) (rearrange argPattern args)

5456 in

5557 ValueDeclaration ident [] Nothing value

5658

57−toArgs :: [Int] -> [[Int]]

58−toArgs = go 1

59− where

60− go _ [] = []

61− go start (n:ns) = [start..start + n - 1] : go (start + n) ns

59+rearrange :: [Int] -> [a] -> [[a]]

60+rearrange [] _ = []

61+rearrange (n:ns) xs = take n xs : rearrange ns (drop n xs)

6262

src/Language/PureScript/CodeGen/JS.hs+2

@@ -25,6 +25,7 @@ import Control.Monad (replicateM, forM)

2525import Language.PureScript.TypeChecker (Environment, names)

2626import Language.PureScript.Values

2727import Language.PureScript.Names

28+import Language.PureScript.Scope

2829import Language.PureScript.Declarations

2930import Language.PureScript.Pretty.Common

3031import Language.PureScript.CodeGen.Monad

@@ -96,6 +97,7 @@ qualifiedToJS f (Qualified (ModulePath parts) a) =

9697

9798bindersToJs :: ModulePath -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> Gen JS

9899bindersToJs m e binders vals = do

100+ setNextName $ firstUnusedName (binders, vals)

99101 valNames <- replicateM (length vals) fresh

100102 jss <- forM binders $ \(bs, grd, result) -> go valNames [JSReturn (valueToJs m e result)] bs grd

101103 return $ JSApp (JSFunction Nothing (map Ident valNames) (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))

src/Language/PureScript/CodeGen/JS/AST.hs+2

@@ -47,3 +47,5 @@ data JS

4747data JSAssignment

4848 = JSAssignVariable Ident

4949 | JSAssignProperty String JSAssignment deriving (Show, Data, Typeable)

50+

51+

src/Language/PureScript/CodeGen/Monad.hs+7−1

@@ -19,7 +19,7 @@ module Language.PureScript.CodeGen.Monad where

1919import Control.Monad.State

2020import Control.Applicative

2121

22−newtype Gen a = Gen { unGen :: State Int a } deriving (Functor, Applicative, Monad, MonadState Int)

22+newtype Gen a = Gen { unGen :: State Int a } deriving (Functor, Applicative, Monad, MonadState Int, MonadFix)

2323

2424runGen :: Gen a -> a

2525runGen = flip evalState 0 . unGen

@@ -29,3 +29,9 @@ fresh = do

2929 n <- get

3030 modify (+ 1)

3131 return $ '_' : show n

32+

33+getNextName :: Gen Int

34+getNextName = get

35+

36+setNextName :: Int -> Gen ()

37+setNextName = put

src/Language/PureScript/Scope.hsnew file+71

@@ -0,0 +1,71 @@

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

2+--

3+-- Module : Language.PureScript.Scope

4+-- Copyright : (c) Phil Freeman 2013

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.Scope (

16+ usedNames,

17+ unusedNames,

18+ firstUnusedName

19+) where

20+

21+import Data.Data

22+import Data.List ((\\), nub)

23+import Data.Generics (extQ, mkQ, everything)

24+

25+import Language.PureScript.Values

26+import Language.PureScript.Names

27+import Language.PureScript.CodeGen.JS.AST

28+import Data.Maybe (mapMaybe)

29+import Text.Read (readMaybe)

30+

31+usedNames :: (Data d) => d -> [Ident]

32+usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesS `extQ` namesB `extQ` namesJS) val

33+ where

34+ namesV :: Value -> [Ident]

35+ namesV (Abs args _) = args

36+ namesV (Var (Qualified (ModulePath []) name)) = [name]

37+ namesV _ = []

38+ namesS :: Statement -> [Ident]

39+ namesS (VariableIntroduction name _) = [name]

40+ namesS (For name _ _ _) = [name]

41+ namesS _ = []

42+ namesB :: Binder -> [Ident]

43+ namesB (VarBinder name) = [name]

44+ namesB _ = []

45+ namesJS :: JS -> [Ident]

46+ namesJS (JSVar name) = [name]

47+ namesJS (JSFunction (Just name) args _) = name : args

48+ namesJS (JSFunction Nothing args _) = args

49+ namesJS (JSVariableIntroduction name _) = [name]

50+ namesJS (JSFor name _ _ _) = [name]

51+ namesJS _ = []

52+

53+unusedNames :: (Data d) => d -> [Ident]

54+unusedNames val =

55+ let

56+ allNames = usedNames val

57+ varNames = map (Ident . ('_' :) . show) ([1..] :: [Int])

58+ in

59+ varNames \\ allNames

60+

61+firstUnusedName :: (Data d) => d -> Int

62+firstUnusedName val =

63+ let

64+ allNames = usedNames val

65+ varNames = mapMaybe toUnknown allNames

66+ in

67+ 1 + maximum (0 : varNames)

68+ where

69+ toUnknown :: Ident -> Maybe Int

70+ toUnknown (Ident ('_' : s)) = readMaybe s

71+ toUnknown _ = Nothing