summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2013-11-15 01:57:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2013-11-15 01:57:00 (GMT)
commit084bf6f0a63c09cc45a05131606bb6a883e6e57e (patch)
tree06a2705b23777ee04f51a52beec366e5d6c454d2
parent4160746b9f7ec6d435b29e87318534ba17d9d9fb (diff)
version 0.1.90.1.9
-rw-r--r--purescript.cabal26
-rw-r--r--src/Data/Generics/Extras.hs24
-rw-r--r--src/Language/PureScript.hs13
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs4
-rw-r--r--src/Language/PureScript/Operators.hs129
-rw-r--r--src/Language/PureScript/Parser/Common.hs20
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs3
-rw-r--r--src/Language/PureScript/Parser/State.hs3
-rw-r--r--src/Language/PureScript/Parser/Values.hs54
-rw-r--r--src/Language/PureScript/Pretty/Common.hs36
-rw-r--r--src/Language/PureScript/Pretty/JS.hs181
-rw-r--r--src/Language/PureScript/Pretty/Kinds.hs14
-rw-r--r--src/Language/PureScript/Pretty/Types.hs22
-rw-r--r--src/Language/PureScript/Pretty/Values.hs46
-rw-r--r--src/Language/PureScript/TypeChecker/Synonyms.hs8
-rw-r--r--src/Language/PureScript/Values.hs2
-rw-r--r--src/Main.hs15
-rw-r--r--tests/Main.hs12
18 files changed, 406 insertions, 206 deletions
diff --git a/purescript.cabal b/purescript.cabal
index 86e7553..ed7de6e 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.1.8
+version: 0.1.9
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -17,17 +17,17 @@ library
build-depends: base >=4 && <5, syb -any, cmdtheline -any,
containers -any, mtl -any, transformers -any, parsec -any,
utf8-string -any
- exposed-modules: 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 Language.PureScript.CodeGen
- Language.PureScript.CodeGen.Externs Language.PureScript.CodeGen.JS
- Language.PureScript.CodeGen.Monad Language.PureScript.Parser
- Language.PureScript.Parser.Common
+ 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
+ Language.PureScript.CodeGen Language.PureScript.CodeGen.Externs
+ Language.PureScript.CodeGen.JS Language.PureScript.CodeGen.Monad
+ Language.PureScript.Parser Language.PureScript.Parser.Common
Language.PureScript.Parser.Declarations
Language.PureScript.Parser.Types Language.PureScript.Parser.Values
Language.PureScript.Parser.State Language.PureScript.Parser.Kinds
@@ -47,7 +47,7 @@ executable psc
main-is: Main.hs
buildable: True
hs-source-dirs: src
- other-modules: Language.PureScript.Optimize
+ other-modules:
test-suite tests
build-depends: base >=4 && <5, syb -any, directory -any,
diff --git a/src/Data/Generics/Extras.hs b/src/Data/Generics/Extras.hs
new file mode 100644
index 0000000..89d05f0
--- /dev/null
+++ b/src/Data/Generics/Extras.hs
@@ -0,0 +1,24 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Data.Generics.Extras
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE Rank2Types #-}
+
+module Data.Generics.Extras where
+
+import Data.Data
+
+everywhereM' :: (Monad m, Data d) => (forall d. (Data d) => d -> m d) -> d -> m d
+everywhereM' f x = do
+ y <- f x
+ gmapM (everywhereM' f) y
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index 1542f7b..df229aa 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -12,7 +12,7 @@
--
-----------------------------------------------------------------------------
-module Language.PureScript (module P) where
+module Language.PureScript (module P, compile) where
import Language.PureScript.Values as P
import Language.PureScript.Types as P
@@ -24,6 +24,15 @@ import Language.PureScript.CodeGen as P
import Language.PureScript.TypeChecker as P
import Language.PureScript.Pretty as P
import Language.PureScript.Optimize as P
+import Language.PureScript.Operators as P
+import Data.List (intercalate)
+import Data.Maybe (mapMaybe)
-
+compile :: [Declaration] -> Either String (String, String, Environment)
+compile decls = do
+ bracketted <- rebracket decls
+ (_, env) <- check (typeCheckAll bracketted)
+ let js = prettyPrintJS . map optimize . concat . mapMaybe (declToJs Nothing global) $ bracketted
+ let exts = intercalate "\n" . mapMaybe (externToPs 0 global env) $ bracketted
+ return (js, exts, env)
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 6fa5be8..f13bc29 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -36,10 +36,10 @@ import Language.PureScript.CodeGen.JS.AST as AST
declToJs :: Maybe Ident -> ModulePath -> Declaration -> Maybe [JS]
declToJs mod mp (ValueDeclaration ident (Abs args ret)) =
Just $ JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs mp ret)]) :
- maybe [] (return . setProperty (show ident) (JSVar ident)) mod
+ maybe [] (return . setProperty (identToJs ident) (JSVar ident)) mod
declToJs mod mp (ValueDeclaration ident val) =
Just $ JSVariableIntroduction ident (Just (valueToJs mp val)) :
- maybe [] (return . setProperty (show ident) (JSVar ident)) mod
+ maybe [] (return . setProperty (identToJs ident) (JSVar ident)) mod
declToJs mod _ (ExternMemberDeclaration member ident _) =
Just $ JSFunction (Just ident) [Ident "value"] (JSBlock [JSReturn (JSAccessor member (JSVar (Ident "value")))]) :
maybe [] (return . setProperty (show ident) (JSVar ident)) mod
diff --git a/src/Language/PureScript/Operators.hs b/src/Language/PureScript/Operators.hs
new file mode 100644
index 0000000..f957315
--- /dev/null
+++ b/src/Language/PureScript/Operators.hs
@@ -0,0 +1,129 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Operators
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE Rank2Types #-}
+
+module Language.PureScript.Operators (
+ rebracket
+) where
+
+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
+import qualified Data.Generics as G
+import qualified Data.Generics.Extras as G
+import Control.Monad.State
+import Control.Applicative
+import qualified Text.Parsec as P
+import qualified Text.Parsec.Pos as P
+import qualified Text.Parsec.Expr as P
+
+rebracket :: [Declaration] -> Either String [Declaration]
+rebracket ds = do
+ m <- collectFixities ds
+ let opTable = customOperatorTable m
+ ds' <- G.everywhereM' (G.mkM (matchOperators opTable)) ds
+ return $ G.everywhere (G.mkT removeParens) ds'
+
+removeParens :: Value -> Value
+removeParens (Parens val) = val
+removeParens val = val
+
+customOperatorTable :: M.Map (Qualified Ident) Fixity -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]]
+customOperatorTable fixities =
+ let
+ applyUserOp name t1 t2 = App (App (Var name) [t1]) [t2]
+ userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) . M.toList $ fixities
+ sorted = sortBy (compare `on` (\(_, _, p, _) -> p)) (userOps ++ builtIns)
+ groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted
+ in
+ map (map (\(name, f, _, a) -> (name, f, a))) groups
+
+type Chain = [Either Value (Qualified Ident)]
+
+matchOperators :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value
+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
+ extendChain :: Value -> Chain
+ extendChain (BinaryNoParens name l r) = Left l : Right name : extendChain r
+ extendChain val = [Left val]
+ 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
+ ++ [[P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) [t1]) [t2]))) P.AssocLeft]]
+
+toAssoc :: Associativity -> P.Assoc
+toAssoc Infixl = P.AssocLeft
+toAssoc Infixr = P.AssocRight
+
+parseValue :: P.Parsec Chain () Value
+parseValue = P.token show (const (P.initialPos "")) (either Just (const Nothing)) P.<?> "expression"
+
+parseOp :: P.Parsec Chain () (Qualified Ident)
+parseOp = P.token show (const (P.initialPos "")) (either (const Nothing) Just) P.<?> "operator"
+
+matchOp :: Qualified Ident -> P.Parsec Chain () ()
+matchOp op = do
+ ident <- parseOp
+ guard (ident == op)
+
+collectFixities :: [Declaration] -> Either String (M.Map (Qualified Ident) Fixity)
+collectFixities = go M.empty global
+ where
+ go :: M.Map (Qualified Ident) Fixity -> ModulePath -> [Declaration] -> Either String (M.Map (Qualified Ident) Fixity)
+ go m _ [] = return m
+ go m p (FixityDeclaration fixity name : rest) = do
+ let qual = Qualified p (Op name)
+ when (qual `M.member` m) (Left $ "redefined fixity for " ++ show name)
+ go (M.insert qual fixity m) p rest
+ go m p (ModuleDeclaration name decls : rest) = do
+ m' <- go m (subModule p name) decls
+ go m' p rest
+ go m p (_:ds) = go m p ds
+
+globalOp :: String -> Qualified Ident
+globalOp = Qualified global . Op
+
+builtIns :: [(Qualified Ident, Value -> Value -> Value, Precedence, Associativity)]
+builtIns = [ (globalOp "<", Binary LessThan, 3, Infixl)
+ , (globalOp "<=", Binary LessThanOrEqualTo, 3, Infixl)
+ , (globalOp ">", Binary GreaterThan, 3, Infixl)
+ , (globalOp ">=", Binary GreaterThanOrEqualTo, 3, Infixl)
+ , (globalOp "!!", flip Indexer, 4, Infixl)
+ , (globalOp "*", Binary Multiply, 5, Infixl)
+ , (globalOp "/", Binary Divide, 5, Infixl)
+ , (globalOp "%", Binary Modulus, 5, Infixl)
+ , (globalOp "++", Binary Concat, 6, Infixr)
+ , (globalOp "+", Binary Add, 7, Infixl)
+ , (globalOp "-", Binary Subtract, 7, Infixl)
+ , (globalOp "<<", Binary ShiftLeft, 8, Infixl)
+ , (globalOp ">>", Binary ShiftRight, 8, Infixl)
+ , (globalOp ">>>", Binary ZeroFillShiftRight, 8, Infixl)
+ , (globalOp "==", Binary EqualTo, 9, Infixl)
+ , (globalOp "!=", Binary NotEqualTo, 9, Infixl)
+ , (globalOp "&", Binary BitwiseAnd, 10, Infixl)
+ , (globalOp "^", Binary BitwiseXor, 10, Infixl)
+ , (globalOp "|", Binary BitwiseOr, 10, Infixl)
+ , (globalOp "&&", Binary And, 11, Infixr)
+ , (globalOp "||", Binary Or, 11, Infixr)
+ ]
+
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index fc359d3..2bfda2b 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -75,9 +75,12 @@ reservedNames = [ "case"
, "infixr"
, "module" ]
+builtInOperators :: [String]
+builtInOperators = [ "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>"
+ , "==", "!=", "&&", "||", "&", "^", "|", "!!", "!" ]
+
reservedOpNames :: [String]
-reservedOpNames = [ "!", "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>"
- , "==", "!=", "&", "^", "|", "&&", "||", "->", "!" ]
+reservedOpNames = builtInOperators ++ [ "->" ]
identStart :: P.Parsec String u Char
identStart = P.lower <|> P.oneOf "_$"
@@ -89,7 +92,7 @@ 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 ":#$%&*+./<=>?@^|"
@@ -161,11 +164,14 @@ fold first more combine = do
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 ($))
+operatorOrBuiltIn :: P.Parsec String u String
+operatorOrBuiltIn = P.try operator <|> P.choice (map (\s -> P.try (reservedOp s) >> return s) builtInOperators)
+
parseIdent :: P.Parsec String u Ident
-parseIdent = (Ident <$> identifier) <|> (Op <$> parens operator)
+parseIdent = (Ident <$> identifier) <|> (Op <$> parens operatorOrBuiltIn)
-parseIdentInfix :: P.Parsec String u Ident
-parseIdentInfix = (Ident <$> P.between tick tick identifier) <|> (Op <$> operator)
+parseIdentInfix :: P.Parsec String ParseState (Qualified Ident)
+parseIdentInfix = (P.between tick tick (parseQualified (Ident <$> identifier))) <|> parseQualified (Op <$> operatorOrBuiltIn)
mark :: P.Parsec String ParseState a -> P.Parsec String ParseState a
mark p = do
@@ -189,4 +195,4 @@ same :: P.Parsec String ParseState ()
same = checkIndentation (==) P.<?> "no indentation"
runIndentParser :: P.Parsec String ParseState a -> String -> Either P.ParseError a
-runIndentParser p = P.runParser p (ParseState 0 M.empty) ""
+runIndentParser p = P.runParser p (ParseState 0) ""
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 7933cef..a0a28ca 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -85,9 +85,6 @@ parseFixityDeclaration = do
fixity <- parseFixity
indented
name <- operator
- current <- fixities <$> P.getState
- when (name `M.member` current) (P.unexpected $ "redefined fixity for " ++ show name)
- P.modifyState $ \st -> st { fixities = M.insert name fixity current }
return $ FixityDeclaration fixity name
parseModuleDeclaration :: P.Parsec String ParseState Declaration
diff --git a/src/Language/PureScript/Parser/State.hs b/src/Language/PureScript/Parser/State.hs
index 98cf531..94cf567 100644
--- a/src/Language/PureScript/Parser/State.hs
+++ b/src/Language/PureScript/Parser/State.hs
@@ -21,7 +21,6 @@ import qualified Text.Parsec as P
import qualified Data.Map as M
data ParseState = ParseState
- { indentationLevel :: P.Column
- , fixities :: M.Map String Fixity } deriving Show
+ { indentationLevel :: P.Column } deriving Show
diff --git a/src/Language/PureScript/Parser/Values.hs b/src/Language/PureScript/Parser/Values.hs
index 4570edf..6efb254 100644
--- a/src/Language/PureScript/Parser/Values.hs
+++ b/src/Language/PureScript/Parser/Values.hs
@@ -117,7 +117,7 @@ parseValueAtom = C.indented *> P.choice
, parseBlock
, parseCase
, parseIfThenElse
- , C.parens parseValue ]
+ , Parens <$> C.parens parseValue ]
parsePropertyUpdate :: P.Parsec String ParseState (String, Value)
parsePropertyUpdate = do
@@ -127,9 +127,8 @@ parsePropertyUpdate = do
return (name, value)
parseValue :: P.Parsec String ParseState Value
-parseValue = do
- customOps <- fixities <$> P.getState
- (buildExpressionParser (operators customOps)
+parseValue =
+ (buildExpressionParser operators
. C.buildPostfixParser postfixTable2
$ indexersAndAccessors) P.<?> "expression"
where
@@ -139,55 +138,14 @@ parseValue = do
postfixTable2 = [ P.try (C.indented *> indexersAndAccessors >>= \t2 -> return (\t1 -> App t1 [t2]))
, P.try $ flip App <$> (C.indented *> C.parens (parseValue `P.sepBy` (C.indented *> C.comma)))
, flip TypedValue <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) ]
- operators user =
- [ [ Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "!") >> return (Unary Not)
+ 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)
, Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "+") >> return id ]
- ] ++ customOperatorTable user ++
- [ [ Infix (C.lexeme (P.try (C.indented *> C.parseQualified C.parseIdentInfix P.<?> "operator") >>= \ident -> return $ \t1 t2 -> App (App (Var ident) [t1]) [t2])) AssocLeft ]
- , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "!!") >> return (flip Indexer)) AssocRight ]
- , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<=") >> return (Binary LessThanOrEqualTo)) AssocRight
- , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">=") >> return (Binary GreaterThanOrEqualTo)) AssocRight ]
- , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<") >> return (Binary LessThan)) AssocRight
- , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">") >> return (Binary GreaterThan)) AssocRight ]
- , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "*") >> return (Binary Multiply)) AssocRight
- , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "/") >> return (Binary Divide)) AssocRight
- , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "%") >> return (Binary Modulus)) AssocRight ]
- , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "++") >> return (Binary Concat)) AssocRight
- , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "+") >> return (Binary Add)) AssocRight
- , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "-") >> return (Binary Subtract)) AssocRight ]
- , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<<") >> return (Binary ShiftLeft)) AssocRight
- , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">>>") >> return (Binary ZeroFillShiftRight)) AssocRight
- , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">>") >> return (Binary ShiftRight)) AssocRight ]
- , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "==") >> return (Binary EqualTo)) AssocRight
- , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "!=") >> return (Binary NotEqualTo)) AssocRight ]
- , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "&") >> return (Binary BitwiseAnd)) AssocRight ]
- , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "^") >> return (Binary BitwiseXor)) AssocRight ]
- , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "|") >> return (Binary BitwiseOr)) AssocRight ]
- , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "&&") >> return (Binary And)) AssocRight ]
- , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "||") >> return (Binary Or)) AssocRight ]
+ , [ Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident ->
+ return (BinaryNoParens ident))) AssocRight ]
]
-customOperatorTable :: M.Map String Fixity -> OperatorTable String ParseState Identity Value
-customOperatorTable fixities =
- let
- ops = map (\(name, Fixity a p) -> (name, (a, p))) . M.toList $ fixities
- sorted = sortBy (compare `on` (snd . snd)) ops
- levels = groupBy ((==) `on` (snd . snd)) sorted
- in
- map (map $ \(name, (a, _)) ->
- flip Infix (toAssoc a) $
- C.lexeme $ P.try $ do
- C.indented
- C.reservedOp name P.<?> "operator"
- return $ \t1 t2 -> App (App (Var (Qualified global (Op name))) [t1]) [t2])
- levels
-
-toAssoc :: Associativity -> Assoc
-toAssoc Infixl = AssocLeft
-toAssoc Infixr = AssocRight
-
parseVariableIntroduction :: P.Parsec String ParseState Statement
parseVariableIntroduction = do
C.reserved "var"
diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs
index f480006..602e5b6 100644
--- a/src/Language/PureScript/Pretty/Common.hs
+++ b/src/Language/PureScript/Pretty/Common.hs
@@ -39,38 +39,44 @@ identToJs (Op op) = concatMap opCharToString op
opCharToString :: Char -> String
opCharToString = (:) '$'. show . ord
-newtype Pattern a b = Pattern { runPattern :: A.Kleisli Maybe a b } deriving (C.Category, A.Arrow, A.ArrowZero, A.ArrowPlus)
+newtype Pattern u a b = Pattern { runPattern :: A.Kleisli (StateT u Maybe) a b } deriving (C.Category, A.Arrow, A.ArrowZero, A.ArrowPlus)
-instance Functor (Pattern a) where
+instance Functor (Pattern u a) where
fmap f (Pattern p) = Pattern $ A.Kleisli $ fmap f . A.runKleisli p
-pattern :: Pattern a b -> a -> Maybe b
-pattern = A.runKleisli . runPattern
+pattern :: Pattern u a b -> u -> a -> Maybe b
+pattern p u = flip evalStateT u . A.runKleisli (runPattern p)
+
+mkPattern :: (a -> Maybe b) -> Pattern u a b
+mkPattern f = Pattern $ A.Kleisli (lift . f)
+
+mkPattern' :: (a -> StateT u Maybe b) -> Pattern u a b
+mkPattern' = Pattern . A.Kleisli
parens :: String -> String
parens s = ('(':s) ++ ")"
-chainl :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r
+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)
-chainr :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r
+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)
-wrap :: Pattern a (s, a) -> (s -> r -> r) -> Pattern a r -> Pattern a r
+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)
-split :: Pattern a (s, t) -> (s -> t -> r) -> Pattern a r -> Pattern a r
+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)
-data OperatorTable a r = OperatorTable { runOperatorTable :: [ [Operator a r] ] }
+data OperatorTable u a r = OperatorTable { runOperatorTable :: [ [Operator u a r] ] }
-data Operator a r where
- AssocL :: Pattern a (a, a) -> (r -> r -> r) -> Operator a r
- AssocR :: Pattern a (a, a) -> (r -> r -> r) -> Operator a r
- Wrap :: Pattern a (s, a) -> (s -> r -> r) -> Operator a r
- Split :: Pattern a (s, t) -> (s -> t -> r) -> Operator a r
+data Operator u a r where
+ AssocL :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r
+ AssocR :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r
+ Wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Operator u a r
+ Split :: Pattern u a (s, t) -> (s -> t -> r) -> Operator u a r
-buildPrettyPrinter :: OperatorTable a r -> Pattern a r -> Pattern a r
+buildPrettyPrinter :: OperatorTable u a r -> Pattern u a r -> Pattern u a r
buildPrettyPrinter table p = foldl (\p' ops -> foldl1 (<+>) (flip map ops $ \op ->
case op of
AssocL pat g -> chainl pat g p'
diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs
index e449a25..5d33ab1 100644
--- a/src/Language/PureScript/Pretty/JS.hs
+++ b/src/Language/PureScript/Pretty/JS.hs
@@ -25,94 +25,171 @@ import Data.List
import Data.Maybe (fromMaybe)
import qualified Control.Arrow as A
import Control.Arrow ((***), (<+>), first, second)
+import Control.Applicative
+import Control.Monad.State
-literals :: Pattern JS String
-literals = Pattern $ A.Kleisli match
+newtype PrinterState = PrinterState { indent :: Int } deriving (Show, Eq, Ord)
+
+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 }
+ return result
+
+currentIndent :: StateT PrinterState Maybe String
+currentIndent = do
+ current <- get
+ return $ replicate (indent current) ' '
+
+literals :: Pattern PrinterState JS String
+literals = mkPattern' match
where
- match (JSNumericLiteral n) = Just $ either show show n
- match (JSStringLiteral s) = Just $ show s
- match (JSBooleanLiteral True) = Just "true"
- match (JSBooleanLiteral False) = Just "false"
- match (JSArrayLiteral xs) = Just $ "[" ++ intercalate ", " (map prettyPrintJS xs) ++ "]"
- match (JSObjectLiteral ps) = Just $ "{ " ++ intercalate ", " (map (\(key, value) -> key ++ ": " ++ prettyPrintJS value) ps) ++ " }"
- match (JSBlock sts) = Just $ "{ " ++ intercalate "; " (map prettyPrintJS sts) ++ " }"
- match (JSVar ident) = Just (identToJs ident)
- match (JSVariableIntroduction ident value) = Just $ "var " ++ identToJs ident ++ maybe "" ((" = " ++) . prettyPrintJS) value
- match (JSAssignment target value) = Just $ targetToJs target ++ " = " ++ prettyPrintJS value
- match (JSWhile cond sts) = Just $ "while ("
- ++ prettyPrintJS cond ++ ") "
- ++ prettyPrintJS sts
- match (JSFor ident start end sts) = Just $ "for ("
- ++ identToJs ident ++ " = " ++ prettyPrintJS start ++ "; "
- ++ identToJs ident ++ " < " ++ prettyPrintJS end ++ "; "
- ++ identToJs ident ++ "++) "
- ++ prettyPrintJS sts
- match (JSIfElse cond thens elses) = Just $ "if ("
- ++ prettyPrintJS cond ++ ") "
- ++ prettyPrintJS thens
- ++ maybe "" ((" else " ++) . prettyPrintJS) elses
- match (JSReturn value) = Just $ "return " ++ prettyPrintJS value
- match (JSThrow value) = Just $ "throw " ++ prettyPrintJS value
- match _ = Nothing
+ match :: JS -> StateT PrinterState Maybe String
+ match (JSNumericLiteral n) = return $ either show show n
+ match (JSStringLiteral s) = return $ show s
+ match (JSBooleanLiteral True) = return "true"
+ match (JSBooleanLiteral False) = return "false"
+ match (JSArrayLiteral xs) = fmap concat $ sequence
+ [ return "[ "
+ , fmap (intercalate ", ") $ forM xs prettyPrintJS'
+ , return " ]"
+ ]
+ match (JSObjectLiteral ps) = fmap concat $ sequence
+ [ return "{\n"
+ , withIndent $ do
+ jss <- forM ps $ \(key, value) -> fmap ((key ++ ": ") ++) . prettyPrintJS' $ value
+ indentString <- currentIndent
+ return $ intercalate ", \n" $ map (indentString ++) jss
+ , return "\n"
+ , currentIndent
+ , return "}"
+ ]
+ match (JSBlock sts) = fmap concat $ sequence
+ [ return "{\n"
+ , withIndent $ do
+ jss <- forM sts prettyPrintJS'
+ indentString <- currentIndent
+ return $ intercalate "\n" $ map (++ "; ") $ map (indentString ++) jss
+ , return "\n"
+ , currentIndent
+ , return "}"
+ ]
+ match (JSVar ident) = return (identToJs ident)
+ match (JSVariableIntroduction ident value) = fmap concat $ sequence
+ [ return "var "
+ , return $ identToJs ident
+ , maybe (return "") (fmap (" = " ++) . prettyPrintJS') value
+ ]
+ match (JSAssignment target value) = fmap concat $ sequence
+ [ return $ targetToJs target
+ , return " = "
+ , prettyPrintJS' value
+ ]
+ match (JSWhile cond sts) = fmap concat $ sequence
+ [ return "while ("
+ , prettyPrintJS' cond
+ , return ") "
+ , prettyPrintJS' sts
+ ]
+ match (JSFor ident start end sts) = fmap concat $ sequence
+ [ return $ "for (" ++ identToJs ident ++ " = "
+ , prettyPrintJS' start
+ , return $ "; " ++ identToJs ident ++ " < "
+ , prettyPrintJS' end
+ , return $ "; " ++ identToJs ident ++ "++) "
+ , prettyPrintJS' sts
+ ]
+ match (JSIfElse cond thens elses) = fmap concat $ sequence
+ [ return "if ("
+ , prettyPrintJS' cond
+ , return ") "
+ , prettyPrintJS' thens
+ , maybe (return "") (fmap (" else " ++) . prettyPrintJS') elses
+ ]
+ match (JSReturn value) = fmap concat $ sequence
+ [ return "return "
+ , prettyPrintJS' value
+ ]
+ match (JSThrow value) = fmap concat $ sequence
+ [ return "throw "
+ , prettyPrintJS' value
+ ]
+ match _ = mzero
targetToJs :: JSAssignment -> String
targetToJs (JSAssignVariable ident) = identToJs ident
targetToJs (JSAssignProperty prop target) = targetToJs target ++ "." ++ prop
-conditional :: Pattern JS ((JS, JS), JS)
-conditional = Pattern $ A.Kleisli match
+conditional :: Pattern PrinterState JS ((JS, JS), JS)
+conditional = mkPattern match
where
match (JSConditional cond th el) = Just ((th, el), cond)
match _ = Nothing
-accessor :: Pattern JS (String, JS)
-accessor = Pattern $ A.Kleisli match
+accessor :: Pattern PrinterState JS (String, JS)
+accessor = mkPattern match
where
match (JSAccessor prop val) = Just (prop, val)
match _ = Nothing
-indexer :: Pattern JS (String, JS)
-indexer = Pattern $ A.Kleisli match
+indexer :: Pattern PrinterState JS (String, JS)
+indexer = mkPattern' match
where
- match (JSIndexer index val) = Just (prettyPrintJS index, val)
- match _ = Nothing
+ match (JSIndexer index val) = (,) <$> prettyPrintJS' index <*> pure val
+ match _ = mzero
-lam :: Pattern JS ((Maybe Ident, [Ident]), JS)
-lam = Pattern $ A.Kleisli match
+lam :: Pattern PrinterState JS ((Maybe Ident, [Ident]), JS)
+lam = mkPattern match
where
match (JSFunction name args ret) = Just ((name, args), ret)
match _ = Nothing
-app :: Pattern JS (String, JS)
-app = Pattern $ A.Kleisli match
+app :: Pattern PrinterState JS (String, JS)
+app = mkPattern' match
where
- match (JSApp val args) = Just (intercalate "," (map prettyPrintJS args), val)
- match _ = Nothing
+ match (JSApp val args) = do
+ jss <- mapM prettyPrintJS' args
+ return (intercalate ", " jss, val)
+ match _ = mzero
-unary :: UnaryOperator -> String -> Operator JS String
+unary :: UnaryOperator -> String -> Operator PrinterState JS String
unary op str = Wrap pattern (++)
where
- pattern :: Pattern JS (String, JS)
- pattern = Pattern $ A.Kleisli match
+ pattern :: Pattern PrinterState JS (String, JS)
+ pattern = mkPattern match
where
match (JSUnary op' val) | op' == op = Just (str, val)
match _ = Nothing
-binary :: BinaryOperator -> String -> Operator JS String
+binary :: BinaryOperator -> String -> Operator PrinterState JS String
binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
where
- pattern :: Pattern JS (JS, JS)
- pattern = Pattern $ A.Kleisli match
+ pattern :: Pattern PrinterState JS (JS, JS)
+ pattern = mkPattern match
where
match (JSBinary op' v1 v2) | op' == op = Just (v1, v2)
match _ = Nothing
-prettyPrintJS :: JS -> String
-prettyPrintJS = fromMaybe (error "Incomplete pattern") . pattern matchValue
+prettyPrintJS1 :: JS -> String
+prettyPrintJS1 = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'
+
+prettyPrintJS :: [JS] -> String
+prettyPrintJS sts = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) $ do
+ jss <- forM sts prettyPrintJS'
+ indentString <- currentIndent
+ return $ intercalate "\n" $ map (++ "; ") $ map (indentString ++) jss
+
+prettyPrintJS' :: JS -> StateT PrinterState Maybe String
+prettyPrintJS' = A.runKleisli $ runPattern matchValue
where
- matchValue :: Pattern JS String
+ matchValue :: Pattern PrinterState JS String
matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
- operators :: OperatorTable JS String
+ operators :: OperatorTable PrinterState JS String
operators =
OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
, [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]
@@ -121,7 +198,7 @@ prettyPrintJS = fromMaybe (error "Incomplete pattern") . pattern matchValue
++ maybe "" identToJs name
++ "(" ++ intercalate ", " (map identToJs args) ++ ") "
++ ret ]
- , [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS th ++ " : " ++ prettyPrintJS el ]
+ , [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS1 th ++ " : " ++ prettyPrintJS1 el ]
, [ binary LessThan "<" ]
, [ binary LessThanOrEqualTo "<=" ]
, [ binary GreaterThan ">" ]
diff --git a/src/Language/PureScript/Pretty/Kinds.hs b/src/Language/PureScript/Pretty/Kinds.hs
index a002a0a..06dfb20 100644
--- a/src/Language/PureScript/Pretty/Kinds.hs
+++ b/src/Language/PureScript/Pretty/Kinds.hs
@@ -26,25 +26,25 @@ import Control.Applicative
import Language.PureScript.Kinds
import Language.PureScript.Pretty.Common
-typeLiterals :: Pattern Kind String
-typeLiterals = Pattern $ A.Kleisli match
+typeLiterals :: Pattern () Kind String
+typeLiterals = mkPattern match
where
match Star = Just "*"
match Row = Just "#"
match (KUnknown u) = Just $ 'u' : show u
match _ = Nothing
-funKind :: Pattern Kind (Kind, Kind)
-funKind = Pattern $ A.Kleisli match
+funKind :: Pattern () Kind (Kind, Kind)
+funKind = mkPattern match
where
match (FunKind arg ret) = Just (arg, ret)
match _ = Nothing
prettyPrintKind :: Kind -> String
-prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind
+prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind ()
where
- matchKind :: Pattern Kind String
+ matchKind :: Pattern () Kind String
matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)
- operators :: OperatorTable Kind String
+ operators :: OperatorTable () Kind String
operators =
OperatorTable [ [ AssocR funKind $ \arg ret -> arg ++ " -> " ++ ret ] ]
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
index 5142416..e987792 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -32,8 +32,8 @@ import Language.PureScript.Declarations
import Language.PureScript.TypeChecker.Monad
import Language.PureScript.Pretty.Common
-typeLiterals :: Pattern Type String
-typeLiterals = Pattern $ A.Kleisli match
+typeLiterals :: Pattern () Type String
+typeLiterals = mkPattern match
where
match Number = Just "Number"
match String = Just "String"
@@ -59,30 +59,30 @@ prettyPrintRow = (\(tys, tail) -> intercalate ", " (map (uncurry nameAndTypeToPs
toList tys (RCons name ty row) = toList ((name, ty):tys) row
toList tys r = (tys, r)
-typeApp :: Pattern Type (Type, Type)
-typeApp = Pattern $ A.Kleisli match
+typeApp :: Pattern () Type (Type, Type)
+typeApp = mkPattern match
where
match (TypeApp f x) = Just (f, x)
match _ = Nothing
-singleArgumentFunction :: Pattern Type (Type, Type)
-singleArgumentFunction = Pattern $ A.Kleisli match
+singleArgumentFunction :: Pattern () Type (Type, Type)
+singleArgumentFunction = mkPattern match
where
match (Function [arg] ret) = Just (arg, ret)
match _ = Nothing
-function :: Pattern Type ([Type], Type)
-function = Pattern $ A.Kleisli match
+function :: Pattern () Type ([Type], Type)
+function = mkPattern match
where
match (Function args ret) = Just (args, ret)
match _ = Nothing
prettyPrintType :: Type -> String
-prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType
+prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType ()
where
- matchType :: Pattern Type String
+ matchType :: Pattern () Type String
matchType = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchType)
- operators :: OperatorTable Type String
+ operators :: OperatorTable () Type String
operators =
OperatorTable [ [ AssocL typeApp $ \f x -> f ++ " " ++ x ]
, [ AssocR singleArgumentFunction $ \arg ret -> arg ++ " -> " ++ ret
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index eff00eb..06a2f82 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -29,8 +29,8 @@ import Language.PureScript.Values
import Language.PureScript.Names
import Language.PureScript.Pretty.Common
-literals :: Pattern Value String
-literals = Pattern $ A.Kleisli match
+literals :: Pattern () Value String
+literals = mkPattern match
where
match (NumericLiteral n) = Just $ either show show n
match (StringLiteral s) = Just $ show s
@@ -47,66 +47,66 @@ literals = Pattern $ A.Kleisli match
prettyPrintCaseAlternative :: Binder -> Value -> String
prettyPrintCaseAlternative binder val = prettyPrintBinder binder ++ " -> " ++ prettyPrintValue val
-ifThenElse :: Pattern Value ((Value, Value), Value)
-ifThenElse = Pattern $ A.Kleisli match
+ifThenElse :: Pattern () Value ((Value, Value), Value)
+ifThenElse = mkPattern match
where
match (IfThenElse cond th el) = Just ((th, el), cond)
match _ = Nothing
-accessor :: Pattern Value (String, Value)
-accessor = Pattern $ A.Kleisli match
+accessor :: Pattern () Value (String, Value)
+accessor = mkPattern match
where
match (Accessor prop val) = Just (prop, val)
match _ = Nothing
-indexer :: Pattern Value (Value, Value)
-indexer = Pattern $ A.Kleisli match
+indexer :: Pattern () Value (Value, Value)
+indexer = mkPattern match
where
match (Indexer index val) = Just (index, val)
match _ = Nothing
-objectUpdate :: Pattern Value ([String], Value)
-objectUpdate = Pattern $ A.Kleisli match
+objectUpdate :: Pattern () Value ([String], Value)
+objectUpdate = mkPattern match
where
match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)
match _ = Nothing
-app :: Pattern Value (String, Value)
-app = Pattern $ A.Kleisli match
+app :: Pattern () Value (String, Value)
+app = mkPattern match
where
match (App val args) = Just (intercalate "," (map prettyPrintValue args), val)
match _ = Nothing
-lam :: Pattern Value ([String], Value)
-lam = Pattern $ A.Kleisli match
+lam :: Pattern () Value ([String], Value)
+lam = mkPattern match
where
match (Abs args val) = Just (map show args, val)
match _ = Nothing
-unary :: UnaryOperator -> String -> Operator Value String
+unary :: UnaryOperator -> String -> Operator () Value String
unary op str = Wrap pattern (++)
where
- pattern :: Pattern Value (String, Value)
- pattern = Pattern $ A.Kleisli match
+ pattern :: Pattern () Value (String, Value)
+ pattern = mkPattern match
where
match (Unary op' val) | op' == op = Just (str, val)
match _ = Nothing
-binary :: BinaryOperator -> String -> Operator Value String
+binary :: BinaryOperator -> String -> Operator () Value String
binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
where
- pattern :: Pattern Value (Value, Value)
- pattern = Pattern $ A.Kleisli match
+ pattern :: Pattern () Value (Value, Value)
+ pattern = mkPattern match
where
match (Binary op' v1 v2) | op' == op = Just (v1, v2)
match _ = Nothing
prettyPrintValue :: Value -> String
-prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue
+prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue ()
where
- matchValue :: Pattern Value String
+ matchValue :: Pattern () Value String
matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
- operators :: OperatorTable Value String
+ operators :: OperatorTable () Value String
operators =
OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
, [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]
diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs
index 8899fef..0c990b7 100644
--- a/src/Language/PureScript/TypeChecker/Synonyms.hs
+++ b/src/Language/PureScript/TypeChecker/Synonyms.hs
@@ -12,8 +12,6 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE Rank2Types #-}
-
module Language.PureScript.TypeChecker.Synonyms (
saturateTypeSynonym,
saturateAllTypeSynonyms
@@ -26,6 +24,7 @@ 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
@@ -40,11 +39,6 @@ buildTypeSubstitution name n = go n []
go n args (TypeApp f arg) = go (n - 1) (arg:args) f
go _ _ _ = return Nothing
-everywhereM' :: (Monad m, Data d) => (forall d. (Data d) => d -> m d) -> d -> m d
-everywhereM' f x = do
- y <- f x
- gmapM (everywhereM' f) y
-
saturateTypeSynonym :: (Data d) => Qualified ProperName -> Int -> d -> Either String d
saturateTypeSynonym name n = everywhereM' (mkM replace)
where
diff --git a/src/Language/PureScript/Values.hs b/src/Language/PureScript/Values.hs
index a486173..402ec1b 100644
--- a/src/Language/PureScript/Values.hs
+++ b/src/Language/PureScript/Values.hs
@@ -54,6 +54,8 @@ data Value
| BooleanLiteral Bool
| Unary UnaryOperator Value
| Binary BinaryOperator Value Value
+ | BinaryNoParens (Qualified Ident) Value Value
+ | Parens Value
| ArrayLiteral [Value]
| Indexer Value Value
| ObjectLiteral [(String, Value)]
diff --git a/src/Main.hs b/src/Main.hs
index 4cdcdfc..adada98 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -14,7 +14,7 @@
module Main where
-import Language.PureScript
+import qualified Language.PureScript as P
import Data.Maybe (mapMaybe)
import Data.List (intercalate)
import System.Console.CmdTheLine
@@ -29,24 +29,23 @@ compile :: [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()
compile inputFiles outputFile externsFile = do
asts <- fmap (fmap concat . sequence) $ forM inputFiles $ \inputFile -> do
text <- U.readFile inputFile
- return $ runIndentParser parseDeclarations text
+ return $ P.runIndentParser P.parseDeclarations text
case asts of
Left err -> do
U.print err
exitFailure
Right decls ->
- case check (typeCheckAll decls) of
- Left typeError -> do
- U.putStrLn typeError
+ case P.compile decls of
+ Left error -> do
+ U.putStrLn error
exitFailure
- Right (_, env) -> do
- let js = intercalate "; " . map (prettyPrintJS . optimize) . concat . mapMaybe (declToJs Nothing global) $ decls
+ Right (js, exts, _) -> do
case outputFile of
Just path -> U.writeFile path js
Nothing -> U.putStrLn js
case externsFile of
Nothing -> return ()
- Just filePath -> U.writeFile filePath $ intercalate "\n" $ mapMaybe (externToPs 0 global env) decls
+ Just filePath -> U.writeFile filePath exts
exitSuccess
inputFiles :: Term [FilePath]
diff --git a/tests/Main.hs b/tests/Main.hs
index c81a374..74dfd19 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -14,7 +14,7 @@
module Main (main) where
-import Language.PureScript
+import qualified Language.PureScript as P
import Data.List (isSuffixOf)
import Control.Applicative
@@ -25,20 +25,20 @@ import System.Directory (getCurrentDirectory, getDirectoryContents)
import qualified System.IO.UTF8 as U
import qualified Data.Map as M
-compile :: FilePath -> IO (Either String Environment)
+compile :: FilePath -> IO (Either String P.Environment)
compile inputFile = do
- ast <- runIndentParser parseDeclarations <$> U.readFile inputFile
+ ast <- P.runIndentParser P.parseDeclarations <$> U.readFile inputFile
case ast of
Left parseError -> do
return (Left $ show parseError)
Right decls -> do
- case check (typeCheckAll decls) of
+ case P.compile decls of
Left typeError -> do
return (Left typeError)
- Right (_, env) -> do
+ Right (_, _, env) -> do
return (Right env)
-assert :: FilePath -> (Either String Environment -> Maybe String) -> IO ()
+assert :: FilePath -> (Either String P.Environment -> Maybe String) -> IO ()
assert inputFile f = do
e <- compile inputFile
case f e of