2caa0c9 · rowtype-yoga/purescript-native

examples/passing/TopLevelCase.pursnew file+5

compare with golang

unifiedsplit

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

27desugarCases = fmap join . mapM toDecls . groupBy inSameGroup

28

29inSameGroup :: Declaration -> Declaration -> Bool

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

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

31inSameGroup _ _ = False

32

33toDecls :: [Declaration] -> Either String [Declaration]

34−toDecls d@[ValueDeclaration _ [] _] = return d

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

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

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

36− let pairs = map toPair ds

36+ let tuples = map toTuple ds

37− unless (all ((== length bs) . length . fst) pairs) $

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

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

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

39− return [makeCaseDeclaration ident pairs]

39+ return [makeCaseDeclaration ident tuples]

40toDecls ds = return ds

41

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

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

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

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

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

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

45

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

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

47makeCaseDeclaration ident alternatives =

48 let

49− numArgs = length (fst . head $ alternatives)

49+ argPattern = map length . fst . head $ alternatives

50− args = map (('_' :) . show) [1..numArgs]

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

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

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

52− objBinders = [ (ObjectBinder (zip args bs), val) | (bs, val) <- alternatives ]

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

53− value = foldr (\arg ret -> Abs [Ident arg] ret) (Case obj objBinders) args

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

54 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

56

66

src/Language/PureScript/CodeGen/Externs.hs+1−1

@@ -24,7 +24,7 @@ import Language.PureScript.Pretty

24import Language.PureScript.Names

25

26externToPs :: Int -> ModulePath -> Environment -> Declaration -> Maybe String

27−externToPs indent path env (ValueDeclaration name _ _) = do

27+externToPs indent path env (ValueDeclaration name _ _ _) = do

28 (ty, _) <- M.lookup (path, name) $ names env

29 return $ replicate indent ' ' ++ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty

30externToPs 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

32import Language.PureScript.TypeChecker.Monad (NameKind(..))

33

34declToJs :: 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 =

36 Just $ JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs mp e ret)]) :

37 maybe [] (return . setProperty (identToJs ident) (JSVar ident)) curMod

38−declToJs curMod mp (ValueDeclaration ident _ val) e =

38+declToJs curMod mp (ValueDeclaration ident _ _ val) e =

39 Just $ JSVariableIntroduction ident (Just (valueToJs mp e val)) :

40 maybe [] (return . setProperty (identToJs ident) (JSVar ident)) curMod

41declToJs 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)

29

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

31

32+type Guard = Value

33+

32data Declaration

34data Declaration

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

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

34 | TypeSynonymDeclaration ProperName [String] PolyType

36 | TypeSynonymDeclaration ProperName [String] PolyType

35 | TypeDeclaration Ident PolyType

37 | TypeDeclaration Ident PolyType

36− | ValueDeclaration Ident [Binder] Value

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

37 | ExternDeclaration Ident PolyType

39 | ExternDeclaration Ident PolyType

38 | ExternMemberDeclaration String Ident PolyType

40 | ExternMemberDeclaration String Ident PolyType

39 | ExternDataDeclaration ProperName Kind

41 | ExternDataDeclaration ProperName Kind

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

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

74

75builtInOperators :: [String]

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

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

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

78

79reservedOpNames :: [String]

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

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

81

82identStart :: P.Parsec String u Char

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

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

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

27import Language.PureScript.Parser.Values

28import Language.PureScript.Parser.Types

29import Language.PureScript.Parser.Kinds

30+import Language.PureScript.Values

30

31

31parseDataDeclaration :: P.Parsec String ParseState Declaration

32parseDataDeclaration :: P.Parsec String ParseState Declaration

32parseDataDeclaration = do

33parseDataDeclaration = do

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

51parseValueDeclaration :: P.Parsec String ParseState Declaration

52parseValueDeclaration :: P.Parsec String ParseState Declaration

52parseValueDeclaration =

53parseValueDeclaration =

53 ValueDeclaration <$> parseIdent

54 ValueDeclaration <$> parseIdent

54− <*> P.many parseBinder

55+ <*> P.many parseTopLevelBinder

56+ <*> P.optionMaybe parseGuard

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

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

56

58

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+

57parseExternDeclaration :: P.Parsec String ParseState Declaration

65parseExternDeclaration :: P.Parsec String ParseState Declaration

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

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

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

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

63 putEnv $ env { types = M.insert (modulePath, name) (kind, TypeSynonym) (types env)

64 , typeSynonyms = M.insert (modulePath, name) (args, ty) (typeSynonyms env) }

65 typeCheckAll rest

66−typeCheckAll (TypeDeclaration name ty : ValueDeclaration name' [] val : rest) | name == name' =

66+typeCheckAll (TypeDeclaration name ty : ValueDeclaration name' [] Nothing val : rest) | name == name' =

67− typeCheckAll (ValueDeclaration name [] (TypedValue val ty) : rest)

67+ typeCheckAll (ValueDeclaration name [] Nothing (TypedValue val ty) : rest)

68typeCheckAll (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name

69−typeCheckAll (ValueDeclaration name [] val : rest) = do

69+typeCheckAll (ValueDeclaration name [] Nothing val : rest) = do

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

71 env <- getEnv

72 modulePath <- checkModulePath `fmap` get

@@ -76,7 +76,7 @@ typeCheckAll (ValueDeclaration name [] val : rest) = do

76 ty <- typeOf (Just name) val

77 putEnv (env { names = M.insert (modulePath, name) (ty, Value) (names env) })

78 typeCheckAll rest

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

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

80typeCheckAll (ExternDataDeclaration name kind : rest) = do

81 env <- getEnv

82 modulePath <- checkModulePath `fmap` get