6206aed · rowtype-yoga/purescript-native

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

Better codegen for top level case expressions - make Case expressions accept multiple inputs in general.

commit6206aed855cb493446cfc95906422204d346a9f3 authorPhil Freeman <paf31@cantab.net> dateWed 25 Dec 2013, 13:01 (13 years ago) parent2caa0c9

9 files changed+56−56

compare with golang

unifiedsplit

examples/passing/TopLevelCase.purs+3 src/Language/PureScript/CaseDeclarations.hs+3−7 src/Language/PureScript/CodeGen/JS.hs+16−11 src/Language/PureScript/Declarations.hs−2 src/Language/PureScript/Parser/Declarations.hs−3 src/Language/PureScript/Parser/Values.hs+9−7 src/Language/PureScript/Pretty/Values.hs+5−4 src/Language/PureScript/TypeChecker/Types.hs+16−19 src/Language/PureScript/Values.hs+4−3

examples/passing/TopLevelCase.purs+3

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

33gcd (x, 0) = x

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

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

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 =

4848 let

4949 argPattern = map length . fst . head $ alternatives

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

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

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

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

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

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

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

5454 in

5555 ValueDeclaration ident [] Nothing value

5656

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

58−applyGuard Nothing = id

59−applyGuard (Just g) = GuardedBinder g

60−

6157toArgs :: [Int] -> [[Int]]

6258toArgs = go 1

6359 where

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

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

2020import Data.Maybe (mapMaybe)

2121import qualified Data.Map as M

2222import Control.Arrow (second)

23−import Control.Monad (forM)

23+import Control.Monad (replicateM, forM)

2424

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

2626import Language.PureScript.Values

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

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

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

7575valueToJs 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))

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

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

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

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

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

9595 delimited _ = error "Invalid argument to delimited"

9696

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

98−bindersToJs m e binders val = do

99− valName <- fresh

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

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

102− [val]

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

98+bindersToJs m e binders vals = do

99+ valNames <- replicateM (length vals) fresh

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

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

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"

103111

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

105113binderToJs _ _ _ done NullBinder = return done

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

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

153161 js <- binderToJs m e varName done binder

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

158163

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

160165statementToJs 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)

2929

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

3131

32−type Guard = Value

33−

3432data Declaration

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

3634 | TypeSynonymDeclaration ProperName [String] PolyType

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

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

5656 <*> P.optionMaybe parseGuard

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

5858

59−parseGuard :: P.Parsec String ParseState Value

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

61−

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

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

6461

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

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

1414

1515module Language.PureScript.Parser.Values (

1616 parseValue,

17+ parseGuard,

1718 parseBinder

1819) where

1920

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

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

7374

7475parseCase :: 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)

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

7778

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

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

80− <*> parseValue

81− P.<?> "case alternative"

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

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

81+ <*> P.optionMaybe parseGuard

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

83+ P.<?> "case alternative"

8284

8385parseIfThenElse :: P.Parsec String ParseState Value

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

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

263265 where

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

265267

266−parseGuardedBinder :: P.Parsec String ParseState Binder

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

268+parseGuard :: P.Parsec String ParseState Guard

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

268270

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

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

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

3838 match (Constructor name) = Just $ show name

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

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

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

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

4142 match (Var ident) = Just $ show ident

4243 match _ = Nothing

4344

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

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

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

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

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

4648

4749ifThenElse :: Pattern () Value ((Value, Value), Value)

4850ifThenElse = mkPattern match

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

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

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

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

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

162163 match _ = Nothing

163164

164165prettyPrintBinder :: Binder -> String

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

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

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

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

333333 Just ty -> replaceAllTypeSynonyms ty

334−infer' (Case val binders) = do

335− t1 <- infer val

334+infer' (Case vals binders) = do

335+ ts <- mapM infer vals

336336 ret <- fresh

337− checkBinders t1 ret binders

337+ checkBinders ts ret binders

338338 return ret

339339infer' (IfThenElse cond th el) = do

340340 check cond Boolean

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

483483inferBinder val (NamedBinder name binder) = do

484484 m <- inferBinder val binder

485485 return $ M.insert name val m

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

487486

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

496488checkBinders _ _ [] = return ()

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

498− m1 <- inferGuardedBinder nval binder

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

500− checkBinders nval ret bs

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

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

491+ bindLocalVariables (M.toList m1) $ do

492+ check val ret

493+ case grd of

494+ Nothing -> return ()

495+ Just g -> check g Boolean

496+ checkBinders nvals ret bs

501497

502498assignVariable :: Ident -> Subst ()

503499assignVariable name = do

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

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

619615 ty1 `subsumes` ty2

620616 check val ty1

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

622− t1 <- infer val

623− checkBinders t1 ret binders

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

618+ ts <- mapM infer vals

619+ checkBinders ts ret binders

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

625621 check cond Boolean

626622 check th ty

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

712708 replaced <- replaceVarWithUnknown ident ty

713709 inferFunctionApplication replaced args

714710inferFunctionApplication u@(TUnknown _) args = do

711+

715712 ret <- fresh

716713 args' <- mapM replaceAllVarsWithUnknowns args

717714 u ~~ Function args' ret

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

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

2121

2222import Data.Data

2323

24+type Guard = Value

25+

2426data UnaryOperator

2527 = Negate

2628 | Not

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

6769 | IfThenElse Value Value Value

6870 | Block [Statement]

6971 | Constructor (Qualified ProperName)

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

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

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

7274

7375data Statement

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

9799 | ObjectBinder [(String, Binder)]

98100 | ArrayBinder [Binder]

99101 | ConsBinder Binder Binder

100− | NamedBinder Ident Binder

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

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