8e56f00 · rowtype-yoga/purescript-native

examples/passing/TopLevelCase.purs+5−5

compare with golang

unifiedsplit

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

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

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

2−gcd (0, x) = x

2+_1 (0, x) = x

3−gcd (x, 0) = x

3+_1 (x, 0) = x

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

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

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

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

6

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

8guardsTest xs = xs

purescript.cabal+6−6

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

12category: Language

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

14data-dir: ""

15−

15+

16library

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

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

19 transformers -any, utf8-string -any

20− exposed-modules: Data.Generics.Extras

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

21 Language.PureScript Language.PureScript.CodeGen

22 Language.PureScript.CodeGen.Externs Language.PureScript.CodeGen.JS

23 Language.PureScript.CodeGen.JS.AST

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

41 exposed: True

42 buildable: True

43 hs-source-dirs: src

44−

44+

45executable psc

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

47 directory -any, filepath -any, mtl -any, parsec -any,

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

49 main-is: Main.hs

50 buildable: True

51 hs-source-dirs: src

52−-- other-modules:

52+ other-modules: Language.PureScript.Scope

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

54−

54+

55test-suite tests

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

57 directory -any, filepath -any, mtl -any, parsec -any,

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

59 type: exitcode-stdio-1.0

60 main-is: Main.hs

61 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 (

19import Data.List (groupBy)

20import Control.Monad (join, unless)

21import Control.Monad.Error.Class

22+

22import Language.PureScript.Names

23import Language.PureScript.Names

23import Language.PureScript.Values

24import Language.PureScript.Values

24import Language.PureScript.Declarations

25import Language.PureScript.Declarations

26+import Language.PureScript.Scope

25

27

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

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

27desugarCases = fmap join . mapM toDecls . groupBy inSameGroup

29desugarCases = fmap join . mapM toDecls . groupBy inSameGroup

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

47makeCaseDeclaration ident alternatives =

49makeCaseDeclaration ident alternatives =

48 let

50 let

49 argPattern = map length . fst . head $ alternatives

51 argPattern = map length . fst . head $ alternatives

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

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

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

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

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

54 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)

54 in

56 in

55 ValueDeclaration ident [] Nothing value

57 ValueDeclaration ident [] Nothing value

56

58

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

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

58−toArgs = go 1

60+rearrange [] _ = []

59− where

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

60− go _ [] = []

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

62

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

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

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

26import Language.PureScript.Values

27import Language.PureScript.Names

28+import Language.PureScript.Scope

28import Language.PureScript.Declarations

29import Language.PureScript.Declarations

29import Language.PureScript.Pretty.Common

30import Language.PureScript.Pretty.Common

30import Language.PureScript.CodeGen.Monad

31import Language.PureScript.CodeGen.Monad

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

96

97

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

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

98bindersToJs m e binders vals = do

99bindersToJs m e binders vals = do

100+ setNextName $ firstUnusedName (binders, vals)

99 valNames <- replicateM (length vals) fresh

101 valNames <- replicateM (length vals) fresh

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

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

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

103 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

47data JSAssignment

48 = JSAssignVariable Ident

49 | 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

19import Control.Monad.State

20import Control.Applicative

21

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)

23

24runGen :: Gen a -> a

25runGen = flip evalState 0 . unGen

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

29 n <- get

30 modify (+ 1)

31 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