packages feed

purescript 0.1.8 → 0.1.9

raw patch · 18 files changed

+406/−206 lines, 18 files

Files

purescript.cabal view
@@ -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 @@     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 @@     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,
+ src/Data/Generics/Extras.hs view
@@ -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
src/Language/PureScript.hs view
@@ -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.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)
src/Language/PureScript/CodeGen/JS.hs view
@@ -36,10 +36,10 @@ 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
+ src/Language/PureScript/Operators.hs view
@@ -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)+           ]+
src/Language/PureScript/Parser/Common.hs view
@@ -75,9 +75,12 @@                 , "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.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 @@ 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 = 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) ""
src/Language/PureScript/Parser/Declarations.hs view
@@ -85,9 +85,6 @@   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
src/Language/PureScript/Parser/State.hs view
@@ -21,7 +21,6 @@ import qualified Data.Map as M  data ParseState = ParseState-  { indentationLevel :: P.Column-  , fixities :: M.Map String Fixity } deriving Show+  { indentationLevel :: P.Column } deriving Show
src/Language/PureScript/Parser/Values.hs view
@@ -117,7 +117,7 @@             , parseBlock             , parseCase             , parseIfThenElse-            , C.parens parseValue ]+            , Parens <$> C.parens parseValue ]  parsePropertyUpdate :: P.Parsec String ParseState (String, Value) parsePropertyUpdate = do@@ -127,9 +127,8 @@   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,54 +138,13 @@   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
src/Language/PureScript/Pretty/Common.hs view
@@ -39,38 +39,44 @@   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'
src/Language/PureScript/Pretty/JS.hs view
@@ -25,94 +25,171 @@ 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 @@                         ++ 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          ">" ]
src/Language/PureScript/Pretty/Kinds.hs view
@@ -26,25 +26,25 @@ 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 ] ]
src/Language/PureScript/Pretty/Types.hs view
@@ -32,8 +32,8 @@ 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 @@   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
src/Language/PureScript/Pretty/Values.hs view
@@ -29,8 +29,8 @@ 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 @@ 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 ++ " }" ]
src/Language/PureScript/TypeChecker/Synonyms.hs view
@@ -12,8 +12,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE Rank2Types #-}- module Language.PureScript.TypeChecker.Synonyms (     saturateTypeSynonym,     saturateAllTypeSynonyms@@ -26,6 +24,7 @@ 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@@ -39,11 +38,6 @@   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 _ _ _ = 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)
src/Language/PureScript/Values.hs view
@@ -54,6 +54,8 @@   | BooleanLiteral Bool   | Unary UnaryOperator Value   | Binary BinaryOperator Value Value+  | BinaryNoParens (Qualified Ident) Value Value+  | Parens Value   | ArrayLiteral [Value]   | Indexer Value Value   | ObjectLiteral [(String, Value)]
src/Main.hs view
@@ -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 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]
tests/Main.hs view
@@ -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 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