summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-01-30 04:30:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-01-30 04:30:00 (GMT)
commit2010183d742aea0de3ec425359a4a9d4d0e977ea (patch)
treeeffcff967837f5a4ad93e6388ca9115888ad338c
parentb9baaa3d13ed8d5ac0817292097b395775c0742e (diff)
version 0.3.50.3.5
-rw-r--r--libraries/prelude/prelude.purs23
-rw-r--r--purescript.cabal4
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs10
-rw-r--r--src/Language/PureScript/CodeGen/JS/AST.hs4
-rw-r--r--src/Language/PureScript/CodeGen/Optimize.hs37
-rw-r--r--src/Language/PureScript/Declarations.hs4
-rw-r--r--src/Language/PureScript/Parser/Common.hs17
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs15
-rw-r--r--src/Language/PureScript/Parser/Types.hs23
-rw-r--r--src/Language/PureScript/Pretty/Common.hs88
-rw-r--r--src/Language/PureScript/Pretty/JS.hs1
-rw-r--r--src/Language/PureScript/Pretty/Kinds.hs4
-rw-r--r--src/Language/PureScript/Pretty/Types.hs2
-rw-r--r--src/Language/PureScript/Pretty/Values.hs1
-rw-r--r--tests/Main.hs18
15 files changed, 114 insertions, 137 deletions
diff --git a/libraries/prelude/prelude.purs b/libraries/prelude/prelude.purs
index 414c4fd..334e6a6 100644
--- a/libraries/prelude/prelude.purs
+++ b/libraries/prelude/prelude.purs
@@ -495,6 +495,15 @@ module IORef where
\ };\
\}" :: forall s r. IORef s -> Eff (ref :: Ref | r) s
+
+ foreign import modifyIORef "function modifyIORef(ref) {\
+ \ return function(f) {\
+ \ return function() {\
+ \ ref.value = f(ref.value);\
+ \ };\
+ \ };\
+ \}" :: forall s r. IORef s -> (s -> s) -> Eff (ref :: Ref | r) {}
+
foreign import writeIORef "function writeIORef(ref) {\
\ return function(val) {\
\ return function() {\
@@ -540,14 +549,22 @@ module ST where
\ };\
\}" :: forall a h r. STRef h a -> Eff (st :: ST h | r) a
- foreign import modifySTRef "function modifySTRef(f) {\
- \ return function(ref) {\
+ foreign import modifySTRef "function modifySTRef(ref) {\
+ \ return function(f) {\
\ return function() {\
\ ref.value = f(ref.value);\
\ };\
\ };\
- \}" :: forall a h r. (a -> a) -> STRef h a -> Eff (st :: ST h | r) {}
+ \}" :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) {}
+ foreign import writeSTRef "function writeSTRef(ref) {\
+ \ return function(a) {\
+ \ return function() {\
+ \ ref.value = a;\
+ \ };\
+ \ };\
+ \}" :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) {}
+
foreign import runST "function runST(f) {\
\ return f;\
\}" :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a
diff --git a/purescript.cabal b/purescript.cabal
index 56778d8..8936ee9 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.3.4
+version: 0.3.5
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -17,7 +17,7 @@ data-dir: ""
library
build-depends: base >=4 && <5, cmdtheline -any, containers -any,
directory -any, filepath -any, mtl -any, parsec -any, syb -any,
- transformers -any, utf8-string -any
+ transformers -any, utf8-string -any, pattern-arrows -any
exposed-modules: Data.Generics.Extras
Language.PureScript
Language.PureScript.Options
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 4fed12e..d656e70 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -41,13 +41,13 @@ import Language.PureScript.Options
import Language.PureScript.CodeGen.JS.AST as AST
import Language.PureScript.Types
import Language.PureScript.CodeGen.Optimize
+import Language.PureScript.TypeChecker.Monad (canonicalizeType)
-- |
-- Generate code in the simplified Javascript intermediate representation for all declarations in a module
--
moduleToJs :: Options -> Module -> Environment -> [JS]
moduleToJs opts (Module pname@(ProperName name) decls) env =
- mapMaybe filterRawDecls decls ++
[ JSVariableIntroduction (Ident name) Nothing
, JSApp (JSFunction Nothing [Ident name]
(JSBlock (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts (ModuleName pname) decl env) (sortBy typeClassesLast decls))))
@@ -55,8 +55,6 @@ moduleToJs opts (Module pname@(ProperName name) decls) env =
(JSBinary Or (JSVar (Ident name)) (JSObjectLiteral []))]
]
where
- filterRawDecls (ExternDeclaration ForeignImport _ (Just js) _) = Just js
- filterRawDecls _ = Nothing
typeClassesLast (ExternDeclaration TypeClassDictionaryImport _ _ _) (ExternDeclaration TypeClassDictionaryImport _ _ _) = EQ
typeClassesLast (ExternDeclaration TypeClassDictionaryImport _ _ _) _ = GT
typeClassesLast _ (ExternDeclaration TypeClassDictionaryImport _ _ _) = LT
@@ -87,7 +85,7 @@ declToJs _ mp (DataDeclaration _ _ ctors) _ =
in [ ctorJs, setProperty ctor (JSVar (Ident ctor)) mp ]
declToJs opts mp (DataBindingGroupDeclaration ds) e =
Just $ concat $ mapMaybe (flip (declToJs opts mp) e) ds
-declToJs _ mp (ExternDeclaration importTy ident (Just js) _) _ | importTy /= ForeignImport =
+declToJs _ mp (ExternDeclaration importTy ident (Just js) _) _ =
Just [ js
, setProperty (identToJs ident) (JSVar ident) mp ]
declToJs _ _ _ _ = Nothing
@@ -201,7 +199,7 @@ binderToJs m e varName done (NullaryBinder ctor) =
then
return done
else
- return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock done) Nothing]
+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ canonicalizeType m e ctor)))) (JSBlock done) Nothing]
binderToJs m e varName done (UnaryBinder ctor b) = do
value <- fresh
js <- binderToJs m e value done b
@@ -210,7 +208,7 @@ binderToJs m e varName done (UnaryBinder ctor b) = do
then
return [success]
else
- return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor))))
+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ canonicalizeType m e ctor))))
success
Nothing]
binderToJs m e varName done (ObjectBinder bs) = go done bs
diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs
index 58a8fa9..05454e2 100644
--- a/src/Language/PureScript/CodeGen/JS/AST.hs
+++ b/src/Language/PureScript/CodeGen/JS/AST.hs
@@ -129,7 +129,7 @@ data JS
-- |
-- Raw Javascript (generated when parsing fails for an inline foreign import declaration)
--
- | JSRaw String deriving (Show, Data, Typeable)
+ | JSRaw String deriving (Show, Eq, Data, Typeable)
-- |
-- Data type for expressions which can appear on the left hand side of an assignment
@@ -142,4 +142,4 @@ data JSAssignment
-- |
-- Assign an object property
--
- | JSAssignProperty String JSAssignment deriving (Show, Data, Typeable)
+ | JSAssignProperty String JSAssignment deriving (Show, Eq, Data, Typeable)
diff --git a/src/Language/PureScript/CodeGen/Optimize.hs b/src/Language/PureScript/CodeGen/Optimize.hs
index 5308425..581b81d 100644
--- a/src/Language/PureScript/CodeGen/Optimize.hs
+++ b/src/Language/PureScript/CodeGen/Optimize.hs
@@ -27,6 +27,8 @@
--
-- * Inlining variables
--
+-- * Inline Prelude.($)
+--
-----------------------------------------------------------------------------
module Language.PureScript.CodeGen.Optimize (
@@ -49,14 +51,24 @@ import Language.PureScript.Types (Type(..))
-- Apply a series of optimizer passes to simplified Javascript code
--
optimize :: Options -> JS -> JS
-optimize opts =
- collapseNestedBlocks
- . tco opts
- . magicDo opts
- . removeUnusedVariables
- . unThunk
- . etaConvert
- . inlineVariables
+optimize opts = untilFixedPoint $ applyAll
+ [ collapseNestedBlocks
+ , tco opts
+ , magicDo opts
+ , removeUnusedVariables
+ , unThunk
+ , etaConvert
+ , inlineVariables
+ , inlineDollar ]
+
+applyAll :: [a -> a] -> a -> a
+applyAll = foldl1 (.)
+
+untilFixedPoint :: (Eq a) => (a -> a) -> a -> a
+untilFixedPoint f a = go a
+ where
+ go a' = let a'' = f a' in
+ if a'' == a' then a'' else go a''
replaceIdent :: (Data d) => Ident -> JS -> d -> d
replaceIdent var1 js = everywhere (mkT replace)
@@ -279,3 +291,12 @@ collapseNestedBlocks = everywhere (mkT collapse)
go :: JS -> [JS]
go (JSBlock sts) = sts
go s = [s]
+
+inlineDollar :: JS -> JS
+inlineDollar = everywhere (mkT convert)
+ where
+ convert :: JS -> JS
+ convert (JSApp (JSApp dollar [f]) [x]) | isDollar dollar = JSApp f [x]
+ convert other = other
+ isDollar (JSAccessor name (JSVar (Ident "Prelude"))) | name == identToJs (Op "$") = True
+ isDollar _ = False
diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs
index 3df4ec3..f81f48f 100644
--- a/src/Language/PureScript/Declarations.hs
+++ b/src/Language/PureScript/Declarations.hs
@@ -53,6 +53,10 @@ data ForeignImportType
--
= ForeignImport
-- |
+ -- A foreign import which contains inline Javascript as a string literal
+ --
+ | InlineJavascript
+ -- |
-- A type class dictionary import, generated during desugaring of type class declarations
--
| TypeClassDictionaryImport
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index 43b283c..c8f8f61 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -78,7 +78,9 @@ reservedNames = [ "case"
, "let"
, "class"
, "instance"
- , "where" ]
+ , "where"
+ , "null"
+ , "undefined" ]
-- |
-- A list of built-in operator names
@@ -266,6 +268,19 @@ operatorOrBuiltIn = P.try operator <|> P.choice (map (\s -> P.try (reservedOp s)
parseIdent :: P.Parsec String ParseState Ident
parseIdent = (Ident <$> identifier) <|> (Op <$> parens operatorOrBuiltIn)
+
+-- |
+-- Parse an identifier or parenthesized operator that is not a reserved keyword or operator
+--
+parseNonReservedIdent :: P.Parsec String ParseState Ident
+parseNonReservedIdent = do
+ ident <- parseIdent
+ when (isReserved ident) $ P.unexpected $ "reserved identifier " ++ show ident
+ return ident
+ where
+ isReserved (Ident ident) = ident `elem` reservedNames
+ isReserved (Op op) = op `elem` reservedOpNames
+
-- |
-- Parse a token inside square brackets
--
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 9fee7cc..818c6ed 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -19,7 +19,8 @@ module Language.PureScript.Parser.Declarations (
parseModules
) where
-import Data.Maybe (fromMaybe)
+import Data.Maybe (isJust, fromMaybe)
+import Control.Monad (when)
import Control.Applicative
import qualified Text.Parsec as P
@@ -45,7 +46,7 @@ parseDataDeclaration = do
parseTypeDeclaration :: P.Parsec String ParseState Declaration
parseTypeDeclaration =
- TypeDeclaration <$> P.try (parseIdent <* lexeme (indented *> P.string "::"))
+ TypeDeclaration <$> P.try (parseNonReservedIdent <* lexeme (indented *> P.string "::"))
<*> parsePolyType
parseTypeSynonymDeclaration :: P.Parsec String ParseState Declaration
@@ -56,7 +57,7 @@ parseTypeSynonymDeclaration =
parseValueDeclaration :: P.Parsec String ParseState Declaration
parseValueDeclaration =
- ValueDeclaration <$> parseIdent
+ ValueDeclaration <$> parseNonReservedIdent
<*> P.many parseTopLevelBinder
<*> P.optionMaybe parseGuard
<*> ((lexeme (indented *> P.char '=')) *> parseValue)
@@ -68,10 +69,10 @@ parseExternDeclaration :: P.Parsec String ParseState Declaration
parseExternDeclaration = P.try (reserved "foreign") *> indented *> (reserved "import") *> indented *>
(ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)
<*> (lexeme (indented *> P.string "::") *> parseKind)
- <|> ExternDeclaration ForeignImport <$> parseIdent
- <*> P.optionMaybe (parseJSLiteral <$> stringLiteral)
- <*> (lexeme (indented *> P.string "::") *> parsePolyType))
-
+ <|> do ident <- parseNonReservedIdent
+ js <- P.optionMaybe (parseJSLiteral <$> stringLiteral)
+ ty <- (lexeme (indented *> P.string "::") *> parsePolyType)
+ return $ ExternDeclaration (if isJust js then InlineJavascript else ForeignImport) ident js ty)
parseJSLiteral :: String -> JS
parseJSLiteral s = either (const $ JSRaw s) id $ P.runParser parseJS () "Javascript" s
diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
index 970e39a..3bffac5 100644
--- a/src/Language/PureScript/Parser/Types.hs
+++ b/src/Language/PureScript/Parser/Types.hs
@@ -24,7 +24,7 @@ import Language.PureScript.Parser.Common
import Control.Applicative
import qualified Text.Parsec as P
import qualified Text.Parsec.Expr as P
-import Control.Monad (unless)
+import Control.Monad (when, unless)
parseNumber :: P.Parsec String ParseState Type
parseNumber = const Number <$> reserved "Number"
@@ -42,7 +42,7 @@ parseArrayOf :: P.Parsec String ParseState Type
parseArrayOf = squares $ TypeApp Array <$> parseType
parseObject :: P.Parsec String ParseState Type
-parseObject = braces $ Object <$> parseRow
+parseObject = braces $ Object <$> parseRow False
parseFunction :: P.Parsec String ParseState Type
parseFunction = do
@@ -69,11 +69,10 @@ parseTypeAtom = indented *> P.choice (map P.try
, parseArray
, parseArrayOf
, parseObject
- , parseFunction
, parseTypeVariable
, parseTypeConstructor
, parseForAll
- , parens parseRow
+ , parens (parseRow True)
, parens parseType ])
parseConstrainedType :: P.Parsec String ParseState Type
@@ -91,11 +90,10 @@ parseConstrainedType = do
return $ maybe ty (flip ConstrainedType ty) constraints
parseAnyType :: P.Parsec String ParseState Type
-parseAnyType = (P.buildExpressionParser operators . buildPostfixParser postfixTable $ parseTypeAtom) P.<?> "type"
+parseAnyType = (P.buildExpressionParser operators $ parseTypeAtom) <|> parseFunction P.<?> "type"
where
- 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 ] ]
+ operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]
+ , [ P.Infix (P.try (lexeme (P.string "->")) >> return (\t1 t2 -> Function [t1] t2)) P.AssocRight ] ]
-- |
-- Parse a monotype
@@ -121,9 +119,6 @@ parseNameAndType p = (,) <$> (indented *> identifier <* indented <* lexeme (P.st
parseRowEnding :: P.Parsec String ParseState Type
parseRowEnding = P.option REmpty (TypeVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier))
-parseRow :: P.Parsec String ParseState Type
-parseRow = (fromList <$> (commaSep $ parseNameAndType parsePolyType) <*> parseRowEnding) P.<?> "row"
- where
- fromList :: [(String, Type)] -> Type -> Type
- fromList [] r = r
- fromList ((name, t):ts) r = RCons name t (fromList ts r)
+parseRow :: Bool -> P.Parsec String ParseState Type
+parseRow nonEmpty = (curry rowFromList <$> (many $ parseNameAndType parsePolyType) <*> parseRowEnding) P.<?> "row"
+ where many = if nonEmpty then commaSep1 else commaSep
diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs
index 82d6592..e57a10b 100644
--- a/src/Language/PureScript/Pretty/Common.hs
+++ b/src/Language/PureScript/Pretty/Common.hs
@@ -43,95 +43,7 @@ identCharToString '_' = "_"
identCharToString c = '$' : show (ord c)
-- |
--- A first-order pattern match
---
--- A pattern is a Kleisli arrow for the @StateT Maybe@ monad. That is, patterns can fail, and can carry user-defined state.
---
-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 u a) where
- fmap f (Pattern p) = Pattern $ A.Kleisli $ fmap f . A.runKleisli p
-
--- |
--- Run a pattern with an input and initial user state
---
--- Returns Nothing if the pattern fails to match
---
-pattern :: Pattern u a b -> u -> a -> Maybe b
-pattern p u = flip evalStateT u . A.runKleisli (runPattern p)
-
--- |
--- Construct a pattern from a function
---
-mkPattern :: (a -> Maybe b) -> Pattern u a b
-mkPattern f = Pattern $ A.Kleisli (lift . f)
-
--- |
--- Construct a pattern from a stateful function
---
-mkPattern' :: (a -> StateT u Maybe b) -> Pattern u a b
-mkPattern' = Pattern . A.Kleisli
-
--- |
-- Wrap a string in parentheses
--
parens :: String -> String
parens s = ('(':s) ++ ")"
-
--- |
--- Construct a pattern which recursively matches on the left-hand-side
---
-chainl :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r
-chainl g f p = fix $ \c -> g >>> ((c <+> p) *** p) >>> A.arr (uncurry f)
-
--- |
--- Construct a pattern which recursively matches on the right-hand side
---
-chainr :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r
-chainr g f p = fix $ \c -> g >>> (p *** (c <+> p)) >>> A.arr (uncurry f)
-
--- |
--- Construct a pattern which recursively matches on one-side of a tuple
---
-wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Pattern u a r -> Pattern u a r
-wrap g f p = fix $ \c -> g >>> (C.id *** (c <+> p)) >>> A.arr (uncurry f)
-
--- |
--- Construct a pattern which matches a part of a tuple
---
-split :: Pattern u a (s, t) -> (s -> t -> r) -> Pattern u a r
-split s f = s >>> A.arr (uncurry f)
-
--- |
--- A table of operators
---
-data OperatorTable u a r = OperatorTable { runOperatorTable :: [ [Operator u a r] ] }
-
--- |
--- An operator:
---
--- [@AssocL@] A left-associative operator
---
--- [@AssocR@] A right-associative operator
---
--- [@Wrap@] A prefix-like or postfix-like operator
---
--- [@Split@] A prefix-like or postfix-like operator which does not recurse into its operand
---
-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
-
--- |
--- Build a pretty printer from an operator table and an indecomposable pattern
---
-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'
- AssocR pat g -> chainr pat g p'
- Wrap pat g -> wrap 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 de85700..668efdc 100644
--- a/src/Language/PureScript/Pretty/JS.hs
+++ b/src/Language/PureScript/Pretty/JS.hs
@@ -26,6 +26,7 @@ import Data.List
import Data.Maybe (fromMaybe)
import qualified Control.Arrow as A
import Control.Arrow ((<+>))
+import Control.PatternArrows
import Control.Applicative
import Control.Monad.State
diff --git a/src/Language/PureScript/Pretty/Kinds.hs b/src/Language/PureScript/Pretty/Kinds.hs
index cf5f8a2..b9fa742 100644
--- a/src/Language/PureScript/Pretty/Kinds.hs
+++ b/src/Language/PureScript/Pretty/Kinds.hs
@@ -19,10 +19,12 @@ module Language.PureScript.Pretty.Kinds (
import Data.Maybe (fromMaybe)
+import Control.Arrow (ArrowPlus(..))
+import Control.PatternArrows
+
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 5f2da8d..d694ca5 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -20,7 +20,9 @@ module Language.PureScript.Pretty.Types (
import Data.Maybe (fromMaybe)
import Data.List (intercalate)
+
import Control.Arrow ((<+>))
+import Control.PatternArrows
import Language.PureScript.Types
import Language.PureScript.Pretty.Common
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index 554edd8..170c91c 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -21,6 +21,7 @@ module Language.PureScript.Pretty.Values (
import Data.Maybe (fromMaybe)
import Data.List (intercalate)
import Control.Arrow ((<+>))
+import Control.PatternArrows
import Language.PureScript.Types
import Language.PureScript.Values
diff --git a/tests/Main.hs b/tests/Main.hs
index 5fc4b34..1897c99 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -19,12 +19,14 @@ module Main (main) where
import qualified Language.PureScript as P
import Data.List (isSuffixOf)
+import Data.Traversable (traverse)
import Control.Applicative
import Control.Monad
+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
import System.Exit
import System.Process
import System.FilePath (pathSeparator)
-import System.Directory (getCurrentDirectory, getDirectoryContents)
+import System.Directory (getCurrentDirectory, getDirectoryContents, findExecutable)
import System.Environment (getArgs)
import Text.Parsec (ParseError)
import qualified Paths_purescript as Paths
@@ -68,12 +70,18 @@ assertCompiles inputFile = do
args <- getArgs
if "--run-js" `elem` args
then do
- (exitCode, out, err) <- readProcessWithExitCode "nodejs" [] js
- case exitCode of
- ExitSuccess -> putStrLn out >> return Nothing
- ExitFailure code -> return $ Just err
+ process <- findNodeProcess
+ result <- traverse (\node -> readProcessWithExitCode node [] js) process
+ case result of
+ Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing
+ Just (ExitFailure _, _, err) -> return $ Just err
+ Nothing -> return $ Just "Couldn't find node.js executable"
else return Nothing
+findNodeProcess :: IO (Maybe String)
+findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names
+ where names = ["nodejs", "node"]
+
assertDoesNotCompile :: FilePath -> IO ()
assertDoesNotCompile inputFile = do
putStrLn $ "assert " ++ inputFile ++ " does not compile"