997c4ee · rowtype-yoga/purescript-native

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

on golang help sign in

#188 Support for multiple data constructor arguments

997c4eePhil Freeman13 years ago

docgen/Main.hs+2−2

compare with golang

unifiedsplit

@@ -92,8 +92,8 @@ renderDeclaration n (P.ExternDeclaration _ ident _ ty) =

92renderDeclaration n (P.DataDeclaration name args ctors) = do

93 let typeName = P.runProperName name ++ " " ++ intercalate " " args

94 atIndent n $ "data " ++ typeName ++ " where"

95− forM_ ctors $ \(ctor, ty) -> do

95+ forM_ ctors $ \(ctor, tys) -> do

96− atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ maybe "" ((++ " -> ") . P.prettyPrintType) ty ++ typeName

96+ atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ concat (map (\ty -> P.prettyPrintType ty ++ " -> ") tys) ++ typeName

97renderDeclaration n (P.ExternDataDeclaration name kind) =

98 atIndent n $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind

99renderDeclaration n (P.TypeSynonymDeclaration name args ty) = do

docs/source/prelude.rst+1−3

@@ -413,7 +413,7 @@ Types

413::

414

415 data Tuple a b where

416− Tuple :: { snd :: b, fst :: a } -> Tuple a b

416+ Tuple :: a -> b -> Tuple a b

417

418Type Classes

419~~~~~~~~~~~~

@@ -432,8 +432,6 @@ Values

432

433 curry :: forall c. forall b. forall a. (Tuple a b -> c) -> a -> b -> c

434

435− tuple :: forall b. forall a. a -> b -> Tuple a b

436−

437 uncurry :: forall c. forall b. forall a. (a -> b -> c) -> Tuple a b -> c

435 uncurry :: forall c. forall b. forall a. (a -> b -> c) -> Tuple a b -> c

438

436

439 unzip :: forall b. forall a. [Tuple a b] -> Tuple [a] [b]

437 unzip :: forall b. forall a. [Tuple a b] -> Tuple [a] [b]

examples/failing/KindError.purs+1−1

@@ -1,3 +1,3 @@

1module KindError where

3− data KindError f a = One f | Two f a

3+ data KindError f a = One f | Two (f a)

examples/passing/MultipleConstructorArgs.pursnew file+14

@@ -0,0 +1,14 @@

1+module MultipleConstructorArgs where

3+data P a b = P a b

5+runP :: forall a b r. (a -> b -> r) -> P a b -> r

6+runP f (P a b) = f a b

8+module Main where

10+import Prelude

11+import MultipleConstructorArgs

12+import Global

13+

14+main = Trace.trace (runP (\s n -> s ++ show n) (P "Test" 1))

prelude/README.md+1−3

@@ -369,7 +369,7 @@

369### Types

370

371 data Tuple a b where

372− Tuple :: { snd :: b, fst :: a } -> Tuple a b

372+ Tuple :: a -> b -> Tuple a b

373

374

375### Type Classes

@@ -384,8 +384,6 @@

384

385 curry :: forall c. forall b. forall a. (Tuple a b -> c) -> a -> b -> c

386

387− tuple :: forall b. forall a. a -> b -> Tuple a b

388−

389 uncurry :: forall c. forall b. forall a. (a -> b -> c) -> Tuple a b -> c

387 uncurry :: forall c. forall b. forall a. (a -> b -> c) -> Tuple a b -> c

390

388

391 unzip :: forall b. forall a. [Tuple a b] -> Tuple [a] [b]

389 unzip :: forall b. forall a. [Tuple a b] -> Tuple [a] [b]

prelude/prelude.purs+44−47

@@ -516,8 +516,8 @@ module Arrays where

516 foldl _ b [] = b

517 foldl f b (a:as) = foldl f (f a b) as

518

519− foreign import length "function length(xs) { \

519+ foreign import length "function length(xs) {\

520− \ return xs.length; \

520+ \ return xs.length;\

521 \}" :: forall a. [a] -> Number

522

523 foreign import indexOf "function indexOf(l) {\

@@ -584,7 +584,7 @@ module Arrays where

584

585 foreign import splice "function splice(s) {\

586 \ return function(e) {\

587− \ return function(l1) { \

587+ \ return function(l1) {\

588 \ return function(l2) {\

589 \ return l2.splice(s, e, l1);\

590 \ }; \

@@ -654,27 +654,24 @@ module Tuples where

654 import Prelude

655 import Arrays

656

657− data Tuple a b = Tuple { fst :: a, snd :: b }

657+ data Tuple a b = Tuple a b

658

659 instance (Prelude.Show a, Prelude.Show b) => Prelude.Show (Tuple a b) where

660− show (Tuple { fst = a, snd = b }) = "Tuple(" ++ show a ++ ", " ++ show b ++ ")"

660+ show (Tuple a b) = "Tuple(" ++ show a ++ ", " ++ show b ++ ")"

661

662 curry :: forall a b c. (Tuple a b -> c) -> a -> b -> c

663− curry f a b = f (tuple a b)

663+ curry f a b = f (Tuple a b)

664

665 uncurry :: forall a b c. (a -> b -> c) -> Tuple a b -> c

666− uncurry f (Tuple t) = f t.fst t.snd

666+ uncurry f (Tuple a b) = f a b

667−

668− tuple :: forall a b. a -> b -> Tuple a b

669− tuple a b = Tuple { fst: a, snd: b }

670

667

671 zip :: forall a b. [a] -> [b] -> [Tuple a b]

668 zip :: forall a b. [a] -> [b] -> [Tuple a b]

672− zip = zipWith tuple

669+ zip = zipWith Tuple

673

670

674 unzip :: forall a b. [Tuple a b] -> Tuple [a] [b]

671 unzip :: forall a b. [Tuple a b] -> Tuple [a] [b]

675− unzip ((Tuple t):ts) = case unzip ts of

672+ unzip ((Tuple a b):ts) = case unzip ts of

676− Tuple { fst = as, snd = bs } -> tuple (t.fst : as) (t.snd : bs)

673+ Tuple as bs -> Tuple (a : as) (b : bs)

677− unzip [] = tuple [] []

674+ unzip [] = Tuple [] []

678

675

679module String where

676module String where

680

677

@@ -701,7 +698,7 @@ module String where

701 \}" :: String -> String -> Number

698 \}" :: String -> String -> Number

702

699

703 foreign import localeCompare "function localeCompare(s1) {\

700 foreign import localeCompare "function localeCompare(s1) {\

704− \ return function(s2) { \

701+ \ return function(s2) {\

705 \ return s1.localeCompare(s2);\

702 \ return s1.localeCompare(s2);\

706 \ };\

703 \ };\

707 \}" :: String -> String -> Number

704 \}" :: String -> String -> Number

@@ -767,7 +764,7 @@ module Regex where

767 \}" :: String -> String -> Regex

764 \}" :: String -> String -> Regex

768

765

769 foreign import test "function test(r) {\

766 foreign import test "function test(r) {\

770− \ return function (s) { \

767+ \ return function (s) {\

771 \ return r.test(s);\

768 \ return r.test(s);\

772 \ };\

769 \ };\

773 \}" :: Regex -> String -> Boolean

770 \}" :: Regex -> String -> Boolean

@@ -780,7 +777,7 @@ module Regex where

780

777

781 foreign import replaceR "function replaceR(r) {\

778 foreign import replaceR "function replaceR(r) {\

782 \ return function(s1) {\

779 \ return function(s1) {\

783− \ return function(s2) { \

780+ \ return function(s2) {\

784 \ return s2.replace(r, s1);\

781 \ return s2.replace(r, s1);\

785 \ };\

782 \ };\

786 \ };\

783 \ };\

@@ -906,24 +903,24 @@ module Eff where

906

903

907 foreign import data Eff :: # ! -> * -> *

904 foreign import data Eff :: # ! -> * -> *

908

905

909− foreign import retEff "function retEff(a) { \

906+ foreign import retEff "function retEff(a) {\

910− \ return function() { \

907+ \ return function() {\

911− \ return a; \

908+ \ return a;\

912− \ }; \

909+ \ };\

913 \}" :: forall e a. a -> Eff e a

910 \}" :: forall e a. a -> Eff e a

914

911

915− foreign import bindEff "function bindEff(a) { \

912+ foreign import bindEff "function bindEff(a) {\

916− \ return function(f) { \

913+ \ return function(f) {\

917− \ return function() { \

914+ \ return function() {\

918− \ return f(a())(); \

915+ \ return f(a())();\

919− \ }; \

916+ \ };\

920− \ }; \

917+ \ };\

921 \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b

918 \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b

922

919

923 type Pure a = forall e. Eff e a

920 type Pure a = forall e. Eff e a

924

921

925− foreign import runPure "function runPure(f) { \

922+ foreign import runPure "function runPure(f) {\

926− \ return f(); \

923+ \ return f();\

927 \}" :: forall a. Pure a -> a

924 \}" :: forall a. Pure a -> a

928

925

929 instance Prelude.Monad (Eff e) where

926 instance Prelude.Monad (Eff e) where

@@ -986,22 +983,22 @@ module Errors where

986

983

987 foreign import data Error :: * -> !

984 foreign import data Error :: * -> !

988

985

989− foreign import throwError "function throwError(e) { \

986+ foreign import throwError "function throwError(e) {\

990− \ return function() { \

987+ \ return function() {\

991− \ throw e; \

988+ \ throw e;\

992− \ }; \

989+ \ };\

993 \}" :: forall a e r. e -> Eff (err :: Error e | r) a

990 \}" :: forall a e r. e -> Eff (err :: Error e | r) a

994

991

995− foreign import catchError "function catchError(c) { \

992+ foreign import catchError "function catchError(c) {\

996− \ return function(t) { \

993+ \ return function(t) {\

997− \ return function() { \

994+ \ return function() {\

998− \ try { \

995+ \ try {\

999− \ return t(); \

996+ \ return t();\

1000− \ } catch(e) { \

997+ \ } catch(e) {\

1001− \ return c(e)(); \

998+ \ return c(e)();\

1002 \ }\

999 \ }\

1003− \ }; \

1000+ \ };\

1004− \ }; \

1001+ \ };\

1005 \}" :: forall e r a. (e -> Eff r a) -> Eff (err :: Error e | r) a -> Eff r a

1002 \}" :: forall e r a. (e -> Eff r a) -> Eff (err :: Error e | r) a -> Eff r a

1006

1003

1007module IORef where

1004module IORef where

@@ -1054,11 +1051,11 @@ module Trace where

1054

1051

1055 foreign import data Trace :: !

1052 foreign import data Trace :: !

1056

1053

1057− foreign import trace "function trace(s) { \

1054+ foreign import trace "function trace(s) {\

1058− \ return function() { \

1055+ \ return function() {\

1059− \ console.log(s); \

1056+ \ console.log(s);\

1060− \ return {}; \

1057+ \ return {};\

1061− \ }; \

1058+ \ };\

1062 \}" :: forall r. String -> Eff (trace :: Trace | r) {}

1059 \}" :: forall r. String -> Eff (trace :: Trace | r) {}

1063

1060

1064 print :: forall a r. (Prelude.Show a) => a -> Eff (trace :: Trace | r) {}

1061 print :: forall a r. (Prelude.Show a) => a -> Eff (trace :: Trace | r) {}

src/Language/PureScript/CodeGen/JS.hs+20−22

@@ -74,16 +74,14 @@ declToJs opts mp (BindingGroupDeclaration vals) e =

74 : setProperty ident (var ident) mp

75 ) vals

76declToJs _ mp (DataDeclaration _ _ ctors) _ =

77− Just $ flip concatMap ctors $ \(pn@(ProperName ctor), maybeTy) ->

77+ Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->

78− let

78+ JSVariableIntroduction ctor (Just (go pn 0 tys [])) : setProperty (Escaped ctor) (JSVar ctor) mp

79− ctorJs =

79+ where

80− case maybeTy of

80+ go pn _ [] values =

81− Nothing -> JSVariableIntroduction ctor (Just (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn))) ]))

81+ JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn))), ("values", JSArrayLiteral $ reverse values) ]

82+ go pn index (_ : tys') values =

82− Just _ -> JSFunction (Just ctor) ["value"]

83+ JSFunction Nothing ["value" ++ show index]

83− (JSBlock [JSReturn

84+ (JSBlock [JSReturn (go pn (index + 1) tys' (JSVar ("value" ++ show index) : values))])

84− (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn)))

85− , ("value", JSVar "value") ])])

86− in ctorJs : setProperty (Escaped ctor) (JSVar ctor) mp

87declToJs opts mp (DataBindingGroupDeclaration ds) e =

85declToJs opts mp (DataBindingGroupDeclaration ds) e =

88 Just $ concat $ mapMaybe (flip (declToJs opts mp) e) ds

86 Just $ concat $ mapMaybe (flip (declToJs opts mp) e) ds

89declToJs _ mp (ExternDeclaration importTy ident (Just js) _) _ =

87declToJs _ mp (ExternDeclaration importTy ident (Just js) _) _ =

@@ -263,23 +261,23 @@ binderToJs _ _ varName done (BooleanBinder False) =

263 return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]

261 return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]

264binderToJs m e varName done (VarBinder ident) =

262binderToJs m e varName done (VarBinder ident) =

265 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)

263 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)

266−binderToJs m e varName done (NullaryBinder ctor) =

264+binderToJs m e varName done (ConstructorBinder ctor bs) = do

265+ js <- go 0 done bs

267 if isOnlyConstructor m e ctor

266 if isOnlyConstructor m e ctor

268 then

267 then

269− return done

268+ return js

270− else

271− return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ canonicalizeDataConstructor m e ctor)))) (JSBlock done) Nothing]

272−binderToJs m e varName done (UnaryBinder ctor b) = do

273− value <- fresh

274− js <- binderToJs m e value done b

275− let success = JSBlock (JSVariableIntroduction value (Just (JSAccessor "value" (JSVar varName))) : js)

276− if isOnlyConstructor m e ctor

277− then

278− return [success]

279 else

269 else

280 return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ canonicalizeDataConstructor m e ctor))))

270 return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ canonicalizeDataConstructor m e ctor))))

281− success

271+ (JSBlock js)

282 Nothing]

272 Nothing]

273+ where

274+ go :: Integer -> [JS] -> [Binder] -> Gen [JS]

275+ go _ done' [] = return done'

276+ go index done' (binder:bs') = do

277+ argVar <- fresh

278+ done'' <- go (index + 1) done' bs'

279+ js <- binderToJs m e argVar done'' binder

280+ return (JSVariableIntroduction argVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSAccessor "values" (JSVar varName)))) : js)

283binderToJs m e varName done (ObjectBinder bs) = go done bs

281binderToJs m e varName done (ObjectBinder bs) = go done bs

284 where

282 where

285 go :: [JS] -> [(String, Binder)] -> Gen [JS]

283 go :: [JS] -> [(String, Binder)] -> Gen [JS]

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

@@ -72,7 +72,7 @@ data Declaration

72 -- |

73 -- A data type declaration (name, arguments, data constructors)

74 --

75− = DataDeclaration ProperName [String] [(ProperName, Maybe Type)]

75+ = DataDeclaration ProperName [String] [(ProperName, [Type])]

76 -- |

77 -- A minimal mutually recursive set of data type declarations

78 --

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

@@ -40,7 +40,7 @@ parseDataDeclaration = do

40 name <- indented *> properName

41 tyArgs <- many (indented *> identifier)

42 _ <- lexeme $ indented *> P.char '='

43− ctors <- sepBy1 ((,) <$> properName <*> P.optionMaybe (indented *> parsePolyType)) pipe

43+ ctors <- sepBy1 ((,) <$> properName <*> P.many (indented *> parseTypeAtom)) pipe

44 return $ DataDeclaration name tyArgs ctors

46parseTypeDeclaration :: P.Parsec String ParseState Declaration

src/Language/PureScript/Parser/Types.hs+5−1

@@ -15,7 +15,8 @@

16module Language.PureScript.Parser.Types (

17 parseType,

18− parsePolyType

18+ parsePolyType,

19+ parseTypeAtom

19) where

20) where

21import Language.PureScript.Types

22import Language.PureScript.Types

@@ -60,6 +61,9 @@ parseForAll :: P.Parsec String ParseState Type

60parseForAll = (mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot)

61parseForAll = (mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot)

61 <*> parseConstrainedType)

62 <*> parseConstrainedType)

64+-- |

65+-- Parse a type as it appears in e.g. a data constructor

66+--

63parseTypeAtom :: P.Parsec String ParseState Type

67parseTypeAtom :: P.Parsec String ParseState Type

64parseTypeAtom = indented *> P.choice (map P.try

68parseTypeAtom = indented *> P.choice (map P.try

65 [ parseNumber

69 [ parseNumber

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

@@ -228,11 +228,11 @@ parseNumberBinder = NumberBinder <$> C.integerOrFloat

228parseVarBinder :: P.Parsec String ParseState Binder

229parseVarBinder = VarBinder <$> C.parseIdent

230

231−parseNullaryBinder :: P.Parsec String ParseState Binder

231+parseNullaryConstructorBinder :: P.Parsec String ParseState Binder

232−parseNullaryBinder = NullaryBinder <$> C.lexeme (C.parseQualified C.properName)

232+parseNullaryConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> pure []

233

234−parseUnaryBinder :: P.Parsec String ParseState Binder

234+parseConstructorBinder :: P.Parsec String ParseState Binder

235−parseUnaryBinder = UnaryBinder <$> C.lexeme (C.parseQualified C.properName) <*> (C.indented *> parseBinder)

235+parseConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> (many (C.indented *> parseBinderNoParens))

236

237parseObjectBinder :: P.Parsec String ParseState Binder

238parseObjectBinder = ObjectBinder <$> C.braces (C.commaSep (C.indented *> parseIdentifierAndBinder))

@@ -262,8 +262,7 @@ parseBinderAtom = P.choice (map P.try

262 , parseNumberBinder

263 , parseNamedBinder

264 , parseVarBinder

265− , parseUnaryBinder

265+ , parseConstructorBinder

266− , parseNullaryBinder

267 , parseObjectBinder

266 , parseObjectBinder

268 , parseArrayBinder

267 , parseArrayBinder

269 , C.parens parseBinder ]) P.<?> "binder"

268 , C.parens parseBinder ]) P.<?> "binder"

@@ -287,7 +286,7 @@ parseBinderNoParens = P.choice (map P.try

287 , parseNumberBinder

286 , parseNumberBinder

288 , parseNamedBinder

287 , parseNamedBinder

289 , parseVarBinder

288 , parseVarBinder

290− , parseNullaryBinder

289+ , parseNullaryConstructorBinder

291 , parseObjectBinder

290 , parseObjectBinder

292 , parseArrayBinder

291 , parseArrayBinder

293 , C.parens parseBinder ]) P.<?> "binder"

292 , C.parens parseBinder ]) P.<?> "binder"

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

@@ -119,8 +119,7 @@ prettyPrintBinderAtom = mkPattern match

119 match (BooleanBinder True) = Just "true"

120 match (BooleanBinder False) = Just "false"

121 match (VarBinder ident) = Just $ show ident

122− match (NullaryBinder ctor) = Just $ show ctor

122+ match (ConstructorBinder ctor args) = Just $ show ctor ++ " " ++ intercalate " " (map (parens . prettyPrintBinder) args)

123− match (UnaryBinder ctor b) = Just $ show ctor ++ " " ++ prettyPrintBinder b

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

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

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

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

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

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

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

@@ -38,21 +38,21 @@ import Language.PureScript.Kinds

38import Language.PureScript.Declarations

39import Language.PureScript.Sugar.TypeClasses

41−addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, Maybe Type)] -> Kind -> Check ()

41+addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()

42addDataType moduleName name args dctors ctorKind = do

43 env <- getEnv

44 putEnv $ env { types = M.insert (moduleName, name) (ctorKind, Data) (types env) }

45− forM_ dctors $ \(dctor, maybeTy) ->

45+ forM_ dctors $ \(dctor, tys) ->

46 rethrow (("Error in data constructor " ++ show dctor ++ ":\n") ++) $

47− addDataConstructor moduleName name args dctor maybeTy

47+ addDataConstructor moduleName name args dctor tys

49−addDataConstructor :: ModuleName -> ProperName -> [String] -> ProperName -> Maybe Type -> Check ()

49+addDataConstructor :: ModuleName -> ProperName -> [String] -> ProperName -> [Type] -> Check ()

50−addDataConstructor moduleName name args dctor maybeTy = do

50+addDataConstructor moduleName name args dctor tys = do

51 env <- getEnv

52 dataConstructorIsNotDefined moduleName dctor

53 when (runModuleName moduleName == dctor) $ throwError "A data constructor may not have the same name as its enclosing module."

54 let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)

55− let dctorTy = maybe retTy (flip function retTy) maybeTy

55+ let dctorTy = foldr function retTy tys

56 let polyType = mkForAll args dctorTy

57 putEnv $ env { dataConstructors = M.insert (moduleName, dctor) (qualifyAllUnqualifiedNames moduleName env polyType, DataConstructor) (dataConstructors env) }

@@ -117,7 +117,7 @@ typeCheckAll _ [] = return []

117typeCheckAll moduleName (d@(DataDeclaration name args dctors) : rest) = do

118 rethrow (("Error in type constructor " ++ show name ++ ":\n") ++) $ do

119 typeIsNotDefined moduleName name

120− ctorKind <- kindsOf moduleName name args (mapMaybe snd dctors)

120+ ctorKind <- kindsOf moduleName name args (concatMap snd dctors)

121 addDataType moduleName name args dctors ctorKind

122 ds <- typeCheckAll moduleName rest

123 return $ d : ds

@@ -125,7 +125,7 @@ typeCheckAll moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do

125 rethrow ("Error in data binding group:\n" ++) $ do

126 let syns = mapMaybe toTypeSynonym tys

127 let dataDecls = mapMaybe toDataDecl tys

128− (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(name, args, dctors) -> (name, args, mapMaybe snd dctors)) dataDecls)

128+ (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)

129 forM_ (zip dataDecls data_ks) $ \((name, args, dctors), ctorKind) -> do

130 typeIsNotDefined moduleName name

131 addDataType moduleName name args dctors ctorKind

src/Language/PureScript/TypeChecker/Types.hs+9−14

@@ -597,25 +597,20 @@ inferBinder val (StringBinder _) = val =?= tyString >> return M.empty

597inferBinder val (NumberBinder _) = val =?= tyNumber >> return M.empty

598inferBinder val (BooleanBinder _) = val =?= tyBoolean >> return M.empty

599inferBinder val (VarBinder name) = return $ M.singleton name val

600−inferBinder val (NullaryBinder ctor) = do

600+inferBinder val (ConstructorBinder ctor binders) = do

601− env <- getEnv

602− Just moduleName <- checkCurrentModule <$> get

603− case M.lookup (qualify moduleName ctor) (dataConstructors env) of

604− Just (ty, _) -> do

605− _ <- subsumes Nothing ty val

606− return M.empty

607− _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"

608−inferBinder val (UnaryBinder ctor binder) = do

609 env <- getEnv

601 env <- getEnv

610 Just moduleName <- checkCurrentModule <$> get

602 Just moduleName <- checkCurrentModule <$> get

611 case M.lookup (qualify moduleName ctor) (dataConstructors env) of

603 case M.lookup (qualify moduleName ctor) (dataConstructors env) of

612 Just (ty, _) -> do

604 Just (ty, _) -> do

613 (_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contains constraints") ty

605 (_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contains constraints") ty

614− case fn of

606+ go binders fn

615− TypeApp (TypeApp t obj) ret | t == tyFunction -> do

607+ where

608+ go [] ty = do

616− _ <- subsumes Nothing val ret

609+ subsumes Nothing val ty

610+ return M.empty

611+ go (binder : binders) (TypeApp (TypeApp t obj) ret) | t == tyFunction =

617− inferBinder obj binder

612+ M.union <$> inferBinder obj binder <*> go binders ret

618− _ -> throwError $ "Constructor " ++ show ctor ++ " is not a unary constructor"

613+ go _ _ = throwError $ "Wrong number of arguments to constructor " ++ show ctor

619 _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"

614 _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"

620inferBinder val (ObjectBinder props) = do

615inferBinder val (ObjectBinder props) = do

621 row <- fresh

616 row <- fresh

src/Language/PureScript/Values.hs+2−6

@@ -247,13 +247,9 @@ data Binder

247 --

248 | VarBinder Ident

249 -- |

250− -- A binder which matches a data constructor with no argument

250+ -- A binder which matches a data constructor

251 --

252− | NullaryBinder (Qualified ProperName)

253− -- |

254− -- A binder which matches a data constructor with one argument

255− --

256− | UnaryBinder (Qualified ProperName) Binder

252+ | ConstructorBinder (Qualified ProperName) [Binder]

257 -- |

253 -- |

258 -- A binder which matches a record and binds its properties

254 -- A binder which matches a record and binds its properties

259 --

255 --