summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-02-11 04:29:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-02-11 04:29:00 (GMT)
commite0b7d7b734222037539d352a4317f4cc1770db2a (patch)
treefea514bdb74eee60e02b543cc3063ebdb4bbd8c2
parentb6cbc00be397476d10881590bd1201666d5bee69 (diff)
version 0.3.130.3.13
-rw-r--r--docgen/Main.hs4
-rw-r--r--prelude/prelude.purs125
-rw-r--r--purescript.cabal2
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs42
-rw-r--r--src/Language/PureScript/Declarations.hs2
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs2
-rw-r--r--src/Language/PureScript/Parser/Types.hs6
-rw-r--r--src/Language/PureScript/Parser/Values.hs13
-rw-r--r--src/Language/PureScript/Pretty/Values.hs3
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs12
-rw-r--r--src/Language/PureScript/TypeChecker.hs16
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs24
-rw-r--r--src/Language/PureScript/Values.hs8
13 files changed, 124 insertions, 135 deletions
diff --git a/docgen/Main.hs b/docgen/Main.hs
index 544f503..9cd2a43 100644
--- a/docgen/Main.hs
+++ b/docgen/Main.hs
@@ -92,8 +92,8 @@ renderDeclaration n (P.ExternDeclaration _ ident _ ty) =
renderDeclaration n (P.DataDeclaration name args ctors) = do
let typeName = P.runProperName name ++ " " ++ intercalate " " args
atIndent n $ "data " ++ typeName ++ " where"
- forM_ ctors $ \(ctor, ty) -> do
- atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ maybe "" ((++ " -> ") . P.prettyPrintType) ty ++ typeName
+ forM_ ctors $ \(ctor, tys) -> do
+ atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ concat (map (\ty -> P.prettyPrintType ty ++ " -> ") tys) ++ typeName
renderDeclaration n (P.ExternDataDeclaration name kind) =
atIndent n $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind
renderDeclaration n (P.TypeSynonymDeclaration name args ty) = do
diff --git a/prelude/prelude.purs b/prelude/prelude.purs
index b830d44..c17988d 100644
--- a/prelude/prelude.purs
+++ b/prelude/prelude.purs
@@ -441,19 +441,19 @@ module Maybe where
fromMaybe :: forall a. a -> Maybe a -> a
fromMaybe a = maybe a (Prelude.id :: forall a. a -> a)
- instance Prelude.Functor Maybe where
- (<$>) fn (Just x) = Just (fn x)
- (<$>) _ _ = Nothing
-
+ instance Prelude.Monad Maybe where
+ return = Just
+ (>>=) m f = maybe Nothing f m
+
instance Prelude.Applicative Maybe where
pure = Just
(<*>) (Just fn) x = fn <$> x
(<*>) Nothing _ = Nothing
- instance Prelude.Monad Maybe where
- return = Just
- (>>=) m f = maybe Nothing f m
-
+ instance Prelude.Functor Maybe where
+ (<$>) fn (Just x) = Just (fn x)
+ (<$>) _ _ = Nothing
+
instance (Show a) => Prelude.Show (Maybe a) where
show (Just x) = "Just " ++ (show x)
show Nothing = "Nothing"
@@ -468,20 +468,18 @@ module Either where
either f _ (Left a) = f a
either _ g (Right b) = g b
- {-
- instance Prelude.Functor (Either a) where
- (<$>) _ (Left x) = Left x
- (<$>) f (Right y) = Right (f y)
- -}
+ instance Prelude.Monad (Either e) where
+ return = Right
+ (>>=) = either (\e _ -> Left e) (\a f -> f a)
instance Prelude.Applicative (Either e) where
pure = Right
(<*>) (Left e) _ = Left e
(<*>) (Right f) r = f <$> r
- instance Prelude.Monad (Either e) where
- return = Right
- (>>=) = either (\e _ -> Left e) (\a f -> f a)
+ instance Prelude.Functor (Either a) where
+ (<$>) _ (Left x) = Left x
+ (<$>) f (Right y) = Right (f y)
instance (Show a, Show b) => Prelude.Show (Either a b) where
show (Left x) = "Left " ++ (show x)
@@ -518,8 +516,8 @@ module Arrays where
foldl _ b [] = b
foldl f b (a:as) = foldl f (f a b) as
- foreign import length "function length(xs) { \
- \ return xs.length; \
+ foreign import length "function length(xs) {\
+ \ return xs.length;\
\}" :: forall a. [a] -> Number
foreign import indexOf "function indexOf(l) {\
@@ -586,7 +584,7 @@ module Arrays where
foreign import splice "function splice(s) {\
\ return function(e) {\
- \ return function(l1) { \
+ \ return function(l1) {\
\ return function(l2) {\
\ return l2.splice(s, e, l1);\
\ }; \
@@ -656,27 +654,24 @@ module Tuples where
import Prelude
import Arrays
- data Tuple a b = Tuple { fst :: a, snd :: b }
+ data Tuple a b = Tuple a b
instance (Prelude.Show a, Prelude.Show b) => Prelude.Show (Tuple a b) where
- show (Tuple { fst = a, snd = b }) = "Tuple(" ++ show a ++ ", " ++ show b ++ ")"
+ show (Tuple a b) = "Tuple(" ++ show a ++ ", " ++ show b ++ ")"
curry :: forall a b c. (Tuple a b -> c) -> a -> b -> c
- curry f a b = f (tuple a b)
+ curry f a b = f (Tuple a b)
uncurry :: forall a b c. (a -> b -> c) -> Tuple a b -> c
- uncurry f (Tuple t) = f t.fst t.snd
-
- tuple :: forall a b. a -> b -> Tuple a b
- tuple a b = Tuple { fst: a, snd: b }
+ uncurry f (Tuple a b) = f a b
zip :: forall a b. [a] -> [b] -> [Tuple a b]
- zip = zipWith tuple
+ zip = zipWith Tuple
unzip :: forall a b. [Tuple a b] -> Tuple [a] [b]
- unzip ((Tuple t):ts) = case unzip ts of
- Tuple { fst = as, snd = bs } -> tuple (t.fst : as) (t.snd : bs)
- unzip [] = tuple [] []
+ unzip ((Tuple a b):ts) = case unzip ts of
+ Tuple as bs -> Tuple (a : as) (b : bs)
+ unzip [] = Tuple [] []
module String where
@@ -692,18 +687,18 @@ module String where
foreign import indexOfS "function indexOfS(s1) {\
\ return function(s2) {\
- \ return s2.indexOf(s2);\
+ \ return s1.indexOf(s2);\
\ }; \
\}" :: String -> String -> Number
foreign import lastIndexOfS "function lastIndexOfS(s1) {\
\ return function(s2) {\
- \ return s2.lastIndexOf(s2);\
+ \ return s1.lastIndexOf(s2);\
\ };\
\}" :: String -> String -> Number
foreign import localeCompare "function localeCompare(s1) {\
- \ return function(s2) { \
+ \ return function(s2) {\
\ return s1.localeCompare(s2);\
\ };\
\}" :: String -> String -> Number
@@ -769,7 +764,7 @@ module Regex where
\}" :: String -> String -> Regex
foreign import test "function test(r) {\
- \ return function (s) { \
+ \ return function (s) {\
\ return r.test(s);\
\ };\
\}" :: Regex -> String -> Boolean
@@ -782,7 +777,7 @@ module Regex where
foreign import replaceR "function replaceR(r) {\
\ return function(s1) {\
- \ return function(s2) { \
+ \ return function(s2) {\
\ return s2.replace(r, s1);\
\ };\
\ };\
@@ -908,24 +903,24 @@ module Eff where
foreign import data Eff :: # ! -> * -> *
- foreign import retEff "function retEff(a) { \
- \ return function() { \
- \ return a; \
- \ }; \
+ foreign import retEff "function retEff(a) {\
+ \ return function() {\
+ \ return a;\
+ \ };\
\}" :: forall e a. a -> Eff e a
- foreign import bindEff "function bindEff(a) { \
- \ return function(f) { \
- \ return function() { \
- \ return f(a())(); \
- \ }; \
- \ }; \
+ foreign import bindEff "function bindEff(a) {\
+ \ return function(f) {\
+ \ return function() {\
+ \ return f(a())();\
+ \ };\
+ \ };\
\}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b
type Pure a = forall e. Eff e a
- foreign import runPure "function runPure(f) { \
- \ return f(); \
+ foreign import runPure "function runPure(f) {\
+ \ return f();\
\}" :: forall a. Pure a -> a
instance Prelude.Monad (Eff e) where
@@ -988,22 +983,22 @@ module Errors where
foreign import data Error :: * -> !
- foreign import throwError "function throwError(e) { \
- \ return function() { \
- \ throw e; \
- \ }; \
+ foreign import throwError "function throwError(e) {\
+ \ return function() {\
+ \ throw e;\
+ \ };\
\}" :: forall a e r. e -> Eff (err :: Error e | r) a
- foreign import catchError "function catchError(c) { \
- \ return function(t) { \
- \ return function() { \
- \ try { \
- \ return t(); \
- \ } catch(e) { \
- \ return c(e)(); \
+ foreign import catchError "function catchError(c) {\
+ \ return function(t) {\
+ \ return function() {\
+ \ try {\
+ \ return t();\
+ \ } catch(e) {\
+ \ return c(e)();\
\ }\
- \ }; \
- \ }; \
+ \ };\
+ \ };\
\}" :: forall e r a. (e -> Eff r a) -> Eff (err :: Error e | r) a -> Eff r a
module IORef where
@@ -1056,11 +1051,11 @@ module Trace where
foreign import data Trace :: !
- foreign import trace "function trace(s) { \
- \ return function() { \
- \ console.log(s); \
- \ return {}; \
- \ }; \
+ foreign import trace "function trace(s) {\
+ \ return function() {\
+ \ console.log(s);\
+ \ return {};\
+ \ };\
\}" :: forall r. String -> Eff (trace :: Trace | r) {}
print :: forall a r. (Prelude.Show a) => a -> Eff (trace :: Trace | r) {}
diff --git a/purescript.cabal b/purescript.cabal
index 581f926..7d45c47 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.3.12
+version: 0.3.13
cabal-version: >=1.8
build-type: Simple
license: MIT
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 3cce144..ab01907 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -74,16 +74,14 @@ declToJs opts mp (BindingGroupDeclaration vals) e =
: setProperty ident (var ident) mp
) vals
declToJs _ mp (DataDeclaration _ _ ctors) _ =
- Just $ flip concatMap ctors $ \(pn@(ProperName ctor), maybeTy) ->
- let
- ctorJs =
- case maybeTy of
- Nothing -> JSVariableIntroduction ctor (Just (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn))) ]))
- Just _ -> JSFunction (Just ctor) ["value"]
- (JSBlock [JSReturn
- (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn)))
- , ("value", JSVar "value") ])])
- in ctorJs : setProperty (Escaped ctor) (JSVar ctor) mp
+ Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->
+ JSVariableIntroduction ctor (Just (go pn 0 tys [])) : setProperty (Escaped ctor) (JSVar ctor) mp
+ where
+ go pn _ [] values =
+ JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn))), ("values", JSArrayLiteral $ reverse values) ]
+ go pn index (_ : tys') values =
+ JSFunction Nothing ["value" ++ show index]
+ (JSBlock [JSReturn (go pn (index + 1) tys' (JSVar ("value" ++ show index) : values))])
declToJs opts mp (DataBindingGroupDeclaration ds) e =
Just $ concat $ mapMaybe (flip (declToJs opts mp) e) ds
declToJs _ mp (ExternDeclaration importTy ident (Just js) _) _ =
@@ -263,23 +261,23 @@ binderToJs _ _ varName done (BooleanBinder False) =
return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
binderToJs m e varName done (VarBinder ident) =
return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)
-binderToJs m e varName done (NullaryBinder ctor) =
+binderToJs m e varName done (ConstructorBinder ctor bs) = do
+ js <- go 0 done bs
if isOnlyConstructor m e ctor
then
- return done
- else
- return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ canonicalizeDataConstructor m e ctor)))) (JSBlock done) Nothing]
-binderToJs m e varName done (UnaryBinder ctor b) = do
- value <- fresh
- js <- binderToJs m e value done b
- let success = JSBlock (JSVariableIntroduction value (Just (JSAccessor "value" (JSVar varName))) : js)
- if isOnlyConstructor m e ctor
- then
- return [success]
+ return js
else
return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ canonicalizeDataConstructor m e ctor))))
- success
+ (JSBlock js)
Nothing]
+ where
+ go :: Integer -> [JS] -> [Binder] -> Gen [JS]
+ go _ done' [] = return done'
+ go index done' (binder:bs') = do
+ argVar <- fresh
+ done'' <- go (index + 1) done' bs'
+ js <- binderToJs m e argVar done'' binder
+ return (JSVariableIntroduction argVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSAccessor "values" (JSVar varName)))) : js)
binderToJs m e varName done (ObjectBinder bs) = go done bs
where
go :: [JS] -> [(String, Binder)] -> Gen [JS]
diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs
index 40f041d..b13d4d9 100644
--- a/src/Language/PureScript/Declarations.hs
+++ b/src/Language/PureScript/Declarations.hs
@@ -72,7 +72,7 @@ data Declaration
-- |
-- A data type declaration (name, arguments, data constructors)
--
- = DataDeclaration ProperName [String] [(ProperName, Maybe Type)]
+ = DataDeclaration ProperName [String] [(ProperName, [Type])]
-- |
-- A minimal mutually recursive set of data type declarations
--
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 79f4248..7858419 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -40,7 +40,7 @@ parseDataDeclaration = do
name <- indented *> properName
tyArgs <- many (indented *> identifier)
_ <- lexeme $ indented *> P.char '='
- ctors <- sepBy1 ((,) <$> properName <*> P.optionMaybe (indented *> parsePolyType)) pipe
+ ctors <- sepBy1 ((,) <$> properName <*> P.many (indented *> parseTypeAtom)) pipe
return $ DataDeclaration name tyArgs ctors
parseTypeDeclaration :: P.Parsec String ParseState Declaration
diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
index d88f906..ecd9bdc 100644
--- a/src/Language/PureScript/Parser/Types.hs
+++ b/src/Language/PureScript/Parser/Types.hs
@@ -15,7 +15,8 @@
module Language.PureScript.Parser.Types (
parseType,
- parsePolyType
+ parsePolyType,
+ parseTypeAtom
) where
import Language.PureScript.Types
@@ -60,6 +61,9 @@ parseForAll :: P.Parsec String ParseState Type
parseForAll = (mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot)
<*> parseConstrainedType)
+-- |
+-- Parse a type as it appears in e.g. a data constructor
+--
parseTypeAtom :: P.Parsec String ParseState Type
parseTypeAtom = indented *> P.choice (map P.try
[ parseNumber
diff --git a/src/Language/PureScript/Parser/Values.hs b/src/Language/PureScript/Parser/Values.hs
index 07fd6f4..6d45baf 100644
--- a/src/Language/PureScript/Parser/Values.hs
+++ b/src/Language/PureScript/Parser/Values.hs
@@ -228,11 +228,11 @@ parseNumberBinder = NumberBinder <$> C.integerOrFloat
parseVarBinder :: P.Parsec String ParseState Binder
parseVarBinder = VarBinder <$> C.parseIdent
-parseNullaryBinder :: P.Parsec String ParseState Binder
-parseNullaryBinder = NullaryBinder <$> C.lexeme (C.parseQualified C.properName)
+parseNullaryConstructorBinder :: P.Parsec String ParseState Binder
+parseNullaryConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> pure []
-parseUnaryBinder :: P.Parsec String ParseState Binder
-parseUnaryBinder = UnaryBinder <$> C.lexeme (C.parseQualified C.properName) <*> (C.indented *> parseBinder)
+parseConstructorBinder :: P.Parsec String ParseState Binder
+parseConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> (many (C.indented *> parseBinderNoParens))
parseObjectBinder :: P.Parsec String ParseState Binder
parseObjectBinder = ObjectBinder <$> C.braces (C.commaSep (C.indented *> parseIdentifierAndBinder))
@@ -262,8 +262,7 @@ parseBinderAtom = P.choice (map P.try
, parseNumberBinder
, parseNamedBinder
, parseVarBinder
- , parseUnaryBinder
- , parseNullaryBinder
+ , parseConstructorBinder
, parseObjectBinder
, parseArrayBinder
, C.parens parseBinder ]) P.<?> "binder"
@@ -287,7 +286,7 @@ parseBinderNoParens = P.choice (map P.try
, parseNumberBinder
, parseNamedBinder
, parseVarBinder
- , parseNullaryBinder
+ , parseNullaryConstructorBinder
, parseObjectBinder
, parseArrayBinder
, C.parens parseBinder ]) P.<?> "binder"
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index 0932d84..1e47f52 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -119,8 +119,7 @@ prettyPrintBinderAtom = mkPattern match
match (BooleanBinder True) = Just "true"
match (BooleanBinder False) = Just "false"
match (VarBinder ident) = Just $ show ident
- match (NullaryBinder ctor) = Just $ show ctor
- match (UnaryBinder ctor b) = Just $ show ctor ++ " " ++ prettyPrintBinder b
+ match (ConstructorBinder ctor args) = Just $ show ctor ++ " " ++ intercalate " " (map (parens . prettyPrintBinder) args)
match (ObjectBinder bs) = Just $ "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }"
match (ArrayBinder bs) = Just $ "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ " ]"
match (NamedBinder ident binder) = Just $ show ident ++ "@" ++ prettyPrintBinder binder
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 40a35fc..3c08625 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -81,7 +81,7 @@ desugarModule (Module name decls) = Module name <$> concat <$> mapM (desugarDecl
--
-- __Test_Foo_string_foo = (\s -> s ++ s) :: String -> String
--
--- __Test_Foo_string :: Foo String
+-- __Test_Foo_string :: {} -> Foo String
-- __Test_Foo_string = { foo: __Test_Foo_string_foo :: String -> String (unchecked) }
--
-- __Test_Foo_array_foo :: forall a. (Foo a) => [a] -> [a]
@@ -127,8 +127,11 @@ typeInstanceDictionaryDeclaration mn deps name ty decls = do
memberNames <- mapM (memberToNameAndValue memberTypes) decls
return $ ValueDeclaration entryName [] Nothing
(TypedValue True
- (foldr Abs (ObjectLiteral memberNames) (map (\n -> Ident ('_' : show n)) [1..length deps]))
- (quantify (foldr function (TypeApp (TypeConstructor name) ty) (map (\(pn, ty') -> TypeApp (TypeConstructor pn) ty') deps)))
+ (foldr Abs (ObjectLiteral memberNames) (map (\n -> Ident ('_' : show n)) [1..max 1 (length deps)]))
+ (quantify (if null deps then
+ function unit (TypeApp (TypeConstructor name) ty)
+ else
+ foldr function (TypeApp (TypeConstructor name) ty) (map (\(pn, ty') -> TypeApp (TypeConstructor pn) ty') deps)))
)
where
memberToNameAndValue :: [(String, Type)] -> Declaration -> Desugar (String, Value)
@@ -136,8 +139,7 @@ typeInstanceDictionaryDeclaration mn deps name ty decls = do
memberType <- lift . maybe (Left "Type class member type not found") Right $ lookup (identToJs ident) tys
memberName <- mkDictionaryEntryName mn name ty ident
return (identToJs ident, TypedValue False
- (if null deps then Var (Qualified Nothing memberName)
- else foldl App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))
+ (foldl App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))
(quantify memberType))
memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index e1c790e..0d993eb 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -38,21 +38,21 @@ import Language.PureScript.Kinds
import Language.PureScript.Declarations
import Language.PureScript.Sugar.TypeClasses
-addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, Maybe Type)] -> Kind -> Check ()
+addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()
addDataType moduleName name args dctors ctorKind = do
env <- getEnv
putEnv $ env { types = M.insert (moduleName, name) (ctorKind, Data) (types env) }
- forM_ dctors $ \(dctor, maybeTy) ->
+ forM_ dctors $ \(dctor, tys) ->
rethrow (("Error in data constructor " ++ show dctor ++ ":\n") ++) $
- addDataConstructor moduleName name args dctor maybeTy
+ addDataConstructor moduleName name args dctor tys
-addDataConstructor :: ModuleName -> ProperName -> [String] -> ProperName -> Maybe Type -> Check ()
-addDataConstructor moduleName name args dctor maybeTy = do
+addDataConstructor :: ModuleName -> ProperName -> [String] -> ProperName -> [Type] -> Check ()
+addDataConstructor moduleName name args dctor tys = do
env <- getEnv
dataConstructorIsNotDefined moduleName dctor
when (runModuleName moduleName == dctor) $ throwError "A data constructor may not have the same name as its enclosing module."
let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)
- let dctorTy = maybe retTy (flip function retTy) maybeTy
+ let dctorTy = foldr function retTy tys
let polyType = mkForAll args dctorTy
putEnv $ env { dataConstructors = M.insert (moduleName, dctor) (qualifyAllUnqualifiedNames moduleName env polyType, DataConstructor) (dataConstructors env) }
@@ -117,7 +117,7 @@ typeCheckAll _ [] = return []
typeCheckAll moduleName (d@(DataDeclaration name args dctors) : rest) = do
rethrow (("Error in type constructor " ++ show name ++ ":\n") ++) $ do
typeIsNotDefined moduleName name
- ctorKind <- kindsOf moduleName name args (mapMaybe snd dctors)
+ ctorKind <- kindsOf moduleName name args (concatMap snd dctors)
addDataType moduleName name args dctors ctorKind
ds <- typeCheckAll moduleName rest
return $ d : ds
@@ -125,7 +125,7 @@ typeCheckAll moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do
rethrow ("Error in data binding group:\n" ++) $ do
let syns = mapMaybe toTypeSynonym tys
let dataDecls = mapMaybe toDataDecl tys
- (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(name, args, dctors) -> (name, args, mapMaybe snd dctors)) dataDecls)
+ (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
forM_ (zip dataDecls data_ks) $ \((name, args, dctors), ctorKind) -> do
typeIsNotDefined moduleName name
addDataType moduleName name args dctors ctorKind
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 7ffdeaf..429803e 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -287,6 +287,7 @@ entails moduleName context goal@(className, ty) = do
-- Make a dictionary from subgoal dictionaries by applying the correct function
mkDictionary :: Qualified Ident -> Maybe [Value] -> Value
mkDictionary fnName Nothing = Var fnName
+ mkDictionary fnName (Just []) = App (Var fnName) (ObjectLiteral [])
mkDictionary fnName (Just dicts) = foldl App (Var fnName) dicts
-- Filter out type dictionaries which are in scope in the current module
filterModule :: TypeClassDictionaryInScope -> Bool
@@ -596,25 +597,20 @@ inferBinder val (StringBinder _) = val =?= tyString >> return M.empty
inferBinder val (NumberBinder _) = val =?= tyNumber >> return M.empty
inferBinder val (BooleanBinder _) = val =?= tyBoolean >> return M.empty
inferBinder val (VarBinder name) = return $ M.singleton name val
-inferBinder val (NullaryBinder ctor) = do
- env <- getEnv
- Just moduleName <- checkCurrentModule <$> get
- case M.lookup (qualify moduleName ctor) (dataConstructors env) of
- Just (ty, _) -> do
- _ <- subsumes Nothing ty val
- return M.empty
- _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
-inferBinder val (UnaryBinder ctor binder) = do
+inferBinder val (ConstructorBinder ctor binders) = do
env <- getEnv
Just moduleName <- checkCurrentModule <$> get
case M.lookup (qualify moduleName ctor) (dataConstructors env) of
Just (ty, _) -> do
(_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contains constraints") ty
- case fn of
- TypeApp (TypeApp t obj) ret | t == tyFunction -> do
- _ <- subsumes Nothing val ret
- inferBinder obj binder
- _ -> throwError $ "Constructor " ++ show ctor ++ " is not a unary constructor"
+ go binders fn
+ where
+ go [] ty = do
+ subsumes Nothing val ty
+ return M.empty
+ go (binder : binders) (TypeApp (TypeApp t obj) ret) | t == tyFunction =
+ M.union <$> inferBinder obj binder <*> go binders ret
+ go _ _ = throwError $ "Wrong number of arguments to constructor " ++ show ctor
_ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
inferBinder val (ObjectBinder props) = do
row <- fresh
diff --git a/src/Language/PureScript/Values.hs b/src/Language/PureScript/Values.hs
index 5433b1c..3049a01 100644
--- a/src/Language/PureScript/Values.hs
+++ b/src/Language/PureScript/Values.hs
@@ -247,13 +247,9 @@ data Binder
--
| VarBinder Ident
-- |
- -- A binder which matches a data constructor with no argument
+ -- A binder which matches a data constructor
--
- | NullaryBinder (Qualified ProperName)
- -- |
- -- A binder which matches a data constructor with one argument
- --
- | UnaryBinder (Qualified ProperName) Binder
+ | ConstructorBinder (Qualified ProperName) [Binder]
-- |
-- A binder which matches a record and binds its properties
--