6206aed · rowtype-yoga/purescript-native

examples/passing/TopLevelCase.purs+3

compare with golang

unifiedsplit

@@ -3,3 +3,6 @@ gcd (0, x) = x

3gcd (x, 0) = x

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

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

6+

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

8+guardsTest xs = xs

src/Language/PureScript/CaseDeclarations.hs+3−7

@@ -48,16 +48,12 @@ makeCaseDeclaration ident alternatives =

48 let

49 argPattern = map length . fst . head $ alternatives

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

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

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

52− objBinders = [ (applyGuard g $ ObjectBinder (join $ zipWith zip args bs), val) | (bs, (g, val)) <- alternatives ]

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

53− value = foldr (\args' ret -> Abs (map Ident args') ret) (Case obj objBinders) args

53+ value = foldr (\args' ret -> Abs (map Ident args') ret) (Case vars binders) args

54 in

55 ValueDeclaration ident [] Nothing value

56

57−applyGuard :: Maybe Guard -> Binder -> Binder

58−applyGuard Nothing = id

59−applyGuard (Just g) = GuardedBinder g

60−

61toArgs :: [Int] -> [[Int]]

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

62toArgs = go 1

58toArgs = go 1

63 where

59 where

src/Language/PureScript/CodeGen/JS.hs+16−11

@@ -20,7 +20,7 @@ module Language.PureScript.CodeGen.JS (

20import Data.Maybe (mapMaybe)

21import qualified Data.Map as M

22import Control.Arrow (second)

23−import Control.Monad (forM)

23+import Control.Monad (replicateM, forM)

24

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

26import Language.PureScript.Values

@@ -73,7 +73,7 @@ valueToJs m e (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs m e))

73valueToJs m e (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar (Ident "Object"))) [ valueToJs m e o, JSObjectLiteral (map (second (valueToJs m e)) ps)]

74valueToJs _ _ (Constructor name) = qualifiedToJS runProperName name

75valueToJs m e (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map (statementToJs m e) sts))) []

76−valueToJs m e (Case value binders) = runGen (bindersToJs m e binders (valueToJs m e value))

76+valueToJs m e (Case values binders) = runGen (bindersToJs m e binders (map (valueToJs m e) values))

77valueToJs m e (IfThenElse cond th el) = JSConditional (valueToJs m e cond) (valueToJs m e th) (valueToJs m e el)

78valueToJs m e (Accessor prop val) = JSAccessor prop (valueToJs m e val)

79valueToJs m e (Indexer index val) = JSIndexer (valueToJs m e index) (valueToJs m e val)

@@ -94,12 +94,20 @@ qualifiedToJS f (Qualified (ModulePath parts) a) =

94 delimited (part:parts') = JSAccessor part (delimited parts')

95 delimited _ = error "Invalid argument to delimited"

96

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

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

98−bindersToJs m e binders val = do

98+bindersToJs m e binders vals = do

99− valName <- fresh

99+ valNames <- replicateM (length vals) fresh

100− jss <- forM binders $ \(binder, result) -> binderToJs m e valName [JSReturn (valueToJs m e result)] binder

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

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

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

102− [val]

102+ vals

103+ where

104+ go :: [String] -> [JS] -> [Binder] -> Maybe Guard -> Gen [JS]

105+ go _ done [] Nothing = return done

106+ go _ done [] (Just cond) = return [JSIfElse (valueToJs m e cond) (JSBlock done) Nothing]

107+ go (v:vs) done' (b:bs) grd = do

108+ done'' <- go vs done' bs grd

109+ binderToJs m e v done'' b

110+ go _ _ _ _ = error "Invalid arguments to bindersToJs"

103

111

104binderToJs :: ModulePath -> Environment -> String -> [JS] -> Binder -> Gen [JS]

112binderToJs :: ModulePath -> Environment -> String -> [JS] -> Binder -> Gen [JS]

105binderToJs _ _ _ done NullBinder = return done

113binderToJs _ _ _ done NullBinder = return done

@@ -152,9 +160,6 @@ binderToJs m e varName done (ConsBinder headBinder tailBinder) = do

152binderToJs m e varName done (NamedBinder ident binder) = do

160binderToJs m e varName done (NamedBinder ident binder) = do

153 js <- binderToJs m e varName done binder

161 js <- binderToJs m e varName done binder

154 return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : js)

162 return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : js)

155−binderToJs m e varName done (GuardedBinder cond binder) = binderToJs m e varName done' binder

156− where

157− done' = [JSIfElse (valueToJs m e cond) (JSBlock done) Nothing]

158

163

159statementToJs :: ModulePath -> Environment -> Statement -> JS

164statementToJs :: ModulePath -> Environment -> Statement -> JS

160statementToJs m e (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs m e value))

165statementToJs m e (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs m e value))

src/Language/PureScript/Declarations.hs−2

@@ -29,8 +29,6 @@ data Associativity = Infixl | Infixr deriving (Show, D.Data, D.Typeable)

29

30data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)

31

32−type Guard = Value

33−

34data Declaration

32data Declaration

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

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

36 | TypeSynonymDeclaration ProperName [String] PolyType

34 | TypeSynonymDeclaration ProperName [String] PolyType

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

@@ -56,9 +56,6 @@ parseValueDeclaration =

56 <*> P.optionMaybe parseGuard

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

58

59−parseGuard :: P.Parsec String ParseState Value

60−parseGuard = indented *> pipe *> indented *> parseValue

61−

62parseTopLevelBinder :: P.Parsec String ParseState [Binder]

59parseTopLevelBinder :: P.Parsec String ParseState [Binder]

63parseTopLevelBinder = return <$> P.try parseBinder <|> parens (commaSep parseBinder)

60parseTopLevelBinder = return <$> P.try parseBinder <|> parens (commaSep parseBinder)

64

61

src/Language/PureScript/Parser/Values.hs+9−7

@@ -14,6 +14,7 @@

14

15module Language.PureScript.Parser.Values (

16 parseValue,

17+ parseGuard,

17 parseBinder

18 parseBinder

18) where

19) where

19

20

@@ -72,13 +73,14 @@ parseConstructor :: P.Parsec String ParseState Value

72parseConstructor = Constructor <$> C.parseQualified C.properName

73parseConstructor = Constructor <$> C.parseQualified C.properName

73

74

74parseCase :: P.Parsec String ParseState Value

75parseCase :: P.Parsec String ParseState Value

75−parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") parseValue

76+parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") (return <$> parseValue)

76 <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))

77 <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))

77

78

78−parseCaseAlternative :: P.Parsec String ParseState (Binder, Value)

79+parseCaseAlternative :: P.Parsec String ParseState ([Binder], Maybe Guard, Value)

79−parseCaseAlternative = (,) <$> (parseGuardedBinder <* C.lexeme (P.string "->"))

80+parseCaseAlternative = (,,) <$> (return <$> parseBinder)

81+ <*> P.optionMaybe parseGuard

80− <*> parseValue

82+ <*> (C.lexeme (P.string "->") *> parseValue)

81− P.<?> "case alternative"

83+ P.<?> "case alternative"

82

84

83parseIfThenElse :: P.Parsec String ParseState Value

85parseIfThenElse :: P.Parsec String ParseState Value

84parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parseValue)

86parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parseValue)

@@ -263,6 +265,6 @@ parseBinder = (buildExpressionParser operators parseBinderAtom) P.<?> "expressio

263 where

265 where

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

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

265

267

266−parseGuardedBinder :: P.Parsec String ParseState Binder

268+parseGuard :: P.Parsec String ParseState Guard

267−parseGuardedBinder = flip ($) <$> parseBinder <*> P.option id (GuardedBinder <$> (C.indented *> C.lexeme (P.char '|') *> C.indented *> parseValue))

269+parseGuard = C.indented *> C.pipe *> C.indented *> parseValue

268

270

src/Language/PureScript/Pretty/Values.hs+5−4

@@ -37,12 +37,14 @@ literals = mkPattern match

37 match (ObjectLiteral ps) = Just $ "{" ++ intercalate ", " (map (uncurry prettyPrintObjectProperty) ps) ++ "}"

38 match (Constructor name) = Just $ show name

39 match (Block sts) = Just $ "do { " ++ intercalate " ; " (map prettyPrintStatement sts) ++ " }"

40+ match (Case values binders) = Just $ "case " ++ intercalate " " (map prettyPrintValue values) ++

40− match (Case value binders) = Just $ "case " ++ prettyPrintValue value ++ " of { " ++ intercalate " ; " (map (uncurry prettyPrintCaseAlternative) binders) ++ " }"

41+ " of { " ++ intercalate " ; " (map prettyPrintCaseAlternative binders) ++ " }"

41 match (Var ident) = Just $ show ident

42 match (Var ident) = Just $ show ident

42 match _ = Nothing

43 match _ = Nothing

43

44

44−prettyPrintCaseAlternative :: Binder -> Value -> String

45+prettyPrintCaseAlternative :: ([Binder], Maybe Guard, Value) -> String

45−prettyPrintCaseAlternative binder val = prettyPrintBinder binder ++ " -> " ++ prettyPrintValue val

46+prettyPrintCaseAlternative (binders, grd, val) = "(" ++ intercalate ", " (map prettyPrintBinder binders) ++ ") " ++

47+ (maybe "" (("| " ++) . prettyPrintValue) grd) ++ " -> " ++ prettyPrintValue val

46

48

47ifThenElse :: Pattern () Value ((Value, Value), Value)

49ifThenElse :: Pattern () Value ((Value, Value), Value)

48ifThenElse = mkPattern match

50ifThenElse = mkPattern match

@@ -158,7 +160,6 @@ prettyPrintBinderAtom = mkPattern match

158 match (ObjectBinder bs) = Just $ "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }"

160 match (ObjectBinder bs) = Just $ "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }"

159 match (ArrayBinder bs) = Just $ "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ " ]"

161 match (ArrayBinder bs) = Just $ "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ " ]"

160 match (NamedBinder ident binder) = Just $ show ident ++ "@" ++ prettyPrintBinder binder

162 match (NamedBinder ident binder) = Just $ show ident ++ "@" ++ prettyPrintBinder binder

161− match (GuardedBinder cond binder) = Just $ prettyPrintBinder binder ++ " | " ++ prettyPrintValue cond

162 match _ = Nothing

163 match _ = Nothing

163

164

164prettyPrintBinder :: Binder -> String

165prettyPrintBinder :: Binder -> String

src/Language/PureScript/TypeChecker/Types.hs+16−19

@@ -331,10 +331,10 @@ infer' (Constructor c) = do

331 case M.lookup (qualify modulePath c) (dataConstructors env) of

332 Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"

333 Just ty -> replaceAllTypeSynonyms ty

334−infer' (Case val binders) = do

334+infer' (Case vals binders) = do

335− t1 <- infer val

335+ ts <- mapM infer vals

336 ret <- fresh

337− checkBinders t1 ret binders

337+ checkBinders ts ret binders

338 return ret

339infer' (IfThenElse cond th el) = do

340 check cond Boolean

@@ -483,21 +483,17 @@ inferBinder val (ConsBinder headBinder tailBinder) = do

483inferBinder val (NamedBinder name binder) = do

484 m <- inferBinder val binder

485 return $ M.insert name val m

486−inferBinder _ _ = error "Invalid argument to inferBinder"

487

486

488−inferGuardedBinder :: Type -> Binder -> Subst (M.Map Ident Type)

489−inferGuardedBinder val (GuardedBinder cond binder) = do

490− m1 <- inferBinder val binder

491− bindLocalVariables (M.toList m1) $ check cond Boolean

492− return m1

493−inferGuardedBinder val b = inferBinder val b

494−

495−checkBinders :: Type -> Type -> [(Binder, Value)] -> Subst ()

487+checkBinders :: [Type] -> Type -> [([Binder], Maybe Guard, Value)] -> Subst ()

496checkBinders _ _ [] = return ()

488checkBinders _ _ [] = return ()

497−checkBinders nval ret ((binder, val):bs) = do

489+checkBinders nvals ret ((binders, grd, val):bs) = do

498− m1 <- inferGuardedBinder nval binder

490+ m1 <- M.unions <$> zipWithM inferBinder nvals binders

499− bindLocalVariables (M.toList m1) $ check val ret

491+ bindLocalVariables (M.toList m1) $ do

492+ check val ret

493+ case grd of

494+ Nothing -> return ()

495+ Just g -> check g Boolean

500− checkBinders nval ret bs

496+ checkBinders nvals ret bs

501

497

502assignVariable :: Ident -> Subst ()

498assignVariable :: Ident -> Subst ()

503assignVariable name = do

499assignVariable name = do

@@ -618,9 +614,9 @@ check' (TypedValue val ty1) ty2 = do

618 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

614 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

619 ty1 `subsumes` ty2

615 ty1 `subsumes` ty2

620 check val ty1

616 check val ty1

621−check' (Case val binders) ret = do

617+check' (Case vals binders) ret = do

622− t1 <- infer val

618+ ts <- mapM infer vals

623− checkBinders t1 ret binders

619+ checkBinders ts ret binders

624check' (IfThenElse cond th el) ty = do

620check' (IfThenElse cond th el) ty = do

625 check cond Boolean

621 check cond Boolean

626 check th ty

622 check th ty

@@ -712,6 +708,7 @@ inferFunctionApplication (ForAll ident ty) args = do

712 replaced <- replaceVarWithUnknown ident ty

708 replaced <- replaceVarWithUnknown ident ty

713 inferFunctionApplication replaced args

709 inferFunctionApplication replaced args

714inferFunctionApplication u@(TUnknown _) args = do

710inferFunctionApplication u@(TUnknown _) args = do

711+

715 ret <- fresh

712 ret <- fresh

716 args' <- mapM replaceAllVarsWithUnknowns args

713 args' <- mapM replaceAllVarsWithUnknowns args

717 u ~~ Function args' ret

714 u ~~ Function args' ret

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

@@ -21,6 +21,8 @@ import Language.PureScript.Names

21

22import Data.Data

23

24+type Guard = Value

25+

24data UnaryOperator

26data UnaryOperator

25 = Negate

27 = Negate

26 | Not

28 | Not

@@ -67,7 +69,7 @@ data Value

67 | IfThenElse Value Value Value

69 | IfThenElse Value Value Value

68 | Block [Statement]

70 | Block [Statement]

69 | Constructor (Qualified ProperName)

71 | Constructor (Qualified ProperName)

70− | Case Value [(Binder, Value)]

72+ | Case [Value] [([Binder], Maybe Guard, Value)]

71 | TypedValue Value PolyType deriving (Show, Data, Typeable)

73 | TypedValue Value PolyType deriving (Show, Data, Typeable)

72

74

73data Statement

75data Statement

@@ -97,5 +99,4 @@ data Binder

97 | ObjectBinder [(String, Binder)]

99 | ObjectBinder [(String, Binder)]

98 | ArrayBinder [Binder]

100 | ArrayBinder [Binder]

99 | ConsBinder Binder Binder

101 | ConsBinder Binder Binder

100− | NamedBinder Ident Binder

102+ | NamedBinder Ident Binder deriving (Show, Data, Typeable)

101− | GuardedBinder Value Binder deriving (Show, Data, Typeable)