6ab12c1 · rowtype-yoga/purescript-native

examples/passing/BindersInFunctions.pursnew file+12

compare with golang

unifiedsplit

@@ -0,0 +1,12 @@

1+module Main where

2+

3+import Prelude

4+import Arrays

5+

6+tails = map (\(_:xs) -> xs)

7+

8+main =

9+ let ts = tails [[1, 2, 3], [4, 5], [6]] in

10+ if ts == [[2, 3], [5], []]

11+ then Trace.trace "Done"

12+ else Errors.throwError "Incorrect result from 'tails'."

psci/Main.hs+1−1

@@ -251,7 +251,7 @@ handleCommand (LoadFile filePath) = do

251handleCommand Reload = do

252 (Right prelude) <- ioToState $ getPreludeFilename >>= loadModule

253 put (PSCI defaultImports prelude [])

254−handleCommand Unknown = inputTToState $ outputStrLn "Unknown command"

254+handleCommand _ = inputTToState $ outputStrLn "Unknown command"

255

256-- |

257-- The PSCI main loop.

purescript.cabal+2−1

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

1name: purescript

2−version: 0.4.1

2+version: 0.4.2

3cabal-version: >=1.8

4build-type: Custom

5license: MIT

@@ -10,6 +10,7 @@ stability: experimental

10synopsis: PureScript Programming Language Compiler

11description: A small compile-to-JS language with extensible records and type-safe blocks

12category: Language

13+Homepage: http://www.purescript.org/

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

14author: Phil Freeman <paf31@cantab.net>,

14 Gary Burgess <gary.burgess@gmail.com>,

15 Gary Burgess <gary.burgess@gmail.com>,

15 Hardy Jones <jones3.hardy@gmail.com>

16 Hardy Jones <jones3.hardy@gmail.com>

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

@@ -132,8 +132,8 @@ valueToJs opts m e (Case values binders) = bindersToJs opts m e binders (map (va

132valueToJs opts m e (IfThenElse cond th el) = JSConditional (valueToJs opts m e cond) (valueToJs opts m e th) (valueToJs opts m e el)

133valueToJs opts m e (Accessor prop val) = JSAccessor prop (valueToJs opts m e val)

134valueToJs opts m e (App val arg) = JSApp (valueToJs opts m e val) [valueToJs opts m e arg]

135−valueToJs opts m e (Abs arg val) = JSFunction Nothing [identToJs arg] (JSBlock [JSReturn (valueToJs opts m (bindName m arg e) val)])

135+valueToJs opts m e (Abs (Left arg) val) = JSFunction Nothing [identToJs arg] (JSBlock [JSReturn (valueToJs opts m (bindName m arg e) val)])

136−valueToJs opts m e (TypedValue _ (Abs arg val) ty) | optionsPerformRuntimeTypeChecks opts = let arg' = identToJs arg in JSFunction Nothing [arg'] (JSBlock $ runtimeTypeChecks arg' ty ++ [JSReturn (valueToJs opts m e val)])

136+valueToJs opts m e (TypedValue _ (Abs (Left arg) val) ty) | optionsPerformRuntimeTypeChecks opts = let arg' = identToJs arg in JSFunction Nothing [arg'] (JSBlock $ runtimeTypeChecks arg' ty ++ [JSReturn (valueToJs opts m e val)])

137valueToJs _ m e (Var ident) = varToJs m e ident

138valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val

139valueToJs _ _ _ (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"

src/Language/PureScript/Parser/Values.hs+13−14

@@ -53,7 +53,7 @@ parseIdentifierAndValue = (,) <$> (C.indented *> C.identifier <* C.indented <* C

53parseAbs :: P.Parsec String ParseState Value

54parseAbs = do

55 C.reservedOp "\\"

56− args <- P.many1 (C.indented *> (Abs <$> C.parseIdent))

56+ args <- P.many1 (C.indented *> (Abs <$> (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens)))

57 C.indented *> C.reservedOp "->"

58 value <- parseValue

59 return $ toFunction args value

@@ -199,19 +199,6 @@ parseIdentifierAndBinder = do

199 binder <- C.indented *> parseBinder

200 return (name, binder)

201

202−parseBinderAtom :: P.Parsec String ParseState Binder

203−parseBinderAtom = P.choice (map P.try

204− [ parseNullBinder

205− , parseStringBinder

206− , parseBooleanBinder

207− , parseNumberBinder

208− , parseNamedBinder

209− , parseVarBinder

210− , parseConstructorBinder

211− , parseObjectBinder

212− , parseArrayBinder

213− , C.parens parseBinder ]) P.<?> "binder"

214−

215-- |

202-- |

216-- Parse a binder

203-- Parse a binder

217--

204--

@@ -219,6 +206,18 @@ parseBinder :: P.Parsec String ParseState Binder

219parseBinder = (buildExpressionParser operators parseBinderAtom) P.<?> "expression"

206parseBinder = (buildExpressionParser operators parseBinderAtom) P.<?> "expression"

220 where

207 where

221 operators = [ [ Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) AssocRight ] ]

208 operators = [ [ Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) AssocRight ] ]

209+ parseBinderAtom :: P.Parsec String ParseState Binder

210+ parseBinderAtom = P.choice (map P.try

211+ [ parseNullBinder

212+ , parseStringBinder

213+ , parseBooleanBinder

214+ , parseNumberBinder

215+ , parseNamedBinder

216+ , parseVarBinder

217+ , parseConstructorBinder

218+ , parseObjectBinder

219+ , parseArrayBinder

220+ , C.parens parseBinder ]) P.<?> "binder"

222

221

223-- |

222-- |

224-- Parse a binder as it would appear in a top level declaration

223-- Parse a binder as it would appear in a top level declaration

src/Language/PureScript/Pretty/Values.hs+1−1

@@ -76,7 +76,7 @@ app = mkPattern match

76lam :: Pattern () Value (String, Value)

77lam = mkPattern match

78 where

79− match (Abs arg val) = Just (show arg, val)

79+ match (Abs (Left arg) val) = Just (show arg, val)

80 match _ = Nothing

81

82typed :: Pattern () Value (Type, Value)

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

@@ -33,7 +33,7 @@ usedNames :: (Data d) => d -> [Ident]

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

34 where

35 namesV :: Value -> [Ident]

36− namesV (Abs arg _) = [arg]

36+ namesV (Abs (Left arg) _) = [arg]

37 namesV (Var (Qualified Nothing name)) = [name]

38 namesV _ = []

39 namesB :: Binder -> [Ident]

src/Language/PureScript/Sugar/CaseDeclarations.hs+15−2

@@ -20,6 +20,8 @@ module Language.PureScript.Sugar.CaseDeclarations (

20) where

21

22import Data.List (groupBy)

23+import Data.Generics (mkT, everywhere)

24+

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

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

24import Control.Monad (forM, join, unless)

26import Control.Monad (forM, join, unless)

25import Control.Monad.Error.Class

27import Control.Monad.Error.Class

@@ -33,7 +35,18 @@ import Language.PureScript.Scope

33-- Replace all top-level binders in a module with case expressions.

35-- Replace all top-level binders in a module with case expressions.

34--

36--

35desugarCasesModule :: [Module] -> Either String [Module]

37desugarCasesModule :: [Module] -> Either String [Module]

36−desugarCasesModule ms = forM ms $ \(Module name ds) -> Module name <$> desugarCases ds

38+desugarCasesModule ms = forM ms $ \(Module name ds) -> Module name <$> (desugarCases . desugarAbs $ ds)

39+

40+desugarAbs :: [Declaration] -> [Declaration]

41+desugarAbs = everywhere (mkT replace)

42+ where

43+ replace (Abs (Right binder) val) =

44+ let

45+ ident = head $ unusedNames (binder, val)

46+ in

47+ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [([binder], Nothing, val)]

48+ replace other = other

49+

37-- |

50-- |

38-- Replace all top-level binders with case expressions.

51-- Replace all top-level binders with case expressions.

39--

52--

@@ -64,7 +77,7 @@ makeCaseDeclaration ident alternatives =

64 args = take argPattern $ unusedNames (ident, alternatives)

77 args = take argPattern $ unusedNames (ident, alternatives)

65 vars = map (\arg -> Var (Qualified Nothing arg)) args

78 vars = map (\arg -> Var (Qualified Nothing arg)) args

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

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

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

80+ value = foldr (\arg ret -> Abs (Left arg) ret) (Case vars binders) args

68 in

81 in

69 ValueDeclaration ident [] Nothing value

82 ValueDeclaration ident [] Nothing value

70

83

src/Language/PureScript/Sugar/DoNotation.hs+3−3

@@ -46,16 +46,16 @@ desugarDo = everywhereM (mkM replace)

46 go [DoNotationValue val] = return val

47 go (DoNotationValue val : rest) = do

48 rest' <- go rest

49− return $ App (App bind val) (Abs (Ident "_") rest')

49+ return $ App (App bind val) (Abs (Left (Ident "_")) rest')

50 go [DoNotationBind _ _] = Left "Bind statement cannot be the last statement in a do block"

51 go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)

52 go (DoNotationBind (VarBinder ident) val : rest) = do

53 rest' <- go rest

54− return $ App (App bind val) (Abs ident rest')

54+ return $ App (App bind val) (Abs (Left ident) rest')

55 go (DoNotationBind binder val : rest) = do

56 rest' <- go rest

57 let ident = head $ unusedNames rest'

58− return $ App (App bind val) (Abs ident (Case [Var (Qualified Nothing ident)] [([binder], Nothing, rest')]))

58+ return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [([binder], Nothing, rest')]))

59 go [DoNotationLet _ _] = Left "Let statement cannot be the last statement in a do block"

60 go (DoNotationLet binder val : rest) = do

61 rest' <- go rest

src/Language/PureScript/Sugar/TypeClasses.hs+1−1

@@ -127,7 +127,7 @@ typeInstanceDictionaryDeclaration mn deps name ty decls = do

127 memberNames <- mapM (memberToNameAndValue memberTypes) decls

128 return $ ValueDeclaration entryName [] Nothing

129 (TypedValue True

130− (foldr Abs (ObjectLiteral memberNames) (map (\n -> Ident ('_' : show n)) [1..max 1 (length deps)]))

130+ (foldr Abs (ObjectLiteral memberNames) (map (\n -> Left . Ident $ '_' : show n) [1..max 1 (length deps)]))

131 (quantify (if null deps then

132 function unit (TypeApp (TypeConstructor name) ty)

133 else

src/Language/PureScript/TypeChecker/Types.hs+7−5

@@ -524,12 +524,13 @@ infer' (Accessor prop val) = do

524 _ <- subsumes Nothing objTy (Object (RCons prop field rest))

525 return $ TypedValue True (Accessor prop typed) field

526 Just ty -> return $ TypedValue True (Accessor prop typed) ty

527−infer' (Abs arg ret) = do

527+infer' (Abs (Left arg) ret) = do

528 ty <- fresh

529 Just moduleName <- checkCurrentModule <$> get

530 bindLocalVariables moduleName [(arg, ty)] $ do

531 body@(TypedValue _ _ bodyTy) <- infer' ret

532− return $ TypedValue True (Abs arg body) $ function ty bodyTy

532+ return $ TypedValue True (Abs (Left arg) body) $ function ty bodyTy

533+infer' (Abs (Right _) _) = error "Binder was not desugared"

533infer' (App f arg) = do

534infer' (App f arg) = do

534 f'@(TypedValue _ _ ft) <- infer f

535 f'@(TypedValue _ _ ft) <- infer f

535 (ret, app) <- checkFunctionApplication f' ft arg

536 (ret, app) <- checkFunctionApplication f' ft arg

@@ -728,7 +729,7 @@ check' val t@(ConstrainedType constraints ty) = do

728 TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames)

729 TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames)

729 (qualifyAllUnqualifiedNames moduleName env constraints)) $

730 (qualifyAllUnqualifiedNames moduleName env constraints)) $

730 check val ty

731 check val ty

731− return $ TypedValue True (foldr Abs val' dictNames) t

732+ return $ TypedValue True (foldr Abs val' (map Left dictNames)) t

732check' val t@(SaturatedTypeSynonym name args) = do

733check' val t@(SaturatedTypeSynonym name args) = do

733 ty <- introduceSkolemScope <=< expandTypeSynonym name $ args

734 ty <- introduceSkolemScope <=< expandTypeSynonym name $ args

734 val' <- check val ty

735 val' <- check val ty

@@ -748,10 +749,11 @@ check' v@(BooleanLiteral _) t | t == tyBoolean =

748check' (ArrayLiteral vals) t@(TypeApp a ty) | a == tyArray = do

749check' (ArrayLiteral vals) t@(TypeApp a ty) | a == tyArray = do

749 arr <- ArrayLiteral <$> forM vals (\val -> check val ty)

750 arr <- ArrayLiteral <$> forM vals (\val -> check val ty)

750 return $ TypedValue True arr t

751 return $ TypedValue True arr t

751−check' (Abs arg ret) ty@(TypeApp (TypeApp t argTy) retTy) | t == tyFunction = do

752+check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) | t == tyFunction = do

752 Just moduleName <- checkCurrentModule <$> get

753 Just moduleName <- checkCurrentModule <$> get

753 ret' <- bindLocalVariables moduleName [(arg, argTy)] $ check ret retTy

754 ret' <- bindLocalVariables moduleName [(arg, argTy)] $ check ret retTy

754− return $ TypedValue True (Abs arg ret') ty

755+ return $ TypedValue True (Abs (Left arg) ret') ty

756+check' (Abs (Right _) _) _ = error "Binder was not desugared"

755check' (App f arg) ret = do

757check' (App f arg) ret = do

756 f'@(TypedValue _ _ ft) <- infer f

758 f'@(TypedValue _ _ ft) <- infer f

757 (ret', app) <- checkFunctionApplication f' ft arg

759 (ret', app) <- checkFunctionApplication f' ft arg

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

@@ -72,7 +72,7 @@ data Value

72 -- |

73 -- Function introduction

74 --

75− | Abs Ident Value

75+ | Abs (Either Ident Binder) Value

76 -- |

77 -- Function application

78 --