packages feed

purescript 0.3.12 → 0.3.13

raw patch · 13 files changed

+124/−135 lines, 13 files

Files

docgen/Main.hs view
@@ -92,8 +92,8 @@ 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
prelude/prelude.purs view
@@ -441,19 +441,19 @@   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 @@   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 @@   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 @@    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 @@   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 @@    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 @@                        \}" :: 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 @@    foreign import replaceR "function replaceR(r) {\                           \  return function(s1) {\-                          \    return function(s2) { \+                          \    return function(s2) {\                           \      return s2.replace(r, s1);\                           \    };\                           \  };\@@ -908,24 +903,24 @@    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 @@    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 @@    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) {}
purescript.cabal view
@@ -1,5 +1,5 @@ name: purescript-version: 0.3.12+version: 0.3.13 cabal-version: >=1.8 build-type: Simple license: MIT
src/Language/PureScript/CodeGen/JS.hs view
@@ -74,16 +74,14 @@            : 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 @@   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) =-  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)+binderToJs m e varName done (ConstructorBinder ctor bs) = do+  js <- go 0 done bs   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]
src/Language/PureScript/Declarations.hs view
@@ -72,7 +72,7 @@   -- |   -- 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   --
src/Language/PureScript/Parser/Declarations.hs view
@@ -40,7 +40,7 @@   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
src/Language/PureScript/Parser/Types.hs view
@@ -15,7 +15,8 @@  module Language.PureScript.Parser.Types (     parseType,-    parsePolyType+    parsePolyType,+    parseTypeAtom ) where  import Language.PureScript.Types@@ -60,6 +61,9 @@ 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
src/Language/PureScript/Parser/Values.hs view
@@ -228,11 +228,11 @@ 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 @@                   , parseNumberBinder                   , parseNamedBinder                   , parseVarBinder-                  , parseUnaryBinder-                  , parseNullaryBinder+                  , parseConstructorBinder                   , parseObjectBinder                   , parseArrayBinder                   , C.parens parseBinder ]) P.<?> "binder"@@ -287,7 +286,7 @@                   , parseNumberBinder                   , parseNamedBinder                   , parseVarBinder-                  , parseNullaryBinder+                  , parseNullaryConstructorBinder                   , parseObjectBinder                   , parseArrayBinder                   , C.parens parseBinder ]) P.<?> "binder"
src/Language/PureScript/Pretty/Values.hs view
@@ -119,8 +119,7 @@   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
src/Language/PureScript/Sugar/TypeClasses.hs view
@@ -81,7 +81,7 @@ -- --   __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 @@   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 @@     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"
src/Language/PureScript/TypeChecker.hs view
@@ -38,21 +38,21 @@ 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 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 @@   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
src/Language/PureScript/TypeChecker/Types.hs view
@@ -287,6 +287,7 @@   -- 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 (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
src/Language/PureScript/Values.hs view
@@ -247,13 +247,9 @@   --   | VarBinder Ident   -- |-  -- A binder which matches a data constructor with no argument-  ---  | NullaryBinder (Qualified ProperName)-  -- |-  -- A binder which matches a data constructor with one argument+  -- A binder which matches a data constructor   ---  | UnaryBinder (Qualified ProperName) Binder+  | ConstructorBinder (Qualified ProperName) [Binder]   -- |   -- A binder which matches a record and binds its properties   --