summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2013-12-07 05:20:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2013-12-07 05:20:00 (GMT)
commit85a7deed23509180aaa3389b5ce1de7f238fcc69 (patch)
treef4bc0e9cd3b6c549c9b3c3c9703854fb1e67b8ad
parenta701e073703d78942a375e156d89ff1763b96bf6 (diff)
version 0.1.150.1.15
-rw-r--r--purescript.cabal43
-rw-r--r--src/Data/Generics/Extras.hs2
-rw-r--r--src/Language/PureScript/CodeGen/Externs.hs7
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs65
-rw-r--r--src/Language/PureScript/Names.hs2
-rw-r--r--src/Language/PureScript/Operators.hs5
-rw-r--r--src/Language/PureScript/Optimize.hs2
-rw-r--r--src/Language/PureScript/Parser/Common.hs104
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs10
-rw-r--r--src/Language/PureScript/Parser/State.hs4
-rw-r--r--src/Language/PureScript/Parser/Types.hs5
-rw-r--r--src/Language/PureScript/Parser/Values.hs31
-rw-r--r--src/Language/PureScript/Pretty/Common.hs19
-rw-r--r--src/Language/PureScript/Pretty/JS.hs31
-rw-r--r--src/Language/PureScript/Pretty/Kinds.hs6
-rw-r--r--src/Language/PureScript/Pretty/Types.hs12
-rw-r--r--src/Language/PureScript/Pretty/Values.hs24
-rw-r--r--src/Language/PureScript/TypeChecker.hs13
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs21
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs3
-rw-r--r--src/Language/PureScript/TypeChecker/Synonyms.hs9
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs83
-rw-r--r--src/Language/PureScript/Types.hs2
-rw-r--r--src/Language/PureScript/Unknown.hs1
-rw-r--r--src/Main.hs17
25 files changed, 247 insertions, 274 deletions
diff --git a/purescript.cabal b/purescript.cabal
index 0f6dbb3..2b9e70a 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -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 @@ author: Phil Freeman <paf31@cantab.net>
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
diff --git a/src/Data/Generics/Extras.hs b/src/Data/Generics/Extras.hs
index 89d05f0..02db199 100644
--- a/src/Data/Generics/Extras.hs
+++ b/src/Data/Generics/Extras.hs
@@ -18,7 +18,7 @@ module Data.Generics.Extras where
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
diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs
index eacd224..b5bcc28 100644
--- a/src/Language/PureScript/CodeGen/Externs.hs
+++ b/src/Language/PureScript/CodeGen/Externs.hs
@@ -16,7 +16,6 @@ module Language.PureScript.CodeGen.Externs (
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 (ValueDeclaration name _) = do
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)
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 12b2068..7c4bef3 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -17,17 +17,12 @@ module Language.PureScript.CodeGen.JS (
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.CodeGen.JS.AST as AST
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 @@ declToJs mod mp (DataDeclaration _ _ ctors) _ =
(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 _ _ (BooleanLiteral b) = JSBooleanLiteral b
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 @@ valueToJs m e (Var ident) = case M.lookup (qualify m ident) (names e) of
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 @@ bindersToJs m e binders val = do
[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 @@ binderToJs _ _ varName done (BooleanBinder True) =
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 (UnaryBinder ctor b) = do
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 @@ binderToJs m e varName done (ArrayBinder bs rest) = do
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 @@ statementToJs m e (If ifst) = ifToJs ifst
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)
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index ebbe063..714a027 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -44,7 +44,7 @@ global = ModulePath []
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)
diff --git a/src/Language/PureScript/Operators.hs b/src/Language/PureScript/Operators.hs
index f957315..295f775 100644
--- a/src/Language/PureScript/Operators.hs
+++ b/src/Language/PureScript/Operators.hs
@@ -22,7 +22,6 @@ import Language.PureScript.Names
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 @@ matchOperators ops val = G.everywhereM' (G.mkM parseChains) val
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
diff --git a/src/Language/PureScript/Optimize.hs b/src/Language/PureScript/Optimize.hs
index c14034c..537a1ae 100644
--- a/src/Language/PureScript/Optimize.hs
+++ b/src/Language/PureScript/Optimize.hs
@@ -29,7 +29,7 @@ replaceIdent :: (Data d) => Ident -> JS -> d -> d
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)
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index 7f202de..a7c64c4 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -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.Parsec String u Char
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,36 +109,80 @@ langDef = PT.LanguageDef
, 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 @@ parseQualified parser = part global
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 @@ fold first more combine = do
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)
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index d8c270b..0345ce0 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -17,20 +17,10 @@ module Language.PureScript.Parser.Declarations (
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
diff --git a/src/Language/PureScript/Parser/State.hs b/src/Language/PureScript/Parser/State.hs
index 94cf567..e20cb1d 100644
--- a/src/Language/PureScript/Parser/State.hs
+++ b/src/Language/PureScript/Parser/State.hs
@@ -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
diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
index 6fa2ba4..d2bb873 100644
--- a/src/Language/PureScript/Parser/Types.hs
+++ b/src/Language/PureScript/Parser/Types.hs
@@ -24,7 +24,6 @@ import Language.PureScript.Parser.Common
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 @@ parseTypeAtom = indented *> P.choice (map P.try
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
diff --git a/src/Language/PureScript/Parser/Values.hs b/src/Language/PureScript/Parser/Values.hs
index d1ae1a8..f0e9f2d 100644
--- a/src/Language/PureScript/Parser/Values.hs
+++ b/src/Language/PureScript/Parser/Values.hs
@@ -18,21 +18,12 @@ module Language.PureScript.Parser.Values (
) 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 @@ parseAbs = do
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 @@ parsePropertyUpdate = do
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 @@ parseValue =
$ 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 @@ parseWhile = While <$> (C.reserved "while" *> C.indented *> parseValue <* C.inde
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
diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs
index 602e5b6..d9cf69d 100644
--- a/src/Language/PureScript/Pretty/Common.hs
+++ b/src/Language/PureScript/Pretty/Common.hs
@@ -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 :: String -> String
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 @@ buildPrettyPrinter table p = foldl (\p' ops -> foldl1 (<+>) (flip map ops $ \op
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
diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs
index 5d33ab1..1f07652 100644
--- a/src/Language/PureScript/Pretty/JS.hs
+++ b/src/Language/PureScript/Pretty/JS.hs
@@ -24,7 +24,7 @@ import Language.PureScript.CodeGen.JS.AST
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 :: Int
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 @@ app = mkPattern' match
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'
diff --git a/src/Language/PureScript/Pretty/Kinds.hs b/src/Language/PureScript/Pretty/Kinds.hs
index a1c9883..822d6a1 100644
--- a/src/Language/PureScript/Pretty/Kinds.hs
+++ b/src/Language/PureScript/Pretty/Kinds.hs
@@ -17,15 +17,11 @@ module Language.PureScript.Pretty.Kinds (
) 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
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
index 1babcc0..bd93195 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -18,17 +18,10 @@ module Language.PureScript.Pretty.Types (
) 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 @@ typeLiterals = mkPattern match
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 @@ prettyPrintRow = (\(tys, tail) -> intercalate ", " (map (uncurry nameAndTypeToPs
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)
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index f37c29a..07065d4 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -17,16 +17,12 @@ module Language.PureScript.Pretty.Values (
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 @@ typed = mkPattern match
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 ()
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index eff76f7..8a9e6da 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -24,9 +24,7 @@ import Language.PureScript.TypeChecker.Kinds as T
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.Names
import Language.PureScript.Kinds
import Language.PureScript.Declarations
-import Control.Monad (forM_)
import Control.Monad.State
import Control.Monad.Error
@@ -74,7 +71,7 @@ typeCheckAll (ValueDeclaration name val : rest) = do
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 (ExternMemberDeclaration member name ty : rest) = do
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 @@ typeCheckAll (ImportDeclaration modulePath idents : rest) = do
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) })
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index 440058a..ed64cc5 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -19,15 +19,9 @@ module Language.PureScript.TypeChecker.Kinds (
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.State
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 @@ infer name m (Function args ret) = do
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 (TypeApp t1 t2) = do
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"
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 7cbce6d..6f9edfa 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -25,13 +25,10 @@ import Language.PureScript.Unknown
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
data NameKind = Value | Extern | Alias ModulePath Ident | LocalVariable deriving Show
diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs
index 0c990b7..d480e4a 100644
--- a/src/Language/PureScript/TypeChecker/Synonyms.hs
+++ b/src/Language/PureScript/TypeChecker/Synonyms.hs
@@ -18,25 +18,22 @@ module Language.PureScript.TypeChecker.Synonyms (
) 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 @@ saturateTypeSynonym name n = everywhereM' (mkM replace)
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
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index ae73ce2..0ab8170 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -19,12 +19,10 @@ module Language.PureScript.TypeChecker.Types (
) 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.State
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 @@ instance Unifiable Type where
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 @@ instance Unifiable Row where
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 t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +
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 @@ typeOf name val = do
(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 @@ escapeCheck checks ty sub =
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 :: (D.Data d) => [(String, Type)] -> d -> d
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 @@ replaceAllTypeSynonyms d = do
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' (StringLiteral _) = return String
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 @@ infer' app@(App _ _) = do
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 @@ infer' (TypedValue val ty) = do
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 (SaturatedTypeSynonym name args) prop = do
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 (ArrayBinder binders rest) = do
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 @@ assignVariable name = do
_ -> 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 @@ checkBlock mass ret (s:ss) = do
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 @@ check' app@(App _ _) ret = do
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 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
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]])
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index d3af5f1..fd8d31b 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -63,7 +63,7 @@ isPolyType (Object ps) = all isPolyType (map snd . fst $ rowToList ps)
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
diff --git a/src/Language/PureScript/Unknown.hs b/src/Language/PureScript/Unknown.hs
index 9f40ab9..96e102b 100644
--- a/src/Language/PureScript/Unknown.hs
+++ b/src/Language/PureScript/Unknown.hs
@@ -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)
diff --git a/src/Main.hs b/src/Main.hs
index adada98..64a4e69 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -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 @@ compile inputFiles outputFile externsFile = do
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 @@ termInfo = defTI
, termDoc = "Compiles PureScript to Javascript"
}
+main :: IO ()
main = run (term, termInfo)