e22e8e7 · rowtype-yoga/purescript-native

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

First attempt at top level case expressions

commite22e8e71664805a5f9b2bcf167ba52dca1f89d9d authorPhil Freeman <paf31@cantab.net> dateTue 24 Dec 2013, 20:04 (13 years ago) parentec2c5ea

10 files changed+94−35

compare with golang

unifiedsplit

examples/passing/List.purs+9−12 examples/passing/Maybe.purs+4−5 purescript.cabal+9−6 src/Language/PureScript.hs+5−3 src/Language/PureScript/CaseDeclarations.hs+56 src/Language/PureScript/CodeGen/Externs.hs+1−1 src/Language/PureScript/CodeGen/JS.hs+2−2 src/Language/PureScript/Declarations.hs+1−1 src/Language/PureScript/Parser/Declarations.hs+3−2 src/Language/PureScript/TypeChecker.hs+4−3

examples/passing/List.purs+9−12

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

55 , tail :: List a

66 }

8−isNull = \l -> case l of

9− Nil -> true

10− _ -> false

8+isNull Nil = true

9+isNull _ = false

1110

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

13− Nil -> l2

14− Cons x -> Cons

15− { head: x.head

16− , tail: concat x.tail l2

17− }

11+concat (Nil) l2 = l2

12+concat (Cons x) l2 = Cons

13+ { head: x.head

14+ , tail: concat x.tail l2

15+ }

1816

19−flatten = \xss -> case xss of

20− Nil -> Nil

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

17+flatten Nil = Nil

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

2219

examples/passing/Maybe.purs+4−5

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

11data Maybe a = Nothing | Just a

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

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

5− Nothing -> b

6− Just a -> f a

4+maybe b _ Nothing = b

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

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

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

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

9+bind m f = maybe Nothing f m

purescript.cabal+9−6

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

11name: purescript

2−version: 0.2.0

2+version: 0.2.1

33cabal-version: >=1.8

44build-type: Simple

55license: MIT

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

1515

1616library

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

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

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

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

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

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

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

19+ transformers -any, utf8-string -any

20+ exposed-modules: Data.Generics.Extras

21+ Language.PureScript Language.PureScript.CodeGen

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

23+ Language.PureScript.CodeGen.JS.AST

2324 Language.PureScript.CodeGen.Monad Language.PureScript.Declarations

2425 Language.PureScript.Kinds Language.PureScript.Names

2526 Language.PureScript.Operators Language.PureScript.Optimize

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

3637 Language.PureScript.TypeChecker.Synonyms

3738 Language.PureScript.TypeChecker.Types Language.PureScript.Types

3839 Language.PureScript.Unknown Language.PureScript.Values Main

40+ Language.PureScript.CaseDeclarations

3941 exposed: True

4042 buildable: True

4143 hs-source-dirs: src

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

4749 main-is: Main.hs

4850 buildable: True

4951 hs-source-dirs: src

52+-- other-modules:

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

5154

5255test-suite tests

src/Language/PureScript.hs+5−3

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

2525import Language.PureScript.Pretty as P

2626import Language.PureScript.Optimize as P

2727import Language.PureScript.Operators as P

28+import Language.PureScript.CaseDeclarations as P

2829

2930import Data.List (intercalate)

3031import Data.Maybe (mapMaybe)

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

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

3334compile decls = do

3435 bracketted <- rebracket decls

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

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

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

36+ desugared <- desugarCases bracketted

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

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

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

3840 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

2424import Language.PureScript.Names

2525

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

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

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

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

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

3030externToPs 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

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

3333

3434declToJs :: 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 =

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

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

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

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

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

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

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

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

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

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

3434 | TypeSynonymDeclaration ProperName [String] PolyType

3535 | TypeDeclaration Ident PolyType

36− | ValueDeclaration Ident Value

36+ | ValueDeclaration Ident [Binder] Value

3737 | ExternDeclaration Ident PolyType

3838 | ExternMemberDeclaration String Ident PolyType

3939 | ExternDataDeclaration ProperName Kind

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

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

5050

5151parseValueDeclaration :: P.Parsec String ParseState Declaration

5252parseValueDeclaration =

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

54− <*> parseValue

53+ ValueDeclaration <$> parseIdent

54+ <*> P.many parseBinder

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

5556

5657parseExternDeclaration :: P.Parsec String ParseState Declaration

5758parseExternDeclaration = 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

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

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

6565 typeCheckAll rest

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

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

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

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

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

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

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

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

7171 env <- getEnv

7272 modulePath <- checkModulePath `fmap` get

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

7676 ty <- typeOf (Just name) val

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

7878 typeCheckAll rest

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

7980typeCheckAll (ExternDataDeclaration name kind : rest) = do

8081 env <- getEnv

8182 modulePath <- checkModulePath `fmap` get