e22e8e7 · rowtype-yoga/purescript-native

examples/passing/List.purs+9−12

compare with golang

unifiedsplit

@@ -5,18 +5,15 @@ data List a

5 , tail :: List a

6 }

7

8−isNull = \l -> case l of

9− Nil -> true

8+isNull Nil = true

10− _ -> false

9+isNull _ = false

11

10

12−concat = \l1 -> \l2 -> case l1 of

13− Nil -> l2

11+concat (Nil) l2 = l2

14− Cons x -> Cons

12+concat (Cons x) l2 = Cons

15− { head: x.head

13+ { head: x.head

16− , tail: concat x.tail l2

14+ , tail: concat x.tail l2

17− }

15+ }

18

16

19−flatten = \xss -> case xss of

20− Nil -> Nil

17+flatten Nil = Nil

21− Cons cons -> concat cons.head (flatten cons.tail)

18+flatten (Cons cons) = concat cons.head (flatten cons.tail)

22

19

examples/passing/Maybe.purs+4−5

@@ -1,10 +1,9 @@

1data Maybe a = Nothing | Just a

2

3maybe :: forall a b. b -> (a -> b) -> Maybe a -> b

4−maybe = \b -> \f -> \m -> case m of

5− Nothing -> b

4+maybe b _ Nothing = b

6− Just a -> f a

5+maybe _ f (Just a) = f a

7

6

8−fmap = \m -> \f -> maybe Nothing (\a -> Just (f a)) m

7+fmap m f = maybe Nothing (\a -> Just (f a)) m

9

8

10−bind = \m -> \f -> maybe Nothing f m

9+bind m f = maybe Nothing f m

purescript.cabal+9−6

@@ -1,5 +1,5 @@

1name: purescript

2−version: 0.2.0

2+version: 0.2.1

3cabal-version: >=1.8

4build-type: Simple

5license: MIT

@@ -15,11 +15,12 @@ data-dir: ""

15

16library

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

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

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

19− syb -any, transformers -any, utf8-string -any

19+ transformers -any, utf8-string -any

20− exposed-modules: Data.Generics.Extras Language.PureScript

20+ exposed-modules: Data.Generics.Extras

21+ Language.PureScript Language.PureScript.CodeGen

21− Language.PureScript.CodeGen Language.PureScript.CodeGen.Externs

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

22− Language.PureScript.CodeGen.JS Language.PureScript.CodeGen.JS.AST

23+ Language.PureScript.CodeGen.JS.AST

23 Language.PureScript.CodeGen.Monad Language.PureScript.Declarations

24 Language.PureScript.CodeGen.Monad Language.PureScript.Declarations

24 Language.PureScript.Kinds Language.PureScript.Names

25 Language.PureScript.Kinds Language.PureScript.Names

25 Language.PureScript.Operators Language.PureScript.Optimize

26 Language.PureScript.Operators Language.PureScript.Optimize

@@ -36,6 +37,7 @@ library

36 Language.PureScript.TypeChecker.Synonyms

37 Language.PureScript.TypeChecker.Synonyms

37 Language.PureScript.TypeChecker.Types Language.PureScript.Types

38 Language.PureScript.TypeChecker.Types Language.PureScript.Types

38 Language.PureScript.Unknown Language.PureScript.Values Main

39 Language.PureScript.Unknown Language.PureScript.Values Main

40+ Language.PureScript.CaseDeclarations

39 exposed: True

41 exposed: True

40 buildable: True

42 buildable: True

41 hs-source-dirs: src

43 hs-source-dirs: src

@@ -47,6 +49,7 @@ executable psc

47 main-is: Main.hs

49 main-is: Main.hs

48 buildable: True

50 buildable: True

49 hs-source-dirs: src

51 hs-source-dirs: src

52+-- other-modules:

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

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

51

54

52test-suite tests

55test-suite tests

src/Language/PureScript.hs+5−3

@@ -25,6 +25,7 @@ import Language.PureScript.TypeChecker as P

25import Language.PureScript.Pretty as P

26import Language.PureScript.Optimize as P

27import Language.PureScript.Operators as P

28+import Language.PureScript.CaseDeclarations as P

28

29

29import Data.List (intercalate)

30import Data.List (intercalate)

30import Data.Maybe (mapMaybe)

31import Data.Maybe (mapMaybe)

@@ -32,7 +33,8 @@ import Data.Maybe (mapMaybe)

32compile :: [Declaration] -> Either String (String, String, Environment)

33compile :: [Declaration] -> Either String (String, String, Environment)

33compile decls = do

34compile decls = do

34 bracketted <- rebracket decls

35 bracketted <- rebracket decls

36+ desugared <- desugarCases bracketted

35− (_, env) <- runCheck (typeCheckAll bracketted)

37+ (_, env) <- runCheck (typeCheckAll desugared)

36− let js = prettyPrintJS . map optimize . concat . mapMaybe (\decl -> declToJs Nothing global decl env) $ bracketted

38+ let js = prettyPrintJS . map optimize . concat . mapMaybe (\decl -> declToJs Nothing global decl env) $ desugared

37− let exts = intercalate "\n" . mapMaybe (externToPs 0 global env) $ bracketted

39+ let exts = intercalate "\n" . mapMaybe (externToPs 0 global env) $ desugared

38 return (js, exts, env)

40 return (js, exts, env)

src/Language/PureScript/CaseDeclarations.hsnew file+56

@@ -0,0 +1,56 @@

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

2+--

3+-- Module : Language.PureScript.CaseDeclarations

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

16+ desugarCases

17+) where

18+

19+import Data.List (groupBy)

20+import Control.Monad (join, unless)

21+import Control.Monad.Error.Class

22+import Language.PureScript.Names

23+import Language.PureScript.Values

24+import Language.PureScript.Declarations

25+

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

27+desugarCases = fmap join . mapM toDecls . groupBy inSameGroup

28+

29+inSameGroup :: Declaration -> Declaration -> Bool

30+inSameGroup (ValueDeclaration ident1 _ _) (ValueDeclaration ident2 _ _) = ident1 == ident2

31+inSameGroup _ _ = False

32+

33+toDecls :: [Declaration] -> Either String [Declaration]

34+toDecls d@[ValueDeclaration _ [] _] = return d

35+toDecls ds@(ValueDeclaration ident bs _ : _) = do

36+ let pairs = map toPair ds

37+ unless (all ((== length bs) . length . fst) pairs) $

38+ throwError $ "Argument list lengths differ in declaration " ++ show pairs

39+ return [makeCaseDeclaration ident pairs]

40+toDecls ds = return ds

41+

42+toPair :: Declaration -> ([Binder], Value)

43+toPair (ValueDeclaration _ bs val) = (bs, val)

44+toPair _ = error "Not a value declaration"

45+

46+makeCaseDeclaration :: Ident -> [([Binder], Value)] -> Declaration

47+makeCaseDeclaration ident alternatives =

48+ let

49+ numArgs = length (fst . head $ alternatives)

50+ args = map (('_' :) . show) [1..numArgs]

51+ obj = ObjectLiteral $ map (\arg -> (arg, Var (Qualified global (Ident arg)))) args

52+ objBinders = [ (ObjectBinder (zip args bs), val) | (bs, val) <- alternatives ]

53+ value = foldr (\arg ret -> Abs [Ident arg] ret) (Case obj objBinders) args

54+ in

55+ ValueDeclaration ident [] value

56+

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

@@ -24,7 +24,7 @@ import Language.PureScript.Pretty

24import Language.PureScript.Names

25

26externToPs :: Int -> ModulePath -> Environment -> Declaration -> Maybe String

27−externToPs indent path env (ValueDeclaration name _) = do

27+externToPs indent path env (ValueDeclaration name _ _) = do

28 (ty, _) <- M.lookup (path, name) $ names env

29 return $ replicate indent ' ' ++ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty

30externToPs indent path env (DataDeclaration name _ _) = do

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

@@ -32,10 +32,10 @@ import Language.PureScript.CodeGen.JS.AST as AST

32import Language.PureScript.TypeChecker.Monad (NameKind(..))

33

34declToJs :: Maybe Ident -> ModulePath -> Declaration -> Environment -> Maybe [JS]

35−declToJs curMod mp (ValueDeclaration ident (Abs args ret)) e =

35+declToJs curMod mp (ValueDeclaration ident _ (Abs args ret)) e =

36 Just $ JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs mp e ret)]) :

37 maybe [] (return . setProperty (identToJs ident) (JSVar ident)) curMod

38−declToJs curMod mp (ValueDeclaration ident val) e =

38+declToJs curMod mp (ValueDeclaration ident _ val) e =

39 Just $ JSVariableIntroduction ident (Just (valueToJs mp e val)) :

40 maybe [] (return . setProperty (identToJs ident) (JSVar ident)) curMod

41declToJs curMod _ (ExternMemberDeclaration member ident _) _ =

src/Language/PureScript/Declarations.hs+1−1

@@ -33,7 +33,7 @@ data Declaration

33 = DataDeclaration ProperName [String] [(ProperName, Maybe PolyType)]

34 | TypeSynonymDeclaration ProperName [String] PolyType

35 | TypeDeclaration Ident PolyType

36− | ValueDeclaration Ident Value

36+ | ValueDeclaration Ident [Binder] Value

37 | ExternDeclaration Ident PolyType

38 | ExternMemberDeclaration String Ident PolyType

39 | ExternDataDeclaration ProperName Kind

src/Language/PureScript/Parser/Declarations.hs+3−2

@@ -50,8 +50,9 @@ parseTypeSynonymDeclaration =

50

51parseValueDeclaration :: P.Parsec String ParseState Declaration

52parseValueDeclaration =

53− ValueDeclaration <$> P.try (parseIdent <* lexeme (indented *> P.char '='))

53+ ValueDeclaration <$> parseIdent

54+ <*> P.many parseBinder

54− <*> parseValue

55+ <*> ((lexeme (indented *> P.char '=')) *> parseValue)

55

56

56parseExternDeclaration :: P.Parsec String ParseState Declaration

57parseExternDeclaration :: P.Parsec String ParseState Declaration

57parseExternDeclaration = P.try (reserved "foreign") *> indented *> (reserved "import") *> indented *>

58parseExternDeclaration = P.try (reserved "foreign") *> indented *> (reserved "import") *> indented *>

src/Language/PureScript/TypeChecker.hs+4−3

@@ -63,10 +63,10 @@ typeCheckAll (TypeSynonymDeclaration name args ty : rest) = do

63 putEnv $ env { types = M.insert (modulePath, name) (kind, TypeSynonym) (types env)

64 , typeSynonyms = M.insert (modulePath, name) (args, ty) (typeSynonyms env) }

65 typeCheckAll rest

66−typeCheckAll (TypeDeclaration name ty : ValueDeclaration name' val : rest) | name == name' =

66+typeCheckAll (TypeDeclaration name ty : ValueDeclaration name' [] val : rest) | name == name' =

67− typeCheckAll (ValueDeclaration name (TypedValue val ty) : rest)

67+ typeCheckAll (ValueDeclaration name [] (TypedValue val ty) : rest)

68typeCheckAll (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name

69−typeCheckAll (ValueDeclaration name val : rest) = do

69+typeCheckAll (ValueDeclaration name [] val : rest) = do

70 rethrow (("Error in declaration " ++ show name ++ ":\n") ++) $ do

71 env <- getEnv

72 modulePath <- checkModulePath `fmap` get

@@ -76,6 +76,7 @@ typeCheckAll (ValueDeclaration name val : rest) = do

76 ty <- typeOf (Just name) val

77 putEnv (env { names = M.insert (modulePath, name) (ty, Value) (names env) })

78 typeCheckAll rest

79+typeCheckAll (ValueDeclaration _ _ _ : _) = error "Binders were not desugared"

79typeCheckAll (ExternDataDeclaration name kind : rest) = do

80typeCheckAll (ExternDataDeclaration name kind : rest) = do

80 env <- getEnv

81 env <- getEnv

81 modulePath <- checkModulePath `fmap` get

82 modulePath <- checkModulePath `fmap` get