6ab12c1 · rowtype-yoga/purescript-native

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

#92 Allow binders in function arguments

commit6ab12c169fb089008e9f33a9d357e06136ea5925 authorPhil Freeman <paf31@cantab.net> dateThu 20 Feb 2014, 20:41 (13 years ago) parente249597

12 files changed+59−32

compare with golang

unifiedsplit

examples/passing/BindersInFunctions.pursnew file+12

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

1+module Main where

3+import Prelude

4+import Arrays

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

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

251251handleCommand Reload = do

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

253253 put (PSCI defaultImports prelude [])

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

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

255255

256256-- |

257257-- The PSCI main loop.

purescript.cabal+2−1

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

11name: purescript

2−version: 0.4.1

2+version: 0.4.2

33cabal-version: >=1.8

44build-type: Custom

55license: MIT

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

1010synopsis: PureScript Programming Language Compiler

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

1212category: Language

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

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

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

1516 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

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

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

134134valueToJs 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)])

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

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 (Left arg) val) ty) | optionsPerformRuntimeTypeChecks opts = let arg' = identToJs arg in JSFunction Nothing [arg'] (JSBlock $ runtimeTypeChecks arg' ty ++ [JSReturn (valueToJs opts m e val)])

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

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

139139valueToJs _ _ _ (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

5353parseAbs :: P.Parsec String ParseState Value

5454parseAbs = do

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

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

5858 value <- parseValue

5959 return $ toFunction args value

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

199199 binder <- C.indented *> parseBinder

200200 return (name, binder)

201201

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−

215202-- |

216203-- Parse a binder

217204--

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

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

220207 where

221208 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"

222221

223222-- |

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

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

7777lam = mkPattern match

7878 where

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

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

8080 match _ = Nothing

8181

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

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

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

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

3434 where

3535 namesV :: Value -> [Ident]

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

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

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

3838 namesV _ = []

3939 namesB :: Binder -> [Ident]

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

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

2020) where

2121

2222import Data.List (groupBy)

23+import Data.Generics (mkT, everywhere)

24+

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

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

2527import Control.Monad.Error.Class

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

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

3436--

3537desugarCasesModule :: [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+

3750-- |

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

3952--

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

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

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

6679 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

6881 in

6982 ValueDeclaration ident [] Nothing value

7083

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

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

4646 go [DoNotationValue val] = return val

4747 go (DoNotationValue val : rest) = do

4848 rest' <- go rest

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

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

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

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

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

5353 rest' <- go rest

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

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

5555 go (DoNotationBind binder val : rest) = do

5656 rest' <- go rest

5757 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')]))

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

6060 go (DoNotationLet binder val : rest) = do

6161 rest' <- go rest

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

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

127127 memberNames <- mapM (memberToNameAndValue memberTypes) decls

128128 return $ ValueDeclaration entryName [] Nothing

129129 (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)]))

131131 (quantify (if null deps then

132132 function unit (TypeApp (TypeConstructor name) ty)

133133 else

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

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

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

525525 return $ TypedValue True (Accessor prop typed) field

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

527−infer' (Abs arg ret) = do

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

528528 ty <- fresh

529529 Just moduleName <- checkCurrentModule <$> get

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

531531 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"

533534infer' (App f arg) = do

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

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

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

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

729730 (qualifyAllUnqualifiedNames moduleName env constraints)) $

730731 check val ty

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

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

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

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

734735 val' <- check val ty

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

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

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

750751 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

752753 Just moduleName <- checkCurrentModule <$> get

753754 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"

755757check' (App f arg) ret = do

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

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

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

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

7272 -- |

7373 -- Function introduction

7474 --

75− | Abs Ident Value

75+ | Abs (Either Ident Binder) Value

7676 -- |

7777 -- Function application

7878 --