packages feed

purescript 0.1.14 → 0.1.15

raw patch · 25 files changed

+247/−274 lines, 25 filesdep ~cmdtheline

Dependency ranges changed: cmdtheline

Files

purescript.cabal view
@@ -1,5 +1,5 @@ name: purescript-version: 0.1.14+version: 0.1.15 cabal-version: >=1.8 build-type: Simple license: MIT@@ -14,46 +14,45 @@ data-dir: ""  library-    build-depends: base >=4 && <5, syb -any, cmdtheline -any,-                   containers -any, mtl -any, transformers -any, parsec -any,-                   utf8-string -any-    exposed-modules: Data.Generics.Extras Language.PureScript.Operators-                     Language.PureScript.Optimize Language.PureScript.Pretty.JS-                     Language.PureScript.CodeGen.JS.AST Main Language.PureScript-                     Language.PureScript.Declarations Language.PureScript.Names-                     Language.PureScript.Types Language.PureScript.Values-                     Language.PureScript.Kinds Language.PureScript.Pretty-                     Language.PureScript.Pretty.Common Language.PureScript.Pretty.Values-                     Language.PureScript.Pretty.Types Language.PureScript.Pretty.Kinds+    build-depends: base >=4 && <5, cmdtheline -any, containers -any,+                   directory -any, filepath -any, mtl -any, parsec -any,+                   syb -any, transformers -any, utf8-string -any+    exposed-modules: Data.Generics.Extras Language.PureScript                      Language.PureScript.CodeGen Language.PureScript.CodeGen.Externs-                     Language.PureScript.CodeGen.JS Language.PureScript.CodeGen.Monad+                     Language.PureScript.CodeGen.JS Language.PureScript.CodeGen.JS.AST+                     Language.PureScript.CodeGen.Monad Language.PureScript.Declarations+                     Language.PureScript.Kinds Language.PureScript.Names+                     Language.PureScript.Operators Language.PureScript.Optimize                      Language.PureScript.Parser Language.PureScript.Parser.Common                      Language.PureScript.Parser.Declarations+                     Language.PureScript.Parser.Kinds Language.PureScript.Parser.State                      Language.PureScript.Parser.Types Language.PureScript.Parser.Values-                     Language.PureScript.Parser.State Language.PureScript.Parser.Kinds+                     Language.PureScript.Pretty Language.PureScript.Pretty.Common+                     Language.PureScript.Pretty.JS Language.PureScript.Pretty.Kinds+                     Language.PureScript.Pretty.Types Language.PureScript.Pretty.Values                      Language.PureScript.TypeChecker                      Language.PureScript.TypeChecker.Kinds                      Language.PureScript.TypeChecker.Monad-                     Language.PureScript.TypeChecker.Types                      Language.PureScript.TypeChecker.Synonyms-                     Language.PureScript.Unknown+                     Language.PureScript.TypeChecker.Types Language.PureScript.Types+                     Language.PureScript.Unknown Language.PureScript.Values Main     exposed: True     buildable: True     hs-source-dirs: src  executable psc     build-depends: base >=4 && <5, cmdtheline -any, containers -any,-                   mtl -any, transformers -any, parsec -any, utf8-string -any,-                   syb -any+                   directory -any, filepath -any, mtl -any, parsec -any,+                   purescript -any, syb -any, transformers -any, utf8-string -any     main-is: Main.hs     buildable: True     hs-source-dirs: src-    other-modules:+    ghc-options: -Wall -O2 -fno-warn-unused-do-bind  test-suite tests-    build-depends: base >=4 && <5, syb -any, directory -any,-                   filepath -any, containers -any, mtl -any, transformers -any,-                   parsec -any, utf8-string -any, purescript -any+    build-depends: base >=4 && <5, cmdtheline -any, containers -any,+                   directory -any, filepath -any, mtl -any, parsec -any,+                   purescript -any, syb -any, transformers -any, utf8-string -any     type: exitcode-stdio-1.0     main-is: Main.hs     buildable: True
src/Data/Generics/Extras.hs view
@@ -18,7 +18,7 @@  import Data.Data -everywhereM' :: (Monad m, Data d) => (forall d. (Data d) => d -> m d) -> d -> m d+everywhereM' :: (Monad m, Data d) => (forall d1. (Data d1) => d1 -> m d1) -> d -> m d everywhereM' f x = do   y <- f x   gmapM (everywhereM' f) y
src/Language/PureScript/CodeGen/Externs.hs view
@@ -16,7 +16,6 @@     externToPs ) where -import Data.List (intercalate) import Data.Maybe (mapMaybe) import qualified Data.Map as M import Language.PureScript.Declarations@@ -31,11 +30,11 @@ externToPs indent path env (DataDeclaration name _ _) = do   (kind, _) <- M.lookup (path, name) $ types env   return $ replicate indent ' ' ++ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind-externToPs indent path env (ExternMemberDeclaration member name ty) =+externToPs indent _ _ (ExternMemberDeclaration member name ty) =   return $ replicate indent ' ' ++ "foreign import member " ++ show member ++ " " ++ show name ++ " :: " ++ prettyPrintType ty-externToPs indent path env (ExternDataDeclaration name kind) =+externToPs indent _ _ (ExternDataDeclaration name kind) =   return $ replicate indent ' ' ++ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind-externToPs indent path env (TypeSynonymDeclaration name args ty) =+externToPs indent _ _ (TypeSynonymDeclaration name args ty) =   return $ replicate indent ' ' ++ "type " ++ show name ++ " " ++ unwords args ++ " = " ++ prettyPrintType ty externToPs indent path env (ModuleDeclaration name decls) =   return $ replicate indent ' ' ++ "module " ++ show name ++ " where\n" ++ unlines (mapMaybe (externToPs (indent + 2) (subModule path name) env) decls)
src/Language/PureScript/CodeGen/JS.hs view
@@ -17,17 +17,12 @@     declToJs ) where -import Data.Char-import Data.Maybe (fromMaybe, mapMaybe)-import Data.List (intercalate)+import Data.Maybe (mapMaybe) import qualified Data.Map as M-import qualified Control.Arrow as A-import Control.Arrow ((<+>), second)+import Control.Arrow (second) import Control.Monad (forM)-import Control.Applicative  import Language.PureScript.TypeChecker (Environment, names)-import Language.PureScript.Types import Language.PureScript.Values import Language.PureScript.Names import Language.PureScript.Declarations@@ -37,16 +32,16 @@ import Language.PureScript.TypeChecker.Monad (NameKind(..))  declToJs :: Maybe Ident -> ModulePath -> Declaration -> Environment -> Maybe [JS]-declToJs mod mp (ValueDeclaration ident (Abs args ret)) e =+declToJs curMod mp (ValueDeclaration ident (Abs args ret)) e =   Just $ JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs mp e ret)]) :-         maybe [] (return . setProperty (identToJs ident) (JSVar ident)) mod-declToJs mod mp (ValueDeclaration ident val) e =+         maybe [] (return . setProperty (identToJs ident) (JSVar ident)) curMod+declToJs curMod mp (ValueDeclaration ident val) e =   Just $ JSVariableIntroduction ident (Just (valueToJs mp e val)) :-         maybe [] (return . setProperty (identToJs ident) (JSVar ident)) mod-declToJs mod _ (ExternMemberDeclaration member ident _) _ =+         maybe [] (return . setProperty (identToJs ident) (JSVar ident)) curMod+declToJs curMod _ (ExternMemberDeclaration member ident _) _ =   Just $ JSFunction (Just ident) [Ident "value"] (JSBlock [JSReturn (JSAccessor member (JSVar (Ident "value")))]) :-         maybe [] (return . setProperty (show ident) (JSVar ident)) mod-declToJs mod mp (DataDeclaration _ _ ctors) _ =+         maybe [] (return . setProperty (show ident) (JSVar ident)) curMod+declToJs curMod mp (DataDeclaration _ _ ctors) _ =   Just $ flip concatMap ctors $ \(pn@(ProperName ctor), maybeTy) ->     let       ctorJs =@@ -56,18 +51,18 @@                       (JSBlock [JSReturn                         (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified mp pn)))                                          , ("value", JSVar (Ident "value")) ])])-    in ctorJs : maybe [] (return . setProperty ctor (JSVar (Ident ctor))) mod-declToJs mod mp (ModuleDeclaration pn@(ProperName name) decls) env =+    in ctorJs : maybe [] (return . setProperty ctor (JSVar (Ident ctor))) curMod+declToJs curMod mp (ModuleDeclaration pn@(ProperName name) decls) env =   Just $ [ JSVariableIntroduction (Ident name) Nothing          , JSApp (JSFunction Nothing [Ident name]                              (JSBlock (concat $ mapMaybe (\decl -> declToJs (Just (Ident name)) (subModule mp pn) decl env) decls)))                  [JSAssignment (JSAssignVariable (Ident name))                                (JSBinary Or (JSVar (Ident name)) (JSObjectLiteral []))]] ++-         maybe [] (return . setProperty name (JSVar (Ident name))) mod+         maybe [] (return . setProperty name (JSVar (Ident name))) curMod declToJs _ _ _ _ = Nothing  setProperty :: String -> JS -> Ident -> JS-setProperty prop val mod = JSAssignment (JSAssignProperty prop (JSAssignVariable mod)) val+setProperty prop val curMod = JSAssignment (JSAssignProperty prop (JSAssignVariable curMod)) val  valueToJs :: ModulePath -> Environment -> Value -> JS valueToJs _ _ (NumericLiteral n) = JSNumericLiteral n@@ -76,7 +71,7 @@ valueToJs m e (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs m e) xs) valueToJs m e (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs m e)) ps) valueToJs m e (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar (Ident "Object"))) [ valueToJs m e o, JSObjectLiteral (map (second (valueToJs m e)) ps)]-valueToJs m e (Constructor name) = qualifiedToJS runProperName name+valueToJs _ _ (Constructor name) = qualifiedToJS runProperName name valueToJs m e (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map (statementToJs m e) sts))) [] valueToJs m e (Case value binders) = runGen (bindersToJs m e binders (valueToJs m e value)) valueToJs m e (IfThenElse cond th el) = JSConditional (valueToJs m e cond) (valueToJs m e th) (valueToJs m e el)@@ -90,12 +85,14 @@   Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS identToJs (Qualified aliasModule aliasIdent)   _ -> qualifiedToJS identToJs ident valueToJs m e (TypedValue val _) = valueToJs m e val+valueToJs _ _ _ = error "Invalid argument to valueToJs"  qualifiedToJS :: (a -> String) -> Qualified a -> JS qualifiedToJS f (Qualified (ModulePath parts) a) =   delimited (f a : reverse (map show parts))  where delimited [part]       = JSVar (Ident (part))-       delimited (part:parts) = JSAccessor part (delimited parts)+       delimited (part:parts') = JSAccessor part (delimited parts')+       delimited _            = error "Invalid argument to delimited"  bindersToJs :: ModulePath -> Environment -> [(Binder, Value)] -> JS -> Gen JS bindersToJs m e binders val = do@@ -105,7 +102,7 @@                  [val]  binderToJs :: ModulePath -> Environment -> String -> [JS] -> Binder -> Gen [JS]-binderToJs _ _ varName done NullBinder = return done+binderToJs _ _ _ done NullBinder = return done binderToJs _ _ varName done (StringBinder str) =   return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSStringLiteral str)) (JSBlock done) Nothing] binderToJs _ _ varName done (NumberBinder num) =@@ -114,9 +111,9 @@   return [JSIfElse (JSVar (Ident varName)) (JSBlock done) Nothing] binderToJs _ _ varName done (BooleanBinder False) =   return [JSIfElse (JSUnary Not (JSVar (Ident varName))) (JSBlock done) Nothing]-binderToJs _ e varName done (VarBinder ident) =+binderToJs _ _ varName done (VarBinder ident) =   return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : done)-binderToJs m e varName done (NullaryBinder ctor) =+binderToJs m _ varName done (NullaryBinder ctor) =   return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral (show (uncurry Qualified $ qualify m ctor)))) (JSBlock done) Nothing] binderToJs m e varName done (UnaryBinder ctor b) = do   value <- fresh@@ -125,11 +122,11 @@ binderToJs m e varName done (ObjectBinder bs) = go done bs   where   go :: [JS] -> [(String, Binder)] -> Gen [JS]-  go done [] = return done-  go done ((prop, binder):bs) = do+  go done' [] = return done'+  go done' ((prop, binder):bs') = do     propVar <- fresh-    done' <- go done bs-    js <- binderToJs m e propVar done' binder+    done'' <- go done' bs'+    js <- binderToJs m e propVar done'' binder     return (JSVariableIntroduction (Ident propVar) (Just (JSAccessor prop (JSVar (Ident varName)))) : js) binderToJs m e varName done (ArrayBinder bs rest) = do   js <- go done rest 0 bs@@ -138,15 +135,15 @@   cmp :: BinaryOperator   cmp = maybe EqualTo (const GreaterThanOrEqualTo) rest   go :: [JS] -> Maybe Binder -> Integer -> [Binder] -> Gen [JS]-  go done Nothing _ [] = return done-  go done (Just binder) index [] = do+  go done' Nothing _ [] = return done'+  go done' (Just binder) index [] = do     restVar <- fresh-    js <- binderToJs m e restVar done binder+    js <- binderToJs m e restVar done' binder     return (JSVariableIntroduction (Ident restVar) (Just (JSApp (JSAccessor "slice" (JSVar (Ident varName))) [JSNumericLiteral (Left index)])) : js)-  go done rest index (binder:bs) = do+  go done' rest' index (binder:bs') = do     elVar <- fresh-    done' <- go done rest (index + 1) bs-    js <- binderToJs m e elVar done' binder+    done'' <- go done' rest' (index + 1) bs'+    js <- binderToJs m e elVar done'' binder     return (JSVariableIntroduction (Ident elVar) (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar (Ident varName)))) : js) binderToJs m e varName done (NamedBinder ident binder) = do   js <- binderToJs m e varName done binder@@ -167,5 +164,5 @@   ifToJs (IfStatement cond thens elses) = JSIfElse (valueToJs m e cond) (JSBlock (map (statementToJs m e) thens)) (fmap elseToJs elses)   elseToJs :: ElseStatement -> JS   elseToJs (Else sts) = JSBlock (map (statementToJs m e) sts)-  elseToJs (ElseIf ifst) = ifToJs ifst+  elseToJs (ElseIf elif) = ifToJs elif statementToJs m e (Return value) = JSReturn (valueToJs m e value)
src/Language/PureScript/Names.hs view
@@ -44,7 +44,7 @@ data Qualified a = Qualified ModulePath a deriving (Eq, Ord, Data, Typeable)  instance (Show a) => Show (Qualified a) where-  show (Qualified (ModulePath names) a) = intercalate ":" (map show names ++ [show a])+  show (Qualified (ModulePath names) a) = intercalate "." (map show names ++ [show a])  qualify :: ModulePath -> Qualified a -> (ModulePath, a) qualify mp (Qualified (ModulePath []) a) = (mp, a)
src/Language/PureScript/Operators.hs view
@@ -22,7 +22,6 @@ import Language.PureScript.Declarations import Language.PureScript.Values -import qualified Data.Data as D import Data.Function (on) import Data.List (groupBy, sortBy) import qualified Data.Map as M@@ -62,10 +61,10 @@   where   parseChains :: Value -> Either String Value   parseChains b@(BinaryNoParens _ _ _) = bracketChain (extendChain b)-  parseChains val = return val+  parseChains other = return other   extendChain :: Value -> Chain   extendChain (BinaryNoParens name l r) = Left l : Right name : extendChain r-  extendChain val = [Left val]+  extendChain other = [Left other]   bracketChain :: Chain -> Either String Value   bracketChain = either (Left . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"   opTable = map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops
src/Language/PureScript/Optimize.hs view
@@ -29,7 +29,7 @@ replaceIdent var1 js = everywhere (mkT replace)   where   replace (JSVar var2) | var1 == var2 = js-  replace js = js+  replace other = other  isReassigned :: (Data d) => Ident -> d -> Bool isReassigned var1 = everything (||) (mkQ False check)
src/Language/PureScript/Parser/Common.hs view
@@ -16,14 +16,11 @@  module Language.PureScript.Parser.Common where -import Data.Char (isSpace)+import Data.Functor.Identity import Control.Applicative import Control.Monad-import Control.Monad.State import Language.PureScript.Parser.State-import qualified Data.Map as M import qualified Text.Parsec as P-import qualified Text.Parsec.Pos as P import qualified Text.Parsec.Token as PT  import Language.PureScript.Names@@ -92,11 +89,12 @@ identLetter = P.alphaNum <|> P.oneOf "_'"  opStart :: P.Parsec String u Char-opStart = P.oneOf "!#$%&*+/<=>?@^|~"+opStart = P.oneOf "!#%&*+/<=>?@^|~"  opLetter :: P.Parsec String u Char opLetter = P.oneOf ":#$%&*+./<=>?@^|" +langDef :: PT.GenLanguageDef String u Identity langDef = PT.LanguageDef   { PT.reservedNames   = reservedNames   , PT.reservedOpNames = reservedOpNames@@ -111,37 +109,81 @@   , PT.caseSensitive   = True   } +tokenParser :: PT.GenTokenParser String u Identity tokenParser = PT.makeTokenParser langDef -lexeme           = PT.lexeme            tokenParser-identifier       = PT.identifier        tokenParser-reserved         = PT.reserved          tokenParser-reservedOp       = PT.reservedOp        tokenParser-operator         = PT.operator          tokenParser-stringLiteral    = PT.stringLiteral     tokenParser-whiteSpace       = PT.whiteSpace        tokenParser-squares          = PT.squares           tokenParser-semi             = PT.semi              tokenParser-comma            = PT.comma             tokenParser-colon            = PT.colon             tokenParser-dot              = PT.dot               tokenParser-natural          = PT.natural           tokenParser+lexeme :: P.Parsec String u a -> P.Parsec String u a+lexeme = PT.lexeme tokenParser +identifier :: P.Parsec String u String+identifier = PT.identifier tokenParser++reserved :: String -> P.Parsec String u ()+reserved = PT.reserved tokenParser++reservedOp :: String -> P.Parsec String u ()+reservedOp = PT.reservedOp tokenParser++operator :: P.Parsec String u String+operator = PT.operator tokenParser++stringLiteral :: P.Parsec String u String+stringLiteral = PT.stringLiteral tokenParser++whiteSpace :: P.Parsec String u ()+whiteSpace = PT.whiteSpace tokenParser++semi :: P.Parsec String u String+semi = PT.semi tokenParser++colon :: P.Parsec String u String+colon = PT.colon tokenParser++dot :: P.Parsec String u String+dot = PT.dot tokenParser++comma :: P.Parsec String u String+comma = PT.comma tokenParser++tick :: P.Parsec String u Char+tick = lexeme $ P.char '`'++pipe :: P.Parsec String u Char+pipe = lexeme $ P.char '|'++natural :: P.Parsec String u Integer+natural = PT.natural tokenParser++squares :: P.Parsec String ParseState a -> P.Parsec String ParseState a+squares = P.between (lexeme $ P.char '[') (lexeme $ indented *> P.char ']') . (indented *>)++parens :: P.Parsec String ParseState a -> P.Parsec String ParseState a parens = P.between (lexeme $ P.char '(') (lexeme $ indented *> P.char ')') . (indented *>)++braces :: P.Parsec String ParseState a -> P.Parsec String ParseState a braces = P.between (lexeme $ P.char '{') (lexeme $ indented *> P.char '}') . (indented *>)++angles :: P.Parsec String ParseState a -> P.Parsec String ParseState a angles = P.between (lexeme $ P.char '<') (lexeme $ indented *> P.char '>') . (indented *>) +sepBy :: P.Parsec String ParseState a -> P.Parsec String ParseState sep -> P.Parsec String ParseState [a] sepBy p s = P.sepBy (indented *> p) (indented *> s)++sepBy1 :: P.Parsec String ParseState a -> P.Parsec String ParseState sep -> P.Parsec String ParseState [a] sepBy1 p s = P.sepBy1 (indented *> p) (indented *> s) -semiSep          = flip sepBy semi-semiSep1         = flip sepBy1 semi-commaSep         = flip sepBy comma-commaSep1        = flip sepBy1 comma+semiSep :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]+semiSep = flip sepBy semi -tick = lexeme $ P.char '`'-pipe = lexeme $ P.char '|'+semiSep1 :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]+semiSep1 = flip sepBy1 semi +commaSep :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]+commaSep = flip sepBy comma++commaSep1 :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]+commaSep1 = flip sepBy1 comma+ properName :: P.Parsec String u ProperName properName = lexeme $ ProperName <$> P.try ((:) <$> P.upper <*> many (PT.identLetter langDef) P.<?> "name") @@ -151,7 +193,7 @@   part path = (do name <- P.try (properName <* delimiter)                   part (subModule path name))               <|> (Qualified path <$> P.try parser)-  delimiter = indented *> colon <* P.notFollowedBy colon+  delimiter = indented *> dot  integerOrFloat :: P.Parsec String u (Either Integer Double) integerOrFloat = (Left <$> P.try (PT.natural tokenParser) <|>@@ -166,8 +208,16 @@   bs <- P.many more   return $ foldl combine a bs -buildPostfixParser :: P.Stream s m t => [P.ParsecT s u m (a -> a)] -> P.ParsecT s u m a -> P.ParsecT s u m a-buildPostfixParser f x = fold x (P.choice f) (flip ($))+buildPostfixParser :: P.Stream s m t => [a -> P.ParsecT s u m a] -> P.ParsecT s u m a -> P.ParsecT s u m a+buildPostfixParser fs first = do+  a <- first+  go a+  where+  go a = do+    maybeA <- P.optionMaybe $ P.choice (map ($ a) fs)+    case maybeA of+      Nothing -> return a+      Just a' -> go a'  operatorOrBuiltIn :: P.Parsec String u String operatorOrBuiltIn = P.try operator <|> P.choice (map (\s -> P.try (reservedOp s) >> return s) builtInOperators)
src/Language/PureScript/Parser/Declarations.hs view
@@ -17,20 +17,10 @@     parseDeclarations ) where -import Data.Char-import Data.List-import Data.Maybe-import Data.Function import Control.Applicative-import Control.Arrow (Arrow(..))-import Control.Monad.State-import qualified Data.Map as M import qualified Text.Parsec as P-import qualified Text.Parsec.Pos as P  import Language.PureScript.Names-import Language.PureScript.Values-import Language.PureScript.Types import Language.PureScript.Parser.State import Language.PureScript.Parser.Common import Language.PureScript.Declarations
src/Language/PureScript/Parser/State.hs view
@@ -14,11 +14,7 @@  module Language.PureScript.Parser.State where -import Language.PureScript.Names-import Language.PureScript.Declarations- import qualified Text.Parsec as P-import qualified Data.Map as M  data ParseState = ParseState   { indentationLevel :: P.Column } deriving Show
src/Language/PureScript/Parser/Types.hs view
@@ -24,7 +24,6 @@ import Control.Applicative import qualified Text.Parsec as P import qualified Text.Parsec.Expr as P-import Control.Arrow (Arrow(..)) import Control.Monad (unless)  parseNumber :: P.Parsec String ParseState Type@@ -75,8 +74,8 @@ parseAnyType :: P.Parsec String ParseState Type parseAnyType = (P.buildExpressionParser operators . buildPostfixParser postfixTable $ parseTypeAtom) P.<?> "type"   where-  postfixTable :: [P.Parsec String ParseState (Type -> Type)]-  postfixTable = [ flip TypeApp <$> P.try (indented *> parseTypeAtom) ]+  postfixTable :: [Type -> P.Parsec String ParseState Type]+  postfixTable = [ \x -> TypeApp x <$> P.try (indented *> parseTypeAtom) ]   operators = [ [ P.Infix (lexeme (P.try (P.string "->")) >> return (\t1 t2 -> Function [t1] t2)) P.AssocRight ] ]  parseType :: P.Parsec String ParseState Type
src/Language/PureScript/Parser/Values.hs view
@@ -18,21 +18,12 @@ ) where  import Language.PureScript.Values-import Language.PureScript.Names-import Language.PureScript.Declarations import Language.PureScript.Parser.State-import Data.Function (on)-import Data.List-import Data.Functor.Identity-import qualified Data.Map as M import qualified Language.PureScript.Parser.Common as C import Control.Applicative import qualified Text.Parsec as P import Text.Parsec.Expr-import Control.Monad-import Control.Arrow (Arrow(..)) import Language.PureScript.Parser.Types-import Language.PureScript.Types  booleanLiteral :: P.Parsec String ParseState Bool booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)@@ -74,10 +65,6 @@   toFunction [] value = Abs [] value   toFunction args value = foldr (($)) value args -parseApp :: P.Parsec String ParseState Value-parseApp = App <$> parseValue-               <*> (C.indented *> C.parens (C.commaSep parseValue))- parseVar :: P.Parsec String ParseState Value parseVar = Var <$> C.parseQualified C.parseIdent @@ -126,6 +113,10 @@   value <- C.indented *> parseValue   return (name, value) +parseAccessor :: Value -> P.Parsec String ParseState Value+parseAccessor (Constructor _) = P.unexpected "constructor"+parseAccessor obj = Accessor <$> (C.indented *> C.dot *> C.indented *> C.identifier) <*> pure obj+ parseValue :: P.Parsec String ParseState Value parseValue =   (buildExpressionParser operators@@ -133,11 +124,11 @@    $ indexersAndAccessors) P.<?> "expression"   where   indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom-  postfixTable1 = [ Accessor <$> (C.indented *> C.dot *> C.indented *> C.identifier)-                  , P.try $ flip ObjectUpdate <$> (C.indented *> C.braces (C.commaSep1 (C.indented *> parsePropertyUpdate))) ]-  postfixTable2 = [ P.try (C.indented *> indexersAndAccessors >>= \t2 -> return (\t1 -> App t1 [t2]))-                  , P.try $ flip App <$> (C.indented *> C.parens (C.commaSep parseValue))-                  , flip TypedValue <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) ]+  postfixTable1 = [ parseAccessor+                  , \v -> P.try $ flip ObjectUpdate <$> (C.indented *> C.braces (C.commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]+  postfixTable2 = [ \v -> P.try (C.indented *> indexersAndAccessors >>= \t2 -> return (\t1 -> App t1 [t2])) <*> pure v+                  , \v -> P.try $ flip App <$> (C.indented *> C.parens (C.commaSep parseValue)) <*> pure v+                  , \v -> flip TypedValue <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) <*> pure v ]   operators = [ [ Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "!") >> return (Unary Not)                 , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "~") >> return (Unary BitwiseNot)                 , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "-") >> return (Unary Negate)@@ -168,12 +159,12 @@ parseFor :: P.Parsec String ParseState Statement parseFor = For <$> (C.reserved "for" *> C.indented *> C.parseIdent)                <*> (C.indented *> C.lexeme (P.string "<-") *> parseValue)-               <*> (C.indented *> C.reserved "until" *> parseValue <* C.colon)+               <*> (C.indented *> C.reserved "until" *> parseValue <* C.indented <* C.colon)                <*> parseManyStatements  parseForEach :: P.Parsec String ParseState Statement parseForEach = ForEach <$> (C.reserved "foreach" *> C.indented *> C.parseIdent)-                       <*> (C.indented *> C.reserved "in" *> parseValue <* C.colon)+                       <*> (C.indented *> C.reserved "in" *> parseValue <* C.indented <* C.colon)                        <*> parseManyStatements  parseIf :: P.Parsec String ParseState Statement
src/Language/PureScript/Pretty/Common.hs view
@@ -17,20 +17,13 @@ module Language.PureScript.Pretty.Common where  import Data.Char-import Data.Maybe (fromMaybe)-import Data.List (nub, intersperse, intercalate)-import Data.Function (fix) import Control.Monad.State-import Control.Applicative (Applicative(..), Alternative(..)) import qualified Control.Category as C import Control.Category ((>>>)) import qualified Control.Arrow as A import Control.Arrow ((***), (<+>))  import Language.PureScript.Names-import Language.PureScript.Values-import Language.PureScript.Types-import Language.PureScript.Declarations  identToJs :: Ident -> String identToJs (Ident name) = name@@ -57,16 +50,16 @@ parens s = ('(':s) ++ ")"  chainl :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r-chainl split f p = fix $ \c -> split >>> ((c <+> p) *** p) >>> A.arr (uncurry f)+chainl g f p = fix $ \c -> g >>> ((c <+> p) *** p) >>> A.arr (uncurry f)  chainr :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r-chainr split f p = fix $ \c -> split >>> (p *** (c <+> p)) >>> A.arr (uncurry f)+chainr g f p = fix $ \c -> g >>> (p *** (c <+> p)) >>> A.arr (uncurry f)  wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Pattern u a r -> Pattern u a r-wrap split f p = fix $ \c -> split >>> (C.id *** (c <+> p)) >>> A.arr (uncurry f)+wrap g f p = fix $ \c -> g >>> (C.id *** (c <+> p)) >>> A.arr (uncurry f) -split :: Pattern u a (s, t) -> (s -> t -> r) -> Pattern u a r -> Pattern u a r-split s f p = s >>> A.arr (uncurry f)+split :: Pattern u a (s, t) -> (s -> t -> r) -> Pattern u a r+split s f = s >>> A.arr (uncurry f)  data OperatorTable u a r = OperatorTable { runOperatorTable :: [ [Operator u a r] ] } @@ -82,5 +75,5 @@     AssocL pat g -> chainl pat g p'     AssocR pat g -> chainr pat g p'     Wrap pat g -> wrap pat g p'-    Split pat g -> split pat g p'+    Split pat g -> split pat g   ) <+> p') p $ runOperatorTable table
src/Language/PureScript/Pretty/JS.hs view
@@ -24,7 +24,7 @@ import Data.List import Data.Maybe (fromMaybe) import qualified Control.Arrow as A-import Control.Arrow ((***), (<+>), first, second)+import Control.Arrow ((<+>)) import Control.Applicative import Control.Monad.State @@ -34,11 +34,10 @@ blockIndent = 4  withIndent :: StateT PrinterState Maybe String -> StateT PrinterState Maybe String-withIndent s = do-  current <- get-  modify $ \s -> s { indent = indent s + blockIndent }-  result <- s-  modify $ \s -> s { indent = indent s - blockIndent }+withIndent action = do+  modify $ \st -> st { indent = indent st + blockIndent }+  result <- action+  modify $ \st -> st { indent = indent st - blockIndent }   return result  currentIndent :: StateT PrinterState Maybe String@@ -158,22 +157,22 @@   match _ = mzero  unary :: UnaryOperator -> String -> Operator PrinterState JS String-unary op str = Wrap pattern (++)+unary op str = Wrap match (++)   where-  pattern :: Pattern PrinterState JS (String, JS)-  pattern = mkPattern match+  match :: Pattern PrinterState JS (String, JS)+  match = mkPattern match'     where-    match (JSUnary op' val) | op' == op = Just (str, val)-    match _ = Nothing+    match' (JSUnary op' val) | op' == op = Just (str, val)+    match' _ = Nothing  binary :: BinaryOperator -> String -> Operator PrinterState JS String-binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)+binary op str = AssocR match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)   where-  pattern :: Pattern PrinterState JS (JS, JS)-  pattern = mkPattern match+  match :: Pattern PrinterState JS (JS, JS)+  match = mkPattern match'     where-    match (JSBinary op' v1 v2) | op' == op = Just (v1, v2)-    match _ = Nothing+    match' (JSBinary op' v1 v2) | op' == op = Just (v1, v2)+    match' _ = Nothing  prettyPrintJS1 :: JS -> String prettyPrintJS1 = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'
src/Language/PureScript/Pretty/Kinds.hs view
@@ -17,15 +17,11 @@ ) where  import Data.Maybe (fromMaybe)-import Data.List (intersperse, intercalate)-import qualified Control.Arrow as A-import Control.Arrow ((<+>))-import qualified Data.Map as M-import Control.Applicative  import Language.PureScript.Kinds import Language.PureScript.Pretty.Common import Language.PureScript.Unknown+import Control.Arrow (ArrowPlus(..))  typeLiterals :: Pattern () Kind String typeLiterals = mkPattern match
src/Language/PureScript/Pretty/Types.hs view
@@ -18,17 +18,10 @@ ) where  import Data.Maybe (fromMaybe)-import Data.List (intersperse, intercalate)-import qualified Control.Arrow as A+import Data.List (intercalate) import Control.Arrow ((<+>))-import qualified Data.Map as M-import Control.Applicative -import Language.PureScript.Values import Language.PureScript.Types-import Language.PureScript.Names-import Language.PureScript.Declarations-import Language.PureScript.TypeChecker.Monad import Language.PureScript.Pretty.Common import Language.PureScript.Unknown @@ -49,7 +42,7 @@   match _ = Nothing  prettyPrintRow :: Row -> String-prettyPrintRow = (\(tys, tail) -> intercalate ", " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs tail) . toList []+prettyPrintRow = (\(tys, rest) -> intercalate ", " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs rest) . toList []   where   nameAndTypeToPs :: String -> Type -> String   nameAndTypeToPs name ty = name ++ " :: " ++ prettyPrintType ty@@ -58,6 +51,7 @@   tailToPs (RUnknown (Unknown u)) = " | u" ++ show u   tailToPs (RowVar var) = " | " ++ var   tailToPs (RSkolem s) = " | s" ++ show s+  tailToPs _ = error "Invalid row tail"   toList :: [(String, Type)] -> Row -> ([(String, Type)], Row)   toList tys (RCons name ty row) = toList ((name, ty):tys) row   toList tys r = (tys, r)
src/Language/PureScript/Pretty/Values.hs view
@@ -17,16 +17,12 @@     prettyPrintBinder ) where -import Data.Char import Data.Maybe (fromMaybe) import Data.List (intercalate)-import qualified Control.Arrow as A import Control.Arrow ((<+>))-import Control.Applicative  import Language.PureScript.Types import Language.PureScript.Values-import Language.PureScript.Names import Language.PureScript.Pretty.Common import Language.PureScript.Pretty.Types @@ -91,22 +87,22 @@   match _ = Nothing  unary :: UnaryOperator -> String -> Operator () Value String-unary op str = Wrap pattern (++)+unary op str = Wrap match (++)   where-  pattern :: Pattern () Value (String, Value)-  pattern = mkPattern match+  match :: Pattern () Value (String, Value)+  match = mkPattern match'     where-    match (Unary op' val) | op' == op = Just (str, val)-    match _ = Nothing+    match' (Unary op' val) | op' == op = Just (str, val)+    match' _ = Nothing  binary :: BinaryOperator -> String -> Operator () Value String-binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)+binary op str = AssocR match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)   where-  pattern :: Pattern () Value (Value, Value)-  pattern = mkPattern match+  match :: Pattern () Value (Value, Value)+  match = mkPattern match'     where-    match (Binary op' v1 v2) | op' == op = Just (v1, v2)-    match _ = Nothing+    match' (Binary op' v1 v2) | op' == op = Just (v1, v2)+    match' _ = Nothing  prettyPrintValue :: Value -> String prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue ()
src/Language/PureScript/TypeChecker.hs view
@@ -24,9 +24,7 @@ import Language.PureScript.TypeChecker.Types as T import Language.PureScript.TypeChecker.Synonyms as T -import Data.List import Data.Maybe-import Data.Function import qualified Data.Map as M  import Language.PureScript.Values@@ -35,7 +33,6 @@ import Language.PureScript.Kinds import Language.PureScript.Declarations -import Control.Monad (forM_) import Control.Monad.State import Control.Monad.Error @@ -74,7 +71,7 @@     env <- getEnv     modulePath <- checkModulePath `fmap` get     case M.lookup (modulePath, name) (names env) of-      Just ty -> throwError $ show name ++ " is already defined"+      Just _ -> throwError $ show name ++ " is already defined"       Nothing -> do         ty <- typeOf (Just name) val         putEnv (env { names = M.insert (modulePath, name) (ty, Value) (names env) })@@ -101,7 +98,7 @@   typeCheckAll rest   where     isSingleArgumentFunction (Function [_] _) = True-    isSingleArgumentFunction (ForAll _ ty) = isSingleArgumentFunction ty+    isSingleArgumentFunction (ForAll _ t) = isSingleArgumentFunction t     isSingleArgumentFunction _ = False typeCheckAll (ExternDeclaration name ty : rest) = do   rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do@@ -128,13 +125,13 @@     guardWith ("Module " ++ show modulePath ++ " does not exist") $ moduleExists env     case idents of       Nothing     -> bindIdents (map snd $ filterModule env) currentModule env-      Just idents -> bindIdents idents currentModule env+      Just idents' -> bindIdents idents' currentModule env   typeCheckAll rest  where errorMessage = (("Error in import declaration " ++ show modulePath ++ ":\n") ++)        filterModule = filter ((== modulePath) . fst) . M.keys . names        moduleExists env = not $ null $ filterModule env-       bindIdents idents currentModule env =-         forM_ idents $ \ident -> do+       bindIdents idents' currentModule env =+         forM_ idents' $ \ident -> do            guardWith (show currentModule ++ "." ++ show ident ++ " is already defined") $ (currentModule, ident) `M.notMember` names env            case (modulePath, ident) `M.lookup` names env of              Just (pt, _) -> modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias modulePath ident) (names e) })
src/Language/PureScript/TypeChecker/Kinds.hs view
@@ -19,15 +19,9 @@     kindOf ) where -import Data.List-import Data.Maybe (fromMaybe)-import Data.Function-import Data.Data- import Language.PureScript.Types import Language.PureScript.Kinds import Language.PureScript.Names-import Language.PureScript.Declarations import Language.PureScript.TypeChecker.Monad import Language.PureScript.Pretty import Language.PureScript.Unknown@@ -36,8 +30,6 @@ import Control.Monad.Error  import Control.Applicative-import Control.Arrow (Kleisli(..), (***))-import qualified Control.Category as C  import qualified Data.Map as M @@ -94,14 +86,14 @@   ks <- inferAll name m args   k <- infer name m ret   k ~~ Star-  forM ks $ \k -> k ~~ Star+  forM ks (~~ Star)   return Star infer _ m (TypeVar v) =   case M.lookup v m of     Just k -> return k     Nothing -> throwError $ "Unbound type variable " ++ v-infer (Just (name, k)) m c@(TypeConstructor v@(Qualified (ModulePath []) pn)) | name == pn = return k-infer name m (TypeConstructor v) = do+infer (Just (name, k)) _ (TypeConstructor (Qualified (ModulePath []) pn)) | name == pn = return k+infer _ _ (TypeConstructor v) = do   env <- liftCheck getEnv   modulePath <- checkModulePath `fmap` get   case M.lookup (qualify modulePath v) (types env) of@@ -116,17 +108,18 @@ infer name m (ForAll ident ty) = do   k <- fresh   infer name (M.insert ident k m) ty-infer _ m t = return Star+infer _ _ _ = return Star  inferRow :: Maybe (ProperName, Kind) -> M.Map String Kind -> Row -> Subst Kind inferRow _ m (RowVar v) = do   case M.lookup v m of     Just k -> return k     Nothing -> throwError $ "Unbound row variable " ++ v-inferRow _ m r@REmpty = return Row-inferRow name m r@(RCons _ ty row) = do+inferRow _ _ REmpty = return Row+inferRow name m (RCons _ ty row) = do   k1 <- infer name m ty   k2 <- inferRow name m row   k1 ~~ Star   k2 ~~ Row   return Row+inferRow _ _ _ = error "Invalid row in inferRow"
src/Language/PureScript/TypeChecker/Monad.hs view
@@ -25,12 +25,9 @@ import Data.Data import Data.Maybe import Data.Monoid-import Data.Typeable import Control.Applicative import Control.Monad.State import Control.Monad.Error--import Control.Arrow ((***), first, second)  import qualified Data.Map as M
src/Language/PureScript/TypeChecker/Synonyms.hs view
@@ -18,25 +18,22 @@ ) where  import Language.PureScript.Types-import Language.PureScript.Declarations import Language.PureScript.Names  import Data.Maybe (fromMaybe) import Data.Data import Data.Generics import Data.Generics.Extras-import Control.Arrow import Control.Monad.Writer import Control.Monad.Error-import qualified Data.Map as M  buildTypeSubstitution :: Qualified ProperName -> Int -> Type -> Either String (Maybe Type) buildTypeSubstitution name n = go n []   where   go :: Int -> [Type] -> Type -> Either String (Maybe Type)   go 0 args (TypeConstructor ctor) | name == ctor = return (Just $ SaturatedTypeSynonym ctor args)-  go n _ (TypeConstructor ctor) | n > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ show name-  go n args (TypeApp f arg) = go (n - 1) (arg:args) f+  go m _ (TypeConstructor ctor) | m > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ show name+  go m args (TypeApp f arg) = go (m - 1) (arg:args) f   go _ _ _ = return Nothing  saturateTypeSynonym :: (Data d) => Qualified ProperName -> Int -> d -> Either String d@@ -45,7 +42,7 @@   replace t = fmap (fromMaybe t) $ buildTypeSubstitution name n t  saturateAllTypeSynonyms :: (Data d) => [(Qualified ProperName, Int)] -> d -> Either String d-saturateAllTypeSynonyms syns d = foldM (\d (name, n) -> saturateTypeSynonym name n d) d syns+saturateAllTypeSynonyms syns d = foldM (\result (name, n) -> saturateTypeSynonym name n result) d syns
src/Language/PureScript/TypeChecker/Types.hs view
@@ -19,12 +19,10 @@ ) where  import Data.List-import Data.Maybe (isJust, fromMaybe)-import Data.Function+import Data.Maybe (fromMaybe) import qualified Data.Data as D import Data.Generics-       (extT, something, everywhere, everywhereM, everything,-        everywhereBut, mkT, mkM, mkQ, extM, extQ)+       (mkT, something, everywhere, everywhereBut, mkQ, extQ)  import Language.PureScript.Values import Language.PureScript.Types@@ -40,8 +38,7 @@ import Control.Monad.Error  import Control.Applicative-import Control.Arrow (Arrow(..), Kleisli(..), (***), (&&&), second)-import qualified Control.Category as C+import Control.Arrow (Arrow(..))  import qualified Data.Map as M @@ -60,7 +57,7 @@   apply _ t = t   unknowns (TUnknown (Unknown u)) = [u]   unknowns (SaturatedTypeSynonym _ tys) = concatMap unknowns tys-  unknowns (ForAll idents ty) = unknowns ty+  unknowns (ForAll _ ty) = unknowns ty   unknowns (Array t) = unknowns t   unknowns (Object r) = unknowns r   unknowns (Function args ret) = concatMap unknowns args ++ unknowns ret@@ -85,16 +82,16 @@       unifyRows :: [(String, Type)] -> Row -> [(String, Type)] -> Row -> Subst ()       unifyRows [] (RUnknown u) sd r = replace u (rowFromList (sd, r))       unifyRows sd r [] (RUnknown u) = replace u (rowFromList (sd, r))-      unifyRows ns@((name, ty):row) r others u@(RUnknown un) = do+      unifyRows ((name, ty):row) r others u@(RUnknown un) = do         occursCheck un ty-        forM row $ \(_, ty) -> occursCheck un ty+        forM row $ \(_, t) -> occursCheck un t         u' <- fresh         u ~~ RCons name ty u'         unifyRows row r others u'       unifyRows [] REmpty [] REmpty = return ()       unifyRows [] (RowVar v1) [] (RowVar v2) | v1 == v2 = return ()       unifyRows [] (RSkolem s1) [] (RSkolem s2) | s1 == s2 = return ()-      unifyRows sd1 r1 sd2 r2 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd1, r1)) ++ " with " ++ prettyPrintRow (rowFromList (sd2, r2)) ++ "."+      unifyRows sd3 r3 sd4 r4 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd3, r3)) ++ " with " ++ prettyPrintRow (rowFromList (sd4, r4)) ++ "."   apply s (RUnknown u) = runSubstitution s u   apply s (RCons name ty r) = RCons name (apply s ty) (apply s r)   apply _ r = r@@ -136,11 +133,11 @@   unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do     modulePath <- checkModulePath `fmap` get     guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (qualify modulePath c1 == qualify modulePath c2)-  unifyTypes' (TypeApp t1 t2) (TypeApp t3 t4) = do-    t1 `unifyTypes` t3-    t2 `unifyTypes` t4+  unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do+    t3 `unifyTypes` t5+    t4 `unifyTypes` t6   unifyTypes' (Skolem s1) (Skolem s2) | s1 == s2 = return ()-  unifyTypes' t1 t2 = throwError $ "Cannot unify " ++ prettyPrintType t1 ++ " with " ++ prettyPrintType t2 ++ "."+  unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."  isFunction :: Value -> Bool isFunction (Abs _ _) = True@@ -152,12 +149,12 @@   (ty, sub, checks) <- runSubst $ case name of         Just ident | isFunction val ->           case val of-            TypedValue val ty -> do+            TypedValue value ty -> do               kind <- liftCheck $ kindOf ty               guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star               ty' <- replaceAllTypeSynonyms ty               modulePath <- checkModulePath <$> get-              bindNames (M.singleton (modulePath, ident) (ty, LocalVariable)) $ check val ty'+              bindNames (M.singleton (modulePath, ident) (ty, LocalVariable)) $ check value ty'               return ty'             _ -> do               me <- fresh@@ -175,7 +172,7 @@   let     visibleUnknowns = nub $ unknowns ty   in-    forM_ checks $ \check -> case check of+    forM_ checks $ \c -> case c of       AnyUnifiable t -> do         let unsolvedUnknowns = nub . unknowns $ apply sub t         guardWith "Escape check fails" $ null $ unsolvedUnknowns \\ visibleUnknowns@@ -214,18 +211,18 @@ replaceAllTypeVars = foldl' (\f (name, ty) -> replaceTypeVars name ty . f) id  replaceTypeVars :: (D.Data d) => String -> Type -> d -> d-replaceTypeVars name t = everywhereBut (mkQ False isShadowed) (mkT replace)+replaceTypeVars name t = everywhereBut (mkQ False isShadowed) (mkT replaceTypeVar)   where-  replace (TypeVar v) | v == name = t-  replace t = t+  replaceTypeVar (TypeVar v) | v == name = t+  replaceTypeVar other = other   isShadowed (ForAll v _) | v == name = True   isShadowed _ = False  replaceRowVars :: (D.Data d) => String -> Row -> d -> d-replaceRowVars name r = everywhere (mkT replace)+replaceRowVars name r = everywhere (mkT replaceRowVar)   where-  replace (RowVar v) | v == name = r-  replace t = t+  replaceRowVar (RowVar v) | v == name = r+  replaceRowVar other = other  replaceAllVarsWithUnknowns :: Type -> Subst Type replaceAllVarsWithUnknowns (ForAll ident ty) = replaceVarWithUnknown ident ty >>= replaceAllVarsWithUnknowns@@ -244,14 +241,10 @@   either throwError return $ saturateAllTypeSynonyms syns d  desaturateAllTypeSynonyms :: (D.Data d) => d -> d-desaturateAllTypeSynonyms = everywhere (mkT replace)+desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)   where-  replace (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args-  replace t = t--expandAllTypeSynonyms :: Type -> Subst Type-expandAllTypeSynonyms (SaturatedTypeSynonym name args) = expandTypeSynonym name args >>= expandAllTypeSynonyms-expandAllTypeSynonyms ty = return ty+  replaceSaturatedTypeSynonym (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args+  replaceSaturatedTypeSynonym t = t  expandTypeSynonym :: Qualified ProperName -> [Type] -> Subst Type expandTypeSynonym name args = do@@ -276,9 +269,9 @@ infer' (BooleanLiteral _) = return Boolean infer' (ArrayLiteral vals) = do   ts <- mapM (infer) vals-  arr <- fresh-  forM_ ts $ \t -> arr ~~ Array t-  return arr+  els <- fresh+  forM_ ts $ \t -> els ~~ Array t+  return els infer' (Unary op val) = do   t <- infer val   inferUnary op t@@ -324,7 +317,7 @@   ret <- fresh   checkFunctionApplications ft argss ret   return ret-infer' (Var var@(Qualified mp name)) = do+infer' (Var var) = do   ty <- lookupVariable var   replaceAllTypeSynonyms ty infer' (Block ss) = do@@ -355,6 +348,7 @@   ty' <- replaceAllTypeSynonyms ty   check val ty'   return ty'+infer' _ = error "Invalid argument to infer"  inferProperty :: Type -> String -> Subst (Maybe Type) inferProperty (Object row) prop = do@@ -366,7 +360,7 @@ inferProperty (ForAll ident ty) prop = do   replaced <- replaceVarWithUnknown ident ty   inferProperty replaced prop-inferProperty _ prop = return Nothing+inferProperty _ _ = return Nothing  inferUnary :: UnaryOperator -> Type -> Subst Type inferUnary op val =@@ -487,6 +481,7 @@ inferBinder val (NamedBinder name binder) = do   m <- inferBinder val binder   return $ M.insert name val m+inferBinder _ _ = error "Invalid argument to inferBinder"  inferGuardedBinder :: Type -> Binder -> Subst (M.Map Ident Type) inferGuardedBinder val (GuardedBinder cond binder) = do@@ -511,11 +506,11 @@     _ -> return ()  checkStatement :: M.Map Ident Type -> Type -> Statement -> Subst (Bool, M.Map Ident Type)-checkStatement mass ret (VariableIntroduction name val) = do+checkStatement mass _ (VariableIntroduction name val) = do   assignVariable name   t <- infer val   return (False, M.insert name t mass)-checkStatement mass ret (Assignment ident val) = do+checkStatement mass _ (Assignment ident val) = do   t <- infer val   case M.lookup ident mass of     Nothing -> throwError $ "No local variable with name " ++ show ident@@ -567,7 +562,7 @@   bindLocalVariables (M.toList mass1) $ case (b1, ss) of     (True, []) -> return (True, mass1)     (True, _) -> throwError "Unreachable code"-    (False, ss) -> checkBlock mass1 ret ss+    (False, ss') -> checkBlock mass1 ret ss'  skolemize :: String -> Type -> Subst Type skolemize ident ty = do@@ -609,7 +604,7 @@   let (f, argss) = unfoldApplication app   ft <- infer f   checkFunctionApplications ft argss ret-check' v@(Var var@(Qualified mp name)) ty = do+check' (Var var) ty = do   ty1 <- lookupVariable var   repl <- replaceAllTypeSynonyms ty1   repl `subsumes` ty@@ -663,21 +658,21 @@   go [] ((p, _): _) _ | lax = return ()                       | otherwise = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have property " ++ p   go ((p,_):_) [] REmpty = throwError $ "Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row-  go ((p,v):ps) [] u@(RUnknown _) = do+  go ((p,v):ps') [] u@(RUnknown _) = do     ty <- infer v     rest <- fresh     u ~~ RCons p ty rest-    go ps [] rest-  go ((p,v):ps) ts r =+    go ps' [] rest+  go ((p,v):ps') ts r =     case lookup p ts of       Nothing -> do         ty <- infer v         rest <- fresh         r ~~ RCons p ty rest-        go ps ts rest+        go ps' ts rest       Just ty -> do         check v ty-        go ps (delete (p, ty) ts) r+        go ps' (delete (p, ty) ts) r   go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (Object row)  unfoldApplication :: Value -> (Value, [[Value]])
src/Language/PureScript/Types.hs view
@@ -63,7 +63,7 @@ isPolyType (Function args ret) = all isPolyType args && isPolyType ret isPolyType (TypeApp t1 t2) = isMonoType t1 && isMonoType t2 isPolyType (SaturatedTypeSynonym _ args) = all isPolyType args-isPolyType (ForAll idents ty) = isPolyType ty+isPolyType (ForAll _ ty) = isPolyType ty isPolyType _ = True  mkForAll :: [String] -> Type -> Type
src/Language/PureScript/Unknown.hs view
@@ -17,7 +17,6 @@ module Language.PureScript.Unknown where  import Data.Data-import Data.Typeable  newtype Unknown t = Unknown { runUnknown :: Int } deriving (Show, Eq, Ord, Data, Typeable)
src/Main.hs view
@@ -15,19 +15,15 @@ module Main where  import qualified Language.PureScript as P-import Data.Maybe (mapMaybe)-import Data.List (intercalate) import System.Console.CmdTheLine import Control.Applicative import Control.Monad (forM) import System.Exit (exitSuccess, exitFailure)-import qualified Text.Parsec as P import qualified System.IO.UTF8 as U-import qualified Data.Map as M  compile :: [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()-compile inputFiles outputFile externsFile = do-  asts <- fmap (fmap concat . sequence) $ forM inputFiles $ \inputFile -> do+compile input output externs = do+  asts <- fmap (fmap concat . sequence) $ forM input $ \inputFile -> do     text <- U.readFile inputFile     return $ P.runIndentParser P.parseDeclarations text   case asts of@@ -36,14 +32,14 @@       exitFailure     Right decls ->       case P.compile decls of-        Left error -> do-          U.putStrLn error+        Left err -> do+          U.putStrLn err           exitFailure         Right (js, exts, _) -> do-          case outputFile of+          case output of             Just path -> U.writeFile path js             Nothing -> U.putStrLn js-          case externsFile of+          case externs of             Nothing -> return ()             Just filePath -> U.writeFile filePath exts           exitSuccess@@ -70,4 +66,5 @@   , termDoc  = "Compiles PureScript to Javascript"   } +main :: IO () main = run (term, termInfo)