2caa0c9 · rowtype-yoga/purescript-native

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

Allow multiple-argument functions to be defined using top level case expressions

commit2caa0c9cf38800507aae7a9c662ca9c9d0494cba authorPhil Freeman <paf31@cantab.net> dateWed 25 Dec 2013, 12:23 (13 years ago) parente22e8e7

8 files changed+53−28

compare with golang

unifiedsplit

examples/passing/TopLevelCase.purs+5 src/Language/PureScript/CaseDeclarations.hs+27−17 src/Language/PureScript/CodeGen/Externs.hs+1−1 src/Language/PureScript/CodeGen/JS.hs+2−2 src/Language/PureScript/Declarations.hs+3−1 src/Language/PureScript/Parser/Common.hs+2−2 src/Language/PureScript/Parser/Declarations.hs+9−1 src/Language/PureScript/TypeChecker.hs+4−4

examples/passing/TopLevelCase.pursnew file+5

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

1+gcd :: (Number, Number) -> Number

2+gcd (0, x) = x

3+gcd (x, 0) = x

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

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

src/Language/PureScript/CaseDeclarations.hs+27−17

@@ -27,30 +27,40 @@ desugarCases :: [Declaration] -> Either String [Declaration]

2727desugarCases = fmap join . mapM toDecls . groupBy inSameGroup

2828

2929inSameGroup :: Declaration -> Declaration -> Bool

30−inSameGroup (ValueDeclaration ident1 _ _) (ValueDeclaration ident2 _ _) = ident1 == ident2

30+inSameGroup (ValueDeclaration ident1 _ _ _) (ValueDeclaration ident2 _ _ _) = ident1 == ident2

3131inSameGroup _ _ = False

3232

3333toDecls :: [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]

34+toDecls d@[ValueDeclaration _ [] Nothing _] = return d

35+toDecls ds@(ValueDeclaration ident bs _ _ : _) = do

36+ let tuples = map toTuple ds

37+ unless (all ((== map length bs) . map length . fst) tuples) $

38+ throwError $ "Argument list lengths differ in declaration " ++ show ident

39+ return [makeCaseDeclaration ident tuples]

4040toDecls ds = return ds

4141

42−toPair :: Declaration -> ([Binder], Value)

43−toPair (ValueDeclaration _ bs val) = (bs, val)

44−toPair _ = error "Not a value declaration"

42+toTuple :: Declaration -> ([[Binder]], (Maybe Guard, Value))

43+toTuple (ValueDeclaration _ bs g val) = (bs, (g, val))

44+toTuple _ = error "Not a value declaration"

4545

46−makeCaseDeclaration :: Ident -> [([Binder], Value)] -> Declaration

46+makeCaseDeclaration :: Ident -> [([[Binder]], (Maybe Guard, Value))] -> Declaration

4747makeCaseDeclaration ident alternatives =

4848 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

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

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

5454 in

55− ValueDeclaration ident [] value

55+ ValueDeclaration ident [] Nothing value

56+

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

58+applyGuard Nothing = id

59+applyGuard (Just g) = GuardedBinder g

60+

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

62+toArgs = go 1

63+ where

64+ go _ [] = []

65+ go start (n:ns) = [start..start + n - 1] : go (start + n) ns

5666

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+3−1

@@ -29,11 +29,13 @@ 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+

3234data Declaration

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

3436 | TypeSynonymDeclaration ProperName [String] PolyType

3537 | TypeDeclaration Ident PolyType

36− | ValueDeclaration Ident [Binder] Value

38+ | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value

3739 | ExternDeclaration Ident PolyType

3840 | ExternMemberDeclaration String Ident PolyType

3941 | ExternDataDeclaration ProperName Kind

src/Language/PureScript/Parser/Common.hs+2−2

@@ -74,10 +74,10 @@ reservedNames = [ "case"

7474

7575builtInOperators :: [String]

7676builtInOperators = [ "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>"

77− , "==", "!=", "&&", "||", "&", "^", "|", "!!", "!", "." ]

77+ , "==", "!=", "&&", "||", "&", "^", "|", "!!", "!" ]

7878

7979reservedOpNames :: [String]

80−reservedOpNames = builtInOperators ++ [ "->" ]

80+reservedOpNames = builtInOperators ++ [ "->", "=", "." ]

8181

8282identStart :: P.Parsec String u Char

8383identStart = P.lower <|> P.oneOf "_$"

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

@@ -27,6 +27,7 @@ import Language.PureScript.Declarations

2727import Language.PureScript.Parser.Values

2828import Language.PureScript.Parser.Types

2929import Language.PureScript.Parser.Kinds

30+import Language.PureScript.Values

3031

3132parseDataDeclaration :: P.Parsec String ParseState Declaration

3233parseDataDeclaration = do

@@ -51,9 +52,16 @@ parseTypeSynonymDeclaration =

5152parseValueDeclaration :: P.Parsec String ParseState Declaration

5253parseValueDeclaration =

5354 ValueDeclaration <$> parseIdent

54− <*> P.many parseBinder

55+ <*> P.many parseTopLevelBinder

56+ <*> P.optionMaybe parseGuard

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

5658

59+parseGuard :: P.Parsec String ParseState Value

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

61+

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

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

64+

5765parseExternDeclaration :: P.Parsec String ParseState Declaration

5866parseExternDeclaration = P.try (reserved "foreign") *> indented *> (reserved "import") *> indented *>

5967 (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)

src/Language/PureScript/TypeChecker.hs+4−4

@@ -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' [] Nothing val : rest) | name == name' =

67+ typeCheckAll (ValueDeclaration name [] Nothing (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 [] Nothing val : rest) = do

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

7171 env <- getEnv

7272 modulePath <- checkModulePath `fmap` get

@@ -76,7 +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"

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

8080typeCheckAll (ExternDataDeclaration name kind : rest) = do

8181 env <- getEnv

8282 modulePath <- checkModulePath `fmap` get