packages feed

purescript 0.4.5.1 → 0.4.6

raw patch · 22 files changed

+735/−344 lines, 22 filesdep +timedep ~haskeline

Dependencies added: time

Dependency ranges changed: haskeline

Files

prelude/prelude.purs view
@@ -6,18 +6,22 @@   const :: forall a b. a -> b -> a   const a _ = a +  on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c+  on f g x y = g x `f` g y+   infixr 9 >>>   infixr 9 <<<    class Category a where     id :: forall t. a t t     (<<<) :: forall b c d. a c d -> a b c -> a b d-    (>>>) :: forall b c d. a b c -> a c d -> a b d +  (>>>) :: forall a b c d. (Category a) => a b c -> a c d -> a b d+  (>>>) f g = g <<< f+   instance categoryArr :: Category (->) where     id x = x     (<<<) f g x = f (g x)-    (>>>) f g x = g (f x)    infixr 0 $   infixl 0 #@@ -172,46 +176,53 @@     (==) _ _ = false     (/=) xs ys = not (xs == ys) +  data Ordering = LT | GT | EQ++  instance showOrdering :: Show Ordering where+    show LT = "LT"+    show GT = "GT"+    show EQ = "EQ"++  class Ord a where+    compare :: a -> a -> Ordering+   infixl 4 <++  (<) :: forall a. (Ord a) => a -> a -> Boolean+  (<) a1 a2 = case a1 `compare` a2 of+    LT -> true+    _ -> false+   infixl 4 >-  infixl 4 <=-  infixl 4 >= -  class Ord a where-    (<) :: a -> a -> Boolean-    (>) :: a -> a -> Boolean-    (<=) :: a -> a -> Boolean-    (>=) :: a -> a -> Boolean+  (>) :: forall a. (Ord a) => a -> a -> Boolean+  (>) a1 a2 = case a1 `compare` a2 of+    GT -> true+    _ -> false -  foreign import numLess "function numLess(n1) {\-                         \  return function(n2) {\-                         \    return n1 < n2;\-                         \  };\-                         \}" :: Number -> Number -> Boolean+  infixl 4 <= -  foreign import numLessEq "function numLessEq(n1) {\-                           \  return function(n2) {\-                           \    return n1 <= n2;\-                           \  };\-                           \}" :: Number -> Number -> Boolean+  (<=) :: forall a. (Ord a) => a -> a -> Boolean+  (<=) a1 a2 = case a1 `compare` a2 of+    GT -> false+    _ -> true -  foreign import numGreater "function numGreater(n1) {\-                            \  return function(n2) {\-                            \    return n1 > n2;\-                            \  };\-                            \}" :: Number -> Number -> Boolean+  infixl 4 >= -  foreign import numGreaterEq "function numGreaterEq(n1) {\-                              \  return function(n2) {\-                              \    return n1 >= n2;\-                              \  };\-                              \}" :: Number -> Number -> Boolean+  (>=) :: forall a. (Ord a) => a -> a -> Boolean+  (>=) a1 a2 = case a1 `compare` a2 of+    LT -> false+    _ -> true +  foreign import numCompare+    "function numCompare(n1) {\+    \  return function(n2) {\+    \    return n1 < n2 ? module.LT : n1 > n2 ? module.GT : module.EQ;\+    \  };\+    \}" :: Number -> Number -> Ordering+   instance ordNumber :: Ord Number where-    (<) = numLess-    (>) = numGreater-    (<=) = numLessEq-    (>=) = numGreaterEq+    compare = numCompare    infixl 10 &   infixl 10 |@@ -323,7 +334,6 @@ module Data.Monoid where    import Prelude-  import Data.Array (foldl)    infixr 6 <> @@ -339,13 +349,30 @@     mempty = []     (<>) = Data.Array.concat -  mconcat :: forall m. (Monoid m) => [m] -> m-  mconcat = foldl (<>) mempty+module Control.Applicative where +  import Prelude++  infixl 4 <*+  infixl 4 *>++  (<*) :: forall a b f. (Applicative f) => f a -> f b -> f a+  (<*) x y = const <$> x <*> y++  (*>) :: forall a b f. (Applicative f) => f a -> f b -> f b+  (*>) x y = const id <$> x <*> y++  lift2 :: forall a b c f. (Applicative f) => (a -> b -> c) -> f a -> f b -> f c+  lift2 f x y = f <$> x <*> y++  lift3 :: forall a b c d f. (Applicative f) => (a -> b -> c -> d) -> f a -> f b -> f c -> f d+  lift3 f x y z = f <$> x <*> y <*> z+ module Control.Monad where    import Prelude   import Data.Array+  import Data.Traversable    replicateM :: forall m a. (Monad m) => Number -> m a -> m [a]   replicateM 0 _ = return []@@ -354,13 +381,6 @@     as <- replicateM (n - 1) m     return (a : as) -  mapM :: forall m a b. (Monad m) => (a -> m b) -> [a] -> m [b]-  mapM _ [] = return []-  mapM f (a:as) = do-    b <- f a-    bs <- mapM f as-    return (b : bs)-   infixr 1 >=>   infixr 1 <=< @@ -372,13 +392,6 @@   (<=<) :: forall m a b c. (Monad m) => (b -> m c) -> (a -> m b) -> a -> m c   (<=<) = flip (>=>) -  sequence :: forall m a. (Monad m) => [m a] -> m [a]-  sequence [] = return []-  sequence (m:ms) = do-    a <- m-    as <- sequence ms-    return (a : as)-   join :: forall m a. (Monad m) => m (m a) -> m a   join mm = do     m <- mm@@ -392,8 +405,8 @@   when true m = m   when false _ = return {} -  zipWithM :: forall m a b c. (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c]-  zipWithM f xs ys = sequence $ zipWith f xs ys+  zipWithA :: forall m a b c. (Applicative m) => (a -> b -> m c) -> [a] -> [b] -> m [c]+  zipWithA f xs ys = sequence (zipWith f xs ys)  module Data.Maybe where @@ -408,6 +421,12 @@   fromMaybe :: forall a. a -> Maybe a -> a   fromMaybe a = maybe a (id :: forall a. a -> a) +  isJust :: forall a. Maybe a -> Boolean+  isJust = maybe false (const true)++  isNothing :: forall a. Maybe a -> Boolean+  isNothing = maybe true (const false)+   instance monadMaybe :: Monad Maybe where     return = Just     (>>=) m f = maybe Nothing f m@@ -441,6 +460,12 @@   either f _ (Left a) = f a   either _ g (Right b) = g b +  isLeft :: forall a b. Either a b -> Boolean+  isLeft = either (const true) (const false)++  isRight :: forall a b. Either a b -> Boolean+  isRight = either (const false) (const true)+   instance monadEither :: Monad (Either e) where     return = Right     (>>=) = either (\e _ -> Left e) (\a f -> f a)@@ -481,14 +506,6 @@   map _ [] = []   map f (x:xs) = f x : map f xs -  foldr :: forall a b. (a -> b -> a) -> a -> [b] -> a-  foldr f a (b : bs) = f (foldr f a bs) b-  foldr _ a [] = a--  foldl :: forall a b. (b -> a -> b) -> b -> [a] -> b-  foldl _ b [] = b-  foldl f b (a:as) = foldl f (f b a) as-   foreign import length "function length(xs) {\                         \  return xs.length;\                         \}" :: forall a. [a] -> Number@@ -596,20 +613,15 @@   singleton :: forall a. a -> [a]   singleton a = [a] -  concatMap :: forall a b. [a] -> (a -> [b]) -> [b]-  concatMap [] f = []-  concatMap (a:as) f = f a `concat` concatMap as f+  concatMap :: forall a b. (a -> [b]) -> [a] -> [b]+  concatMap _ [] = []+  concatMap f (a:as) = f a `concat` concatMap f as    filter :: forall a. (a -> Boolean) -> [a] -> [a]   filter _ [] = []   filter p (x:xs) | p x = x : filter p xs   filter p (_:xs) = filter p xs -  find :: forall a. (a -> Boolean) -> [a] -> Maybe a-  find _ [] = Nothing-  find p (x:xs) | p x = Just x-  find p (_:xs) = find p xs-   isEmpty :: forall a. [a] -> Boolean   isEmpty [] = true   isEmpty _ = false@@ -622,14 +634,6 @@   zipWith f (a:as) (b:bs) = f a b : zipWith f as bs   zipWith _ _ _ = [] -  any :: forall a. (a -> Boolean) -> [a] -> Boolean-  any _ [] = false-  any p (a:as) = p a || any p as--  all :: forall a. (a -> Boolean) -> [a] -> Boolean-  all _ [] = true-  all p (a:as) = p a && all p as-   drop :: forall a. Number -> [a] -> [a]   drop 0 xs = xs   drop _ [] = []@@ -640,12 +644,19 @@   take _ [] = []   take n (x:xs) = x : take (n - 1) xs +  nub :: forall a. (Eq a) => [a] -> [a]+  nub = nubBy (==)++  nubBy :: forall a. (a -> a -> Boolean) -> [a] -> [a]+  nubBy _ [] = []+  nubBy (==) (x:xs) = x : nubBy (==) (filter (\y -> not (x == y)) xs)+   instance showArray :: (Show a) => Show [a] where     show xs = "[" ++ joinWith (map show xs) "," ++ "]"    instance monadArray :: Monad [] where     return = singleton-    (>>=) = concatMap+    (>>=) = flip concatMap    instance functorArray :: Functor [] where     (<$>) = map@@ -689,6 +700,12 @@    data Tuple a b = Tuple a b +  fst :: forall a b. Tuple a b -> a+  fst (Tuple a _) = a++  snd :: forall a b. Tuple a b -> b+  snd (Tuple _ b) = b+   instance showTuple :: (Show a, Show b) => Show (Tuple a b) where     show (Tuple a b) = "Tuple(" ++ show a ++ ", " ++ show b ++ ")" @@ -710,6 +727,9 @@     (==) (Tuple a1 b1) (Tuple a2 b2) = a1 == a2 && b1 == b2     (/=) t1 t2 = not (t1 == t2) +  instance functorTuple :: Functor (Tuple a) where+    (<$>) f (Tuple x y) = Tuple x (f y)+ module Data.String where    foreign import lengthS "function lengthS(s) {\@@ -758,7 +778,7 @@    foreign import split "function split(sep) {\                        \  return function(s) {\-                       \    return s.split(s);\+                       \    return s.split(sep);\                        \  };\                        \}" :: String -> String -> [String] @@ -909,19 +929,19 @@                      \}" :: Number -> Number    foreign import max "function max(n1){\-                     \  return function(n2) {\ +                     \  return function(n2) {\                      \    return Math.max(n1, n2);\                      \  }\                      \}" :: Number -> Number -> Number    foreign import min "function min(n1){\-                     \  return function(n2) {\ +                     \  return function(n2) {\                      \    return Math.min(n1, n2);\                      \  }\                      \}" :: Number -> Number -> Number    foreign import pow "function pow(n){\-                     \  return function(p) {\ +                     \  return function(p) {\                      \    return Math.pow(n, p);\                      \  }\                      \}" :: Number -> Number -> Number@@ -1039,7 +1059,7 @@                         \  return Math.random();\                         \}" :: forall e. Eff (random :: Random | e) Number -module Control.Monad.Error where+module Control.Monad.Eff.Error where    import Control.Monad.Eff @@ -1206,7 +1226,7 @@   class Enum a where     toEnum :: Number -> Maybe a     fromEnum :: a -> Number-    + module Text.Parsing.Read where    class Read a where@@ -1223,3 +1243,154 @@    instance readNumber :: Read Number where     read = readNumberImpl++module Data.Foldable where++  import Prelude+  import Control.Applicative+  import Data.Either+  import Data.Eq+  import Data.Maybe+  import Data.Monoid+  import Data.Tuple++  class Foldable f where+    foldr :: forall a b. (a -> b -> b) -> b -> f a -> b+    foldl :: forall a b. (b -> a -> b) -> b -> f a -> b+    foldMap :: forall a m. (Monoid m) => (a -> m) -> f a -> m++  instance foldableArray :: Foldable [] where+    foldr _ z []     = z+    foldr f z (x:xs) = x `f` (foldr f z xs)++    foldl _ z []     = z+    foldl f z (x:xs) = foldl f (z `f` x) xs++    foldMap _ []     = mempty+    foldMap f (x:xs) = f x <> foldMap f xs++  instance foldableEither :: Foldable (Either a) where+    foldr _ z (Left _)  = z+    foldr f z (Right x) = x `f` z++    foldl _ z (Left _)  = z+    foldl f z (Right x) = z `f` x++    foldMap f (Left _)  = mempty+    foldMap f (Right x) = f x++  instance foldableMaybe :: Foldable Maybe where+    foldr _ z Nothing  = z+    foldr f z (Just x) = x `f` z++    foldl _ z Nothing  = z+    foldl f z (Just x) = z `f` x++    foldMap f Nothing  = mempty+    foldMap f (Just x) = f x++  instance foldableRef :: Foldable Ref where+    foldr f z (Ref x) = x `f` z++    foldl f z (Ref x) = z `f` x++    foldMap f (Ref x) = f x++  instance foldableTuple :: Foldable (Tuple a) where+    foldr f z (Tuple _ x) = x `f` z++    foldl f z (Tuple _ x) = z `f` x++    foldMap f (Tuple _ x) = f x++  fold :: forall f m. (Foldable f, Monoid m) => f m -> m+  fold = foldMap id++  traverse_ :: forall a b f m. (Applicative m, Foldable f) => (a -> m b) -> f a -> m {}+  traverse_ f = foldr ((*>) <<< f) (pure {})++  for_ :: forall a b f m. (Applicative m, Foldable f) => f a -> (a -> m b) -> m {}+  for_ = flip traverse_++  sequence_ :: forall a f m. (Applicative m, Foldable f) => f (m a) -> m {}+  sequence_ = traverse_ id++  mconcat :: forall f m. (Foldable f, Monoid m) => f m -> m+  mconcat = foldl (<>) mempty++  and :: forall f. (Foldable f) => f Boolean -> Boolean+  and = foldl (&&) true++  or :: forall f. (Foldable f) => f Boolean -> Boolean+  or = foldl (||) false++  any :: forall a f. (Foldable f) => (a -> Boolean) -> f a -> Boolean+  any p = or <<< foldMap (\x -> [p x])++  all :: forall a f. (Foldable f) => (a -> Boolean) -> f a -> Boolean+  all p = and <<< foldMap (\x -> [p x])++  sum :: forall f. (Foldable f) => f Number -> Number+  sum = foldl (+) 0++  product :: forall f. (Foldable f) => f Number -> Number+  product = foldl (*) 1++  elem :: forall a f. (Eq a, Foldable f) => a -> f a -> Boolean+  elem = any  <<< (==)++  notElem :: forall a f. (Eq a, Foldable f) => a -> f a -> Boolean+  notElem x = not <<< elem x++  find :: forall a f. (Foldable f) => (a -> Boolean) -> f a -> Maybe a+  find p f = case foldMap (\x -> if p x then [x] else []) f of+    (x:_) -> Just x+    []    -> Nothing++module Data.Traversable where++  import Prelude+  import Data.Array ((:))+  import Data.Either+  import Data.Eq+  import Data.Foldable+  import Data.Maybe+  import Data.Tuple++  class Traversable t where+    traverse :: forall a b m. (Applicative m) => (a -> m b) -> t a -> m (t b)+    sequence :: forall a m. (Applicative m) => t (m a) -> m (t a)++  instance traversableArray :: Traversable [] where+    traverse _ []     = pure []+    traverse f (x:xs) = (:) <$> (f x) <*> traverse f xs++    sequence []     = pure []+    sequence (x:xs) = (:) <$> x <*> sequence xs++  instance traversableEither :: Traversable (Either a) where+    traverse _ (Left x)  = pure (Left x)+    traverse f (Right x) = Right <$> f x++    sequence (Left x) = pure (Left x)+    sequence (Right x)  = Right <$> x++  instance traversableRef :: Traversable Ref where+    traverse f (Ref x) = Ref <$> f x++    sequence (Ref x) = Ref <$> x++  instance traversableMaybe :: Traversable Maybe where+    traverse _ Nothing  = pure Nothing+    traverse f (Just x) = Just <$> f x++    sequence Nothing  = pure Nothing+    sequence (Just x) = Just <$> x++  instance traversableTuple :: Traversable (Tuple a) where+    traverse f (Tuple x y) = Tuple x <$> f y++    sequence (Tuple x y) = Tuple x <$> y++  for :: forall a b m t. (Applicative m, Traversable t) => t a -> (a -> m b) -> m (t b)+  for x f = traverse f x
psc/Main.hs view
@@ -12,48 +12,99 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE GeneralizedNewtypeDeriving #-}+ module Main where -import qualified Language.PureScript as P-import System.Console.CmdTheLine import Control.Applicative-import Control.Monad (forM)+import Control.Monad.Error++import Data.Version (showVersion)++import System.Console.CmdTheLine+import System.Directory+       (doesFileExist, getModificationTime, createDirectoryIfMissing)+import System.FilePath (takeDirectory) import System.Exit (exitSuccess, exitFailure)-import qualified System.IO.UTF8 as U+import System.IO.Error (tryIOError)+ import Text.Parsec (ParseError)++import qualified Language.PureScript as P import qualified Paths_purescript as Paths-import Data.Version (showVersion)+import qualified System.IO.UTF8 as U  preludeFilename :: IO FilePath preludeFilename = Paths.getDataFileName "prelude/prelude.purs" -readInput :: Maybe [FilePath] -> IO (Either ParseError [P.Module])-readInput Nothing = P.runIndentParser "" P.parseModules <$> getContents-readInput (Just input) = fmap (fmap concat . sequence) $ forM input $ \inputFile -> do+readInput :: Maybe [FilePath] -> IO (Either ParseError [(FilePath, P.Module)])+readInput Nothing = do+  text <- getContents+  return $ map ((,) undefined) <$> P.runIndentParser "" P.parseModules text+readInput (Just input) = fmap collect $ forM input $ \inputFile -> do   text <- U.readFile inputFile-  return $ P.runIndentParser inputFile P.parseModules text+  return $ (inputFile, P.runIndentParser inputFile P.parseModules text)+  where+  collect :: [(FilePath, Either ParseError [P.Module])] -> Either ParseError [(FilePath, P.Module)]+  collect = fmap concat . sequence . map (\(fp, e) -> fmap (map ((,) fp)) e) -compile :: P.Options -> Maybe [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()-compile opts input output externs = do+newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Monad, MonadIO, MonadError String)++runMake :: Make a -> IO (Either String a)+runMake = runErrorT . unMake++makeIO :: IO a -> Make a+makeIO = Make . ErrorT . fmap (either (Left . show) Right) . tryIOError++instance P.MonadMake Make where+  getTimestamp path = makeIO $ do+    exists <- doesFileExist path+    case exists of+      True -> Just <$> getModificationTime path+      False -> return Nothing+  readTextFile path = makeIO $ do+    U.putStrLn $ "Reading " ++ path+    U.readFile path+  writeTextFile path text = makeIO $ do+    mkdirp path+    U.putStrLn $ "Writing " ++ path+    U.writeFile path text+  liftError = either throwError return++compile :: Bool -> P.Options -> Maybe [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()+compile makeMode opts input output externs = do   modules <- readInput input   case modules of     Left err -> do       U.print err       exitFailure     Right ms ->-      case P.compile opts ms of-        Left err -> do-          U.putStrLn err-          exitFailure-        Right (js, exts, _) -> do-          case output of-            Just path -> U.writeFile path js-            Nothing -> U.putStrLn js-          case externs of-            Nothing -> return ()-            Just filePath -> U.writeFile filePath exts-          exitSuccess+      case makeMode of+        True -> do+          e <- runMake $ P.make opts ms+          case e of+            Left err -> do+              U.putStrLn err+              exitFailure+            Right _ -> do+              exitSuccess+        False ->+          case P.compile opts (map snd ms) of+            Left err -> do+              U.putStrLn err+              exitFailure+            Right (js, exts, _) -> do+              case output of+                Just path -> mkdirp path >> U.writeFile path js+                Nothing -> U.putStrLn js+              case externs of+                Just path -> mkdirp path >> U.writeFile path exts+                Nothing -> return ()+              exitSuccess +mkdirp :: FilePath -> IO ()+mkdirp = createDirectoryIfMissing True . takeDirectory+ useStdIn :: Term Bool useStdIn = value . flag $ (optInfo [ "s", "stdin" ])      { optDoc = "Read from standard input" }@@ -94,6 +145,10 @@ noOpts = value $ flag $ (optInfo [ "no-opts" ])      { optDoc = "Skip the optimization phase." } +make :: Term Bool+make = value $ flag $ (optInfo [ "make" ])+     { optDoc = "Run in make mode" }+ browserNamespace :: Term String browserNamespace = value $ opt "PS" $ (optInfo [ "browser-namespace" ])      { optDoc = "Specify the namespace that PureScript modules will be exported to when running in the browser." }@@ -102,8 +157,12 @@ dceModules = value $ optAll [] $ (optInfo [ "m", "module" ])      { optDoc = "Enables dead code elimination, all code which is not a transitive dependency of a specified module will be removed. This argument can be used multiple times." } +codeGenModules :: Term [String]+codeGenModules = value $ optAll [] $ (optInfo [ "codegen" ])+     { optDoc = "A list of modules for which Javascript and externs should be generated. This argument can be used multiple times." }+ options :: Term P.Options-options = P.Options <$> tco <*> performRuntimeTypeChecks <*> magicDo <*> runMain <*> noOpts <*> browserNamespace <*> dceModules+options = P.Options <$> tco <*> performRuntimeTypeChecks <*> magicDo <*> runMain <*> noOpts <*> browserNamespace <*> dceModules <*> codeGenModules  stdInOrInputFiles :: FilePath -> Term (Maybe [FilePath]) stdInOrInputFiles prelude = combine <$> useStdIn <*> (not <$> noPrelude) <*> inputFiles@@ -113,7 +172,7 @@   combine True _ _ = Nothing  term :: FilePath -> Term (IO ())-term prelude = compile <$> options <*> stdInOrInputFiles prelude <*> outputFile <*> externsFile+term prelude = compile <$> make <*> options <*> stdInOrInputFiles prelude <*> outputFile <*> externsFile  termInfo :: TermInfo termInfo = defTI
psci/Main.hs view
@@ -195,7 +195,7 @@ -- | Compilation options. -- options :: P.Options-options = P.Options True False True (Just "Main") True "PS" []+options = P.Options True False True (Just "Main") True "PS" [] []  -- | -- Makes a volatile module to execute the current expression.@@ -204,7 +204,7 @@ createTemporaryModule exec PSCiState{psciImportedModuleNames = imports, psciLetBindings = lets} value =   let     moduleName = P.ModuleName [P.ProperName "Main"]-    importDecl m = P.ImportDeclaration m Nothing+    importDecl m = P.ImportDeclaration m Nothing Nothing     traceModule = P.ModuleName [P.ProperName "Debug", P.ProperName "Trace"]     trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))     itValue = foldl (\x f -> f x) value lets
purescript.cabal view
@@ -1,5 +1,5 @@ name: purescript-version: 0.4.5.1+version: 0.4.6 cabal-version: >=1.8 build-type: Custom license: MIT@@ -21,7 +21,7 @@     build-depends: base >=4 && <5, cmdtheline -any, containers -any,                    directory -any, filepath -any, mtl -any, parsec -any, syb -any,                    transformers -any, utf8-string -any, pattern-arrows -any, monad-unify >= 0.2 && < 0.3,-                   xdg-basedir -any+                   xdg-basedir -any, time -any     if (!os(windows))         build-depends: unix -any     exposed-modules: Data.Generics.Extras@@ -95,7 +95,7 @@  executable psci     build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,-                   mtl -any, parsec -any, haskeline <=0.7.1.1, purescript -any,+                   mtl -any, parsec -any, haskeline -any, purescript -any,                    syb -any, transformers -any, utf8-string -any, process -any,                    xdg-basedir -any, cmdtheline -any     main-is: Main.hs
src/Language/PureScript.hs view
@@ -13,7 +13,7 @@ -- ----------------------------------------------------------------------------- -module Language.PureScript (module P, compile) where+module Language.PureScript (module P, compile, compile', MonadMake(..), make) where  import Language.PureScript.Values as P import Language.PureScript.Types as P@@ -34,10 +34,12 @@ import qualified Language.PureScript.Constants as C  import Data.List (intercalate)-import Data.Maybe (mapMaybe)+import Data.Time.Clock+import Data.Maybe (fromMaybe, mapMaybe) import Control.Monad.State.Lazy import Control.Applicative ((<$>), (<*>), pure) import qualified Data.Map as M+import System.FilePath (pathSeparator)  -- | -- Compile a collection of modules@@ -59,23 +61,126 @@ --  * Pretty-print the generated Javascript -- compile :: Options -> [Module] -> Either String (String, String, Environment)-compile opts ms = do+compile = compile' initEnvironment++compile' :: Environment -> Options -> [Module] -> Either String (String, String, Environment)+compile' env opts ms = do   sorted <- sortModules ms   desugared <- desugar sorted-  (elaborated, env) <- runCheck $ forM desugared $ \(Module moduleName' decls exps) -> do+  (elaborated, env') <- runCheck' env $ forM desugared $ \(Module moduleName' decls exps) -> do     modify (\s -> s { checkCurrentModule = Just moduleName' })     Module moduleName' <$> typeCheckAll mainModuleIdent moduleName' decls <*> pure exps   regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated   let entryPoints = moduleNameFromString `map` optionsModules opts   let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped-  let js = mapMaybe (flip (moduleToJs opts) env) elim-  let exts = intercalate "\n" . map (`moduleToPs` env) $ elim-  js' <- case mainModuleIdent of+  let codeGenModules = moduleNameFromString `map` optionsCodeGenModules opts+  let modulesToCodeGen = if null codeGenModules then elim else filter (\(Module mn _ _) -> mn `elem` codeGenModules) elim+  let js = mapMaybe (flip (moduleToJs opts) env') modulesToCodeGen+  let exts = intercalate "\n" . map (`moduleToPs` env') $ modulesToCodeGen+  js' <- generateMain env' opts js+  return (prettyPrintJS [wrapExportsContainer opts js'], exts, env')+  where+  mainModuleIdent = moduleNameFromString <$> optionsMain opts++generateMain :: Environment -> Options -> [JS] -> Either String [JS]+generateMain env opts js =+  case moduleNameFromString <$> optionsMain opts of     Just mmi -> do       when ((mmi, Ident C.main) `M.notMember` names env) $         Left $ show mmi ++ "." ++ C.main ++ " is undefined"       return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar C._ps))) []]     _ -> return js-  return (prettyPrintJS [wrapExportsContainer opts js'], exts, env)++-- |+-- A type class which collects the IO actions we need to be able to run in "make" mode+--+class MonadMake m where+  -- |+  -- Get a file timestamp+  --+  getTimestamp :: FilePath -> m (Maybe UTCTime)++  -- |+  -- Read a file as a string+  --+  readTextFile :: FilePath -> m String++  -- |+  -- Write a text file+  --+  writeTextFile :: FilePath -> String -> m ()++  -- |+  -- Report an error+  --+  liftError :: Either String a -> m a+++-- |+-- Compiles in "make" mode, compiling each module separately to a js files and an externs file+--+-- If timestamps have not changed, the externs file can be used to provide the module's types without+-- having to typecheck the module again.+--+make :: (Functor m, Monad m, MonadMake m) => Options -> [(FilePath, Module)] -> m ()+make opts ms = do+  let filePathMap = M.fromList (map (\(fp, (Module mn _ _)) -> (mn, fp)) ms)++  sorted <- liftError $ sortModules (map snd ms)++  marked <- forM sorted $ \m@(Module moduleName' _ _) -> do+    let filePath = toFileName moduleName'++        jsFile = "js" ++ pathSeparator : filePath ++ ".js"+        externsFile = "externs" ++ pathSeparator : filePath ++ ".externs"+        inputFile = fromMaybe (error "Input file is undefined in make") $ M.lookup moduleName' filePathMap++    jsTimestamp <- getTimestamp jsFile+    externsTimestamp <- getTimestamp externsFile+    inputTimestamp <- getTimestamp inputFile++    case inputTimestamp < min jsTimestamp externsTimestamp of+      True -> do+        externs <- readTextFile externsFile+        externsModules <- liftError . either (Left . show) Right $ P.runIndentParser externsFile P.parseModules externs+        case externsModules of+          [m'@(Module moduleName'' _ _)] | moduleName' == moduleName'' -> return (True, m')+          _ -> liftError . Left $ "Externs file " ++ externsFile ++ " was invalid"+      False -> return (False, m)++  desugared <- liftError $ zip (map fst marked) <$> desugar (map snd marked)++  go initEnvironment desugared+   where-  mainModuleIdent = moduleNameFromString <$> optionsMain opts+  go :: (Functor m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> m ()+  go _ [] = return ()+  go env ((True, Module moduleName' typings _) : ms') = do+    (_, env') <- liftError . runCheck' env $ do+      modify (\s -> s { checkCurrentModule = Just moduleName' })+      typeCheckAll Nothing moduleName' typings++    go env' ms'+  go env ((False, Module moduleName' decls exps) : ms') = do+    let filePath = toFileName moduleName'+        jsFile = "js" ++ pathSeparator : filePath ++ ".js"+        externsFile = "externs" ++ pathSeparator : filePath ++ ".externs"++    (elaborated, env') <- liftError . runCheck' env $ do+      modify (\s -> s { checkCurrentModule = Just moduleName' })+      typeCheckAll Nothing moduleName' decls++    regrouped <- liftError . createBindingGroups moduleName' . collapseBindingGroups $ elaborated++    let mod' = Module moduleName' regrouped exps+        js = moduleToJs opts mod' env'+        exts = moduleToPs mod' env'+        js' = maybe "" (prettyPrintJS . return . wrapExportsContainer opts . return) js++    writeTextFile jsFile js'+    writeTextFile externsFile exts++    go env' ms'++  toFileName :: ModuleName -> FilePath+  toFileName (ModuleName ps) = intercalate [pathSeparator] . map runProperName $ ps
src/Language/PureScript/CodeGen/Externs.hs view
@@ -57,7 +57,7 @@               printDctor dctor = case dctor `lookup` tys of                                    Nothing -> Nothing                                    Just tyArgs -> Just $ show dctor ++ " " ++ unwords (map prettyPrintTypeAtom tyArgs)-          tell ["data " ++ show pn ++ " " ++ unwords args ++ " = " ++ intercalate " | " (mapMaybe printDctor dctors')]+          tell ["data " ++ show pn ++ " " ++ unwords args ++ (if null dctors' then "" else " = " ++ intercalate " | " (mapMaybe printDctor dctors'))]         Just (_, TypeSynonym) ->           case Qualified (Just moduleName) pn `M.lookup` typeSynonyms env of             Nothing -> error $ show pn ++ " has no type synonym info in exportToPs"
src/Language/PureScript/CodeGen/JS.hs view
@@ -52,11 +52,14 @@   case jsDecls of     [] -> Nothing     _ -> Just $ JSAssignment (JSAccessor (moduleNameToJs name) (JSVar C._ps)) $-           JSApp (JSFunction Nothing ["module"] (JSBlock $ jsDecls ++ [JSReturn $ JSVar "module"]))-                 [JSBinary Or (JSAccessor (moduleNameToJs name) (JSVar C._ps)) (JSObjectLiteral [])]+           JSApp (JSFunction Nothing [] (JSBlock $+            JSVariableIntroduction "module" (Just $ JSObjectLiteral []) :+            jsDecls +++            jsExports +++            [JSReturn $ JSVar "module"])) []   where   jsDecls = (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts name decl env) decls)-          ++ concatMap exportToJs exps+  jsExports = concatMap exportToJs exps moduleToJs _ _ _ = error "Exports should have been elaborated in name desugaring"  -- |
src/Language/PureScript/Declarations.hs view
@@ -117,9 +117,10 @@   --   | FixityDeclaration Fixity String   -- |-  -- A module import (module name, optional set of identifiers to import)+  -- A module import (module name, optional set of identifiers to import, optional "qualified as"+  -- name)   ---  | ImportDeclaration ModuleName (Maybe [DeclarationRef])+  | ImportDeclaration ModuleName (Maybe [DeclarationRef]) (Maybe ModuleName)   -- |   -- A type class declaration (name, argument, member declarations)   --
src/Language/PureScript/ModuleDependencies.hs view
@@ -47,7 +47,7 @@   qualifiedProperNames (Qualified (Just mn) _) = [mn]   qualifiedProperNames _ = []   imports :: Declaration -> [ModuleName]-  imports (ImportDeclaration mn _) = [mn]+  imports (ImportDeclaration mn _ _) = [mn]   imports _ = []  getModuleName :: Module -> ModuleName
src/Language/PureScript/Options.hs view
@@ -49,10 +49,14 @@     -- The modules to keep while enabling dead code elimination     --   , optionsModules :: [String]+    -- |+    -- The modules to code gen+    --+  , optionsCodeGenModules :: [String]   } deriving Show  -- | -- Default compiler options -- defaultOptions :: Options-defaultOptions = Options False False False Nothing False "PS" []+defaultOptions = Options False False False Nothing False "PS" [] []
src/Language/PureScript/Parser/Common.hs view
@@ -328,7 +328,7 @@ -- Parse an identifier in backticks or an operator -- parseIdentInfix :: P.Parsec String ParseState (Qualified Ident)-parseIdentInfix = P.between tick tick (parseQualified (Ident <$> identifier)) <|> Qualified Nothing <$> (Op <$> operator)+parseIdentInfix = P.between tick tick (parseQualified (Ident <$> identifier)) <|> (parseQualified (Op <$> operator))  -- | -- Mark the current indentation level
src/Language/PureScript/Parser/Declarations.hs view
@@ -99,9 +99,20 @@ parseImportDeclaration = do   reserved "import"   indented-  moduleName' <- moduleName-  idents <- P.optionMaybe $ parens $ commaSep1 parseDeclarationRef-  return $ ImportDeclaration moduleName' idents+  qualImport <|> stdImport+  where+  stdImport = do+    moduleName' <- moduleName+    idents <- P.optionMaybe $ parens $ commaSep parseDeclarationRef+    return $ ImportDeclaration moduleName' idents Nothing+  qualImport = do+    reserved "qualified"+    indented+    moduleName' <- moduleName+    idents <- P.optionMaybe $ parens $ commaSep parseDeclarationRef+    reserved "as"+    asQ <- moduleName+    return $ ImportDeclaration moduleName' idents (Just asQ)  parseDeclarationRef :: P.Parsec String ParseState DeclarationRef parseDeclarationRef = ValueRef <$> parseIdent
src/Language/PureScript/Sugar.hs view
@@ -49,11 +49,11 @@ --  * Qualify any unqualified names and types -- desugar :: [Module] -> Either String [Module]-desugar = rebracket-          >=> desugarDo+desugar = desugarDo           >=> desugarLetBindings           >>> desugarCasesModule           >=> desugarImports+          >=> rebracket           >=> desugarTypeDeclarationsModule           >=> desugarTypeClasses           >=> createBindingGroupsModule
src/Language/PureScript/Sugar/BindingGroups.hs view
@@ -25,6 +25,7 @@ import Data.Graph import Data.Generics import Data.List (nub, intersect)+import Data.Maybe (mapMaybe) import Control.Applicative ((<$>), (<*>), pure)  import Language.PureScript.Declarations@@ -89,6 +90,10 @@ usedProperNames moduleName = nub . everything (++) (mkQ [] usedNames)   where   usedNames :: Type -> [ProperName]+  usedNames (ConstrainedType constraints _) = flip mapMaybe constraints $ \qual ->+    case qual of+      (Qualified (Just moduleName') name, _) | moduleName == moduleName' -> Just name+      _ -> Nothing   usedNames (TypeConstructor (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]   usedNames _ = []
src/Language/PureScript/Sugar/Names.hs view
@@ -16,7 +16,7 @@   desugarImports ) where -import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, isJust) import Data.Generics (extM, mkM, everywhereM) import Data.Generics.Extras (mkS, extS, everywhereWithContextM') @@ -61,19 +61,19 @@   -- |   -- Local names for types within a module mapped to to their qualified names   ---  { importedTypes :: M.Map ProperName (Qualified ProperName)+  { importedTypes :: M.Map (Qualified ProperName) (Qualified ProperName)   -- |   -- Local names for data constructors within a module mapped to to their qualified names   ---  , importedDataConstructors :: M.Map ProperName (Qualified ProperName)+  , importedDataConstructors :: M.Map (Qualified ProperName) (Qualified ProperName)   -- |   -- Local names for classes within a module mapped to to their qualified names   ---  , importedTypeClasses :: M.Map ProperName (Qualified ProperName)+  , importedTypeClasses :: M.Map (Qualified ProperName) (Qualified ProperName)   -- |   -- Local names for values within a module mapped to to their qualified names   ---  , importedValues :: M.Map Ident (Qualified Ident)+  , importedValues :: M.Map (Qualified Ident) (Qualified Ident)   } deriving (Show)  -- |@@ -89,8 +89,11 @@ -- | -- Adds an empty module to an ExportEnvironment. ---addEmptyModule :: ExportEnvironment -> ModuleName -> ExportEnvironment-addEmptyModule env name = M.insert name (Exports [] [] []) env+addEmptyModule :: ExportEnvironment -> ModuleName -> Either String ExportEnvironment+addEmptyModule env name =+  if name `M.member` env+    then throwError $ "Module '" ++ show name ++ "' has been defined more than once"+    else return $ M.insert name (Exports [] [] []) env  -- | -- Adds a type belonging to a module to the export environment.@@ -187,8 +190,14 @@     ValueDeclaration name nameKind [] Nothing <$> everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val     where     bindFunctionArgs bound (Abs (Left arg) val') = return (arg : bound, Abs (Left arg) val')-    bindFunctionArgs bound (Var name'@(Qualified Nothing ident)) | ident `notElem` bound = (,) bound <$> (Var <$> updateValueName name')-    bindFunctionArgs bound (Var name'@(Qualified (Just _) _)) = (,) bound <$> (Var <$> updateValueName name')+    bindFunctionArgs bound (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =+      (,) bound <$> (Var <$> updateValueName name')+    bindFunctionArgs bound (Var name'@(Qualified (Just _) _)) =+      (,) bound <$> (Var <$> updateValueName name')+    bindFunctionArgs bound (BinaryNoParens name'@(Qualified Nothing ident) v1 v2) | ident `notElem` bound =+      (,) bound <$> (BinaryNoParens <$> updateValueName name' <*> pure v1 <*> pure v2)+    bindFunctionArgs bound (BinaryNoParens name'@(Qualified (Just _) _) v1 v2) =+      (,) bound <$> (BinaryNoParens <$> updateValueName name' <*> pure v1 <*> pure v2)     bindFunctionArgs bound other = return (bound, other)     bindBinders :: [Ident] -> CaseAlternative -> Either String ([Ident], CaseAlternative)     bindBinders bound c@(CaseAlternative bs _ _) = return (binderNames bs ++ bound, c)@@ -204,38 +213,26 @@   updateType t = return t   updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts) -  updateTypeName (Qualified Nothing name) = update "type" importedTypes name-  updateTypeName (Qualified (Just mn') name) = do-    modExports <- getExports mn'-    case name `lookup` exportedTypes modExports of-      Nothing -> throwError $ "Unknown type '" ++ show (Qualified (Just mn') name) ++ "'"-      _ -> return $ Qualified (Just mn') name--  updateDataConstructorName (Qualified Nothing name) = update "data constructor" importedDataConstructors name-  updateDataConstructorName (Qualified (Just mn') name) = do-    modExports <- getExports mn'-    let allDcons = join $ snd `map` exportedTypes modExports-    if name `elem` allDcons-      then return $ Qualified (Just mn') name-      else throwError $ "Unknown data constructor '" ++ show (Qualified (Just mn') name) ++ "'"--  updateClassName (Qualified Nothing name) = update "type class" importedTypeClasses name-  updateClassName (Qualified (Just mn') name) = check "type class" exportedTypeClasses mn' name--  updateValueName (Qualified Nothing name) = update "value" importedValues name-  updateValueName (Qualified (Just mn') name) = check "value" exportedValues mn' name--  -- Replace an unqualified name with a qualified-  update :: (Ord a, Show a) => String -> (ImportEnvironment -> M.Map a (Qualified a)) -> a -> Either String (Qualified a)-  update t get name = maybe (throwError $ "Unknown " ++ t ++ " '" ++ show name ++ "'") return $ M.lookup name (get imports)+  updateTypeName = update "type" importedTypes (\mes -> isJust . (`lookup` (exportedTypes mes)))+  updateClassName = update "type class" importedTypeClasses (flip elem . exportedTypeClasses)+  updateValueName = update "value" importedValues (flip elem . exportedValues)+  updateDataConstructorName = update "data constructor" importedDataConstructors (\mes -> flip elem (join $ snd `map` exportedTypes mes)) -  -- Check that a qualified name is valid-  check :: (Show a, Eq a) => String -> (Exports -> [a]) -> ModuleName -> a -> Either String (Qualified a)-  check t get mn' name = do-    modExports <- getExports mn'-    if name `elem` get modExports-      then return $ Qualified (Just mn') name-      else throwError $ "Unknown " ++ t ++ " '" ++ show (Qualified (Just mn') name) ++ "'"+  -- Update names so unqualified references become qualified, and locally qualified references+  -- are replaced with their canoncial qualified names (e.g. M.Map -> Data.Map.Map)+  update :: (Ord a, Show a) => String+                            -> (ImportEnvironment -> M.Map (Qualified a) (Qualified a))+                            -> (Exports -> a -> Bool)+                            -> (Qualified a)+                            -> Either String (Qualified a)+  update t getI checkE qname@(Qualified mn' name) = case (M.lookup qname (getI imports), mn') of+    (Just qname', _) -> return qname'+    (Nothing, Just mn'') -> do+      modExports <- getExports mn''+      if checkE modExports name+        then return qname+        else throwError $ "Unknown " ++ t ++ " '" ++ show (qname) ++ "'"+    _ -> throwError $ "Unknown " ++ t ++ " '" ++ show name ++ "'"    -- Gets the exports for a module, or an error message if the module doesn't exist   getExports :: ModuleName -> Either String Exports@@ -255,7 +252,9 @@    -- Add all of the exported declarations from a module to the global export environment   addModule :: ExportEnvironment -> Module -> Either String ExportEnvironment-  addModule env m@(Module mn ds _) = rethrowForModule m $ foldM (addDecl mn) (addEmptyModule env mn) ds+  addModule env m@(Module mn ds _) = do+    env' <- addEmptyModule env mn+    rethrowForModule m $ foldM (addDecl mn) env' ds    -- Add a declaration from a module to the global export environment   addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either String ExportEnvironment@@ -329,10 +328,10 @@ -- Finds the imports within a module, mapping the imported module name to an optional set of -- explicitly imported declarations. ---findImports :: [Declaration] -> M.Map ModuleName (Maybe ExplicitImports)+findImports :: [Declaration] -> M.Map ModuleName (Maybe ExplicitImports, Maybe ModuleName) findImports = foldl findImports' M.empty   where-  findImports' result (ImportDeclaration mn expl) = M.insert mn expl result+  findImports' result (ImportDeclaration mn expl qual) = M.insert mn (expl, qual) result   findImports' result _ = result  -- |@@ -343,17 +342,17 @@   foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)   where   -- A Map from module name to imports from that module, where Nothing indicates everything is to be imported-  scope :: M.Map ModuleName (Maybe ExplicitImports)-  scope = M.insert currentModule Nothing (findImports decls)-  resolveImport' imp (mn, i) = do-      m <- maybe (throwError $ "Cannot import unknown module '" ++ show mn ++ "'") return $ mn `M.lookup` env-      resolveImport currentModule mn m imp i+  scope :: M.Map ModuleName (Maybe ExplicitImports, Maybe ModuleName)+  scope = M.insert currentModule (Nothing, Nothing) (findImports decls)+  resolveImport' imp (mn, (explImports, impQual)) = do+      modExports <- maybe (throwError $ "Cannot import unknown module '" ++ show mn ++ "'") return $ mn `M.lookup` env+      resolveImport currentModule mn modExports imp impQual explImports  -- | -- Extends the local environment for a module by resolving an import of another module. ---resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ExplicitImports -> Either String ImportEnvironment-resolveImport currentModule importModule exps imps = maybe importAll (foldM importExplicit imps)+resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> Maybe ExplicitImports-> Either String ImportEnvironment+resolveImport currentModule importModule exps imps impQual = maybe importAll (foldM importExplicit imps)   where    -- Import everything from a module@@ -387,9 +386,9 @@   allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exps    -- Add something to the ImportEnvironment if it does not already exist there-  updateImports :: (Ord a, Show a) => M.Map a (Qualified a) -> a -> Either String (M.Map a (Qualified a))-  updateImports m name = case M.lookup name m of-    Nothing -> return $ M.insert name (Qualified (Just importModule) name) m+  updateImports :: (Ord a, Show a) => M.Map (Qualified a) (Qualified a) -> a -> Either String (M.Map (Qualified a) (Qualified a))+  updateImports m name = case M.lookup (Qualified impQual name) m of+    Nothing -> return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name) m     Just (Qualified Nothing _) -> error "Invalid state in updateImports"     Just x@(Qualified (Just mn) _) -> throwError $       if mn == currentModule || importModule == currentModule
src/Language/PureScript/Sugar/Operators.hs view
@@ -17,7 +17,7 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE Rank2Types, FlexibleContexts #-}  module Language.PureScript.Sugar.Operators (   rebracket@@ -28,13 +28,14 @@ import Language.PureScript.Values  import Control.Applicative-import Control.Arrow (first) import Control.Monad.State+import Control.Monad.Error.Class  import Data.Function (on)-import Data.List (groupBy, sortBy)+import Data.Functor.Identity+import Data.List (sort, groupBy, sortBy) -import qualified Data.Map as M+import qualified Data.Data as D import qualified Data.Generics as G import qualified Data.Generics.Extras as G @@ -46,28 +47,41 @@ -- Remove explicit parentheses and reorder binary operator applications -- rebracket :: [Module] -> Either String [Module]-rebracket = go M.empty []+rebracket ms = do+  let fixities = concatMap collectFixities ms+  ensureNoDuplicates $ map fst fixities+  let opTable = customOperatorTable fixities+  mapM (rebracketModule opTable) ms++rebracketModule :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Module -> Either String Module+rebracketModule opTable (Module mn ds exts) = Module mn <$> (removeParens <$> G.everywhereM' (G.mkM (matchOperators opTable)) ds) <*> pure exts++removeParens :: (D.Data d) => d -> d+removeParens = G.everywhere (G.mkT go)   where-  go _ rb [] = return . reverse $ rb-  go m rb (Module name ds exps : ms) = do-    m' <- M.union m <$> collectFixities m name ds-    let opTable = customOperatorTable m'-    ds' <- G.everywhereM' (G.mkM (matchOperators name opTable)) ds-    go m' (Module name (G.everywhere (G.mkT removeParens) ds') exps : rb) ms+  go (Parens val) = val+  go val = val -removeParens :: Value -> Value-removeParens (Parens val) = val-removeParens val = val+collectFixities :: Module -> [(Qualified Ident, Fixity)]+collectFixities (Module moduleName ds _) = concatMap collect ds+  where+  collect :: Declaration -> [(Qualified Ident, Fixity)]+  collect (FixityDeclaration fixity name) = [(Qualified (Just moduleName) (Op name), fixity)]+  collect _ = [] -customOperatorTable :: M.Map (Qualified Ident) Fixity -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]]+ensureNoDuplicates :: [Qualified Ident] -> Either String ()+ensureNoDuplicates m = go $ sort m+  where+  go [] = return ()+  go [_] = return ()+  go (x : y : _) | x == y = throwError $ "Redefined fixity for " ++ show x+  go (_ : rest) = go rest++customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]] customOperatorTable fixities =   let-    -- We make the assumption here that infix operators are not qualified. The parser currently enforces this.-    -- The fixity map can therefore map from module name/ident pairs to fixities, where the module name is the name-    -- of the module imported into, not from. This is useful in matchOp, but here we have to discard the module name to-    -- make sure that the generated code is correct.-    applyUserOp (Qualified _ name) t1 = App (App (Var (Qualified Nothing name)) t1)-    userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) . M.toList $ fixities+    applyUserOp ident t1 = App (App (Var ident) t1)+    userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) fixities     sorted = sortBy (flip compare `on` (\(_, _, p, _) -> p)) userOps     groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted   in@@ -75,8 +89,8 @@  type Chain = [Either Value (Qualified Ident)] -matchOperators :: ModuleName -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value-matchOperators moduleName ops = G.everywhereM' (G.mkM parseChains)+matchOperators :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value+matchOperators ops = parseChains   where   parseChains :: Value -> Either String Value   parseChains b@BinaryNoParens{} = bracketChain (extendChain b)@@ -86,33 +100,34 @@   extendChain other = [Left other]   bracketChain :: Chain -> Either String Value   bracketChain = either (Left . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"-  opTable = map (map (\(name, f, a) -> P.Infix (P.try (matchOp moduleName name) >> return f) (toAssoc a))) ops-    ++ [[P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft]]+  opTable = [P.Infix (P.try (parseTicks >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft]+            : 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 +token :: (P.Stream s Identity t, Show t) => (t -> Maybe a) -> P.Parsec s u a+token = P.token show (const (P.initialPos ""))+ parseValue :: P.Parsec Chain () Value-parseValue = P.token show (const (P.initialPos "")) (either Just (const Nothing)) P.<?> "expression"+parseValue = token (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"+parseOp = token (either (const Nothing) fromOp) P.<?> "operator"+  where+  fromOp q@(Qualified _ (Op _)) = Just q+  fromOp _ = Nothing -matchOp :: ModuleName -> Qualified Ident -> P.Parsec Chain () ()-matchOp moduleName op = do-  ident <- parseOp-  guard (qualify moduleName ident == qualify moduleName op)+parseTicks :: P.Parsec Chain () (Qualified Ident)+parseTicks = token (either (const Nothing) fromOp) P.<?> "infix function"+  where+  fromOp q@(Qualified _ (Ident _)) = Just q+  fromOp _ = Nothing -collectFixities :: M.Map (Qualified Ident) Fixity -> ModuleName -> [Declaration] -> Either String (M.Map (Qualified Ident) Fixity)-collectFixities m _ [] = return m-collectFixities m moduleName (FixityDeclaration fixity name : rest) = do-  let qual = Qualified (Just moduleName) (Op name)-  when (qual `M.member` m) (Left $ "redefined fixity for " ++ show name)-  collectFixities (M.insert qual fixity m) moduleName rest-collectFixities m moduleName (ImportDeclaration importedModule _ : rest) = do-  let fs = [ (i, fixity) | (Qualified mn i, fixity) <- M.toList m, mn == Just importedModule ]-  let m' = M.fromList (map (first (Qualified (Just moduleName))) fs)-  collectFixities (m' `M.union` m) moduleName rest-collectFixities m moduleName (_:ds) = collectFixities m moduleName ds+matchOp :: Qualified Ident -> P.Parsec Chain () ()+matchOp op = do+  ident <- parseOp+  guard $ ident == op
src/Language/PureScript/TypeChecker.hs view
@@ -36,6 +36,7 @@ import Language.PureScript.Kinds import Language.PureScript.Declarations import Language.PureScript.Environment+import Language.PureScript.Pretty.Types  addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check () addDataType moduleName name args dctors ctorKind = do@@ -86,8 +87,8 @@   env <- getEnv   when (ctor `M.member` typeSynonyms env) $ throwError "Type synonym instances are disallowed"   return ()-checkTypeClassInstance m (TypeApp ty (TypeVar _)) = checkTypeClassInstance m ty-checkTypeClassInstance _ _ = throwError "Type class instance must be of the form T a1 ... an"+checkTypeClassInstance m (TypeApp t1 t2) = checkTypeClassInstance m t1 >> checkTypeClassInstance m t2+checkTypeClassInstance _ ty = throwError $ "Type class instance head is invalid: " ++ prettyPrintType ty  -- | -- Type check all declarations in a module@@ -173,15 +174,12 @@   env <- getEnv   guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (moduleName, Op name) $ names env   return $ d : ds-typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName _) : rest) = do+typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName _ _) : rest) = do   env <- getEnv-  let instances = filter (\tcd ->-                    let Qualified (Just mn) _ = tcdName tcd in-                    moduleName == mn && tcdType tcd == TCDRegular-                  ) (typeClassDictionaries env)+  let instances = filter (\tcd -> let Qualified (Just mn) _ = tcdName tcd in moduleName == mn) (typeClassDictionaries env)   forM_ instances $ \tcd -> do     let (Qualified _ ident) = tcdName tcd-    addTypeClassDictionaries [tcd { tcdName = Qualified (Just currentModule) ident, tcdType = TCDAlias (tcdName tcd) }]+    addTypeClassDictionaries [tcd { tcdName = Qualified (Just currentModule) ident, tcdType = TCDAlias (canonicalizeDictionary tcd) }]   ds <- typeCheckAll mainModuleName currentModule rest   return $ d : ds typeCheckAll mainModuleName moduleName (d@(TypeClassDeclaration pn args tys) : rest) = do
src/Language/PureScript/TypeChecker/Kinds.hs view
@@ -134,7 +134,7 @@ infer (TypeConstructor v) = do   env <- liftCheck getEnv   case M.lookup v (types env) of-    Nothing -> UnifyT . lift . throwError $ "Unknown type constructor '" ++ show v ++ "'" ++ show (M.keys (types env))+    Nothing -> UnifyT . lift . throwError $ "Unknown type constructor '" ++ show v ++ "'"     Just (kind, _) -> return kind infer (TypeApp t1 t2) = do   k0 <- fresh
src/Language/PureScript/TypeChecker/Monad.hs view
@@ -153,11 +153,17 @@ modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })  -- |--- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.+-- Run a computation in the Check monad, starting with an empty @Environment@ -- runCheck :: Check a -> Either String (a, Environment)-runCheck c = do-  (a, s) <- flip runStateT (CheckState initEnvironment 0 0 Nothing) $ unCheck c+runCheck = runCheck' initEnvironment++-- |+-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.+--+runCheck' :: Environment -> Check a -> Either String (a, Environment)+runCheck' env c = do+  (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c   return (a, checkEnv s)  -- |
src/Language/PureScript/TypeChecker/Types.hs view
@@ -118,6 +118,9 @@   unifyTypes' r1 r2@RCons{} = unifyRows r1 r2   unifyTypes' r1@REmpty r2 = unifyRows r1 r2   unifyTypes' r1 r2@REmpty = unifyRows r1 r2+  unifyTypes' t@(ConstrainedType _ _) _ = throwError $ "Attempted to unify a constrained type " ++ prettyPrintType t +++                                                       " with another type."+  unifyTypes' t3 t4@(ConstrainedType _ _) = unifyTypes' t4 t3   unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."  -- |@@ -179,7 +182,7 @@       -- If the declaration is a function, it has access to other values in the binding group.       -- If not, the generated code might fail at runtime since those values might be undefined.       let dict' = if isFunction val then dict else M.empty-      triple@(_, (val', ty)) <- case e of+      triple@(_, (_, ty)) <- case e of         -- Typed declarations         (ident, (val', Just (ty, checkType))) -> do           -- Kind check@@ -201,8 +204,6 @@       when (Just moduleName == mainModuleName && fst e == Ident C.main) $ do         [eff, a] <- replicateM 2 fresh         ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"])) (ProperName "Eff"))) eff) a-      -- Make sure unification variables do not escape-      escapeCheck val' ty       return triple   forM tys $ \(ident, (val, ty)) -> do     -- Replace type class dictionary placeholders with actual dictionaries@@ -245,21 +246,22 @@ replaceTypeClassDictionaries :: ModuleName -> Value -> Check Value replaceTypeClassDictionaries mn = everywhereM' (mkM go)   where-  go (TypeClassDictionary constraint dicts) = entails mn dicts constraint+  go (TypeClassDictionary constraint dicts) = do+    env <- getEnv+    entails env mn dicts constraint   go other = return other  -- | -- Check that the current set of type class dictionaries entail the specified type class goal, and, if so, -- return a type class dictionary reference. ---entails :: ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Check Value-entails moduleName context goal@(className, tys) = do-  env <- getEnv-  case go env goal of-    [] -> throwError $ "No " ++ show className ++ " instance found for " ++ intercalate ", " (map prettyPrintType tys) ++ show (typeClassDictionaries env)+entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Check Value+entails env moduleName context goal@(className, tys) = do+  case go goal of+    [] -> throwError $ "No " ++ show className ++ " instance found for " ++ intercalate ", " (map prettyPrintType tys)     (dict : _) -> return dict   where-  go env (className', tys') =+  go (className', tys') =     [ mkDictionary (canonicalizeDictionary tcd) args     | tcd <- context     -- Choose type class dictionaries in scope in the current module@@ -269,14 +271,14 @@     -- Make sure the type unifies with the type in the type instance definition     , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)     -- Solve any necessary subgoals-    , args <- solveSubgoals env subst (tcdDependencies tcd) ]+    , args <- solveSubgoals subst (tcdDependencies tcd) ]   -- Create dictionaries for subgoals which still need to be solved by calling go recursively   -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type   -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.-  solveSubgoals :: Environment -> [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [Value]]-  solveSubgoals _ _ Nothing = return Nothing-  solveSubgoals env subst (Just subgoals) = do-    dict <- mapM (go env . second (map (replaceAllTypeVars subst))) subgoals+  solveSubgoals :: [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [Value]]+  solveSubgoals _ Nothing = return Nothing+  solveSubgoals subst (Just subgoals) = do+    dict <- mapM (go . second (map (replaceAllTypeVars subst))) subgoals     return $ Just dict   -- Make a dictionary from subgoal dictionaries by applying the correct function   mkDictionary :: Qualified Ident -> Maybe [Value] -> Value@@ -288,54 +290,53 @@   filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True   filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True   filterModule _ = False-  canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident-  canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm-  canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm   -- Ensure that a substitution is valid   verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]   verifySubstitution subst = do     let grps = groupBy ((==) `on` fst) subst-    guard (all ((==) 1 . length . nubBy ((==) `on` snd)) grps)+    guard (all (pairwise (unifiesWith env) . map snd) grps)     return $ map head grps  -- |+-- Check all values in a list pairwise match a predicate+--+pairwise :: (a -> a -> Bool) -> [a] -> Bool+pairwise _ [] = True+pairwise _ [_] = True+pairwise p (x : xs) = all (p x) xs && pairwise p xs++-- |+-- Check that two types unify+--+unifiesWith :: Environment -> Type -> Type -> Bool+unifiesWith _ (TUnknown _) _ = True+unifiesWith _ _ (TUnknown _) = True+unifiesWith _ (Skolem s1 _) (Skolem s2 _) | s1 == s2 = True+unifiesWith _ (TypeVar v1) (TypeVar v2) | v1 == v2 = True+unifiesWith _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = True+unifiesWith e (TypeApp h1 t1) (TypeApp h2 t2) = unifiesWith e h1 h2 && unifiesWith e t1 t2+unifiesWith e (SaturatedTypeSynonym name args) t2 =+  case expandTypeSynonym' e name args of+    Left  _  -> False+    Right t1 -> unifiesWith e t1 t2+unifiesWith e t1 t2@(SaturatedTypeSynonym _ _) = unifiesWith e t2 t1+unifiesWith _ _ _ = False++-- | -- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup), -- and return a substitution from type variables to types which makes the type heads unify. -- typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)] typeHeadsAreEqual _ _ (Skolem s1 _) (Skolem s2 _) | s1 == s2 = Just []-typeHeadsAreEqual _ _ (TypeVar v) t = Just [(v, t)] typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)] typeHeadsAreEqual _ _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []-typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2-typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1+typeHeadsAreEqual m e (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m e h1 h2 <*> typeHeadsAreEqual m e t1 t2 typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e name args of   Left  _  -> Nothing   Right t1 -> typeHeadsAreEqual m e t1 t2 typeHeadsAreEqual _ _ _ _ = Nothing  -- |--- Ensure unsolved unification variables do not escape----escapeCheck :: Value -> Type -> UnifyT Type Check ()-escapeCheck value ty = do-  subst <- unifyCurrentSubstitution <$> UnifyT get-  let visibleUnknowns = nub $ unknowns $ subst $? ty-  let allUnknowns = findAllTypes value-  forM_ allUnknowns $ \t -> do-    let unsolvedUnknowns = nub . unknowns $ subst $? t-    guardWith "Escape check fails" $ null $ unsolvedUnknowns \\ visibleUnknowns---- |--- Find all type annotations occuring inside a value----findAllTypes :: Value -> [Type]-findAllTypes = everything (++) (mkQ [] go)-  where-  go (TypedValue _ _ ty) = [ty]-  go _ = []---- | -- Ensure skolem variables do not escape their scope -- skolemEscapeCheck :: Value -> Check ()@@ -519,7 +520,7 @@ infer' (Abs (Right _) _) = error "Binder was not desugared" infer' (App f arg) = do   f'@(TypedValue _ _ ft) <- infer f-  (ret, app) <- checkFunctionApplication f' ft arg+  (ret, app) <- checkFunctionApplication f' ft arg Nothing   return $ TypedValue True app ret infer' (Var var) = do   Just moduleName <- checkCurrentModule <$> get@@ -716,7 +717,8 @@   return $ TypedValue True v t check' v@(BooleanLiteral _) t | t == tyBoolean =   return $ TypedValue True v t-check' (ArrayLiteral vals) t@(TypeApp a ty) | a == tyArray = do+check' (ArrayLiteral vals) t@(TypeApp a ty) = do+  a =?= tyArray   array <- ArrayLiteral <$> forM vals (`check` ty)   return $ TypedValue True array t check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) | t == tyFunction = do@@ -726,8 +728,7 @@ check' (Abs (Right _) _) _ = error "Binder was not desugared" check' (App f arg) ret = do   f'@(TypedValue _ _ ft) <- infer f-  (ret', app) <- checkFunctionApplication f' ft arg-  _ <- subsumes Nothing ret' ret+  (_, app) <- checkFunctionApplication f' ft arg (Just ret)   return $ TypedValue True app ret check' v@(Var var) ty = do   Just moduleName <- checkCurrentModule <$> get@@ -746,7 +747,7 @@   case val' of     Nothing -> throwError "Unable to check type subsumption"     Just val'' -> do-      val''' <- if checkType then check val'' ty1 else return val''+      val''' <- if checkType then check val'' ty1' else return val''       return $ TypedValue checkType (TypedValue True val''' ty1) ty2 check' (Case vals binders) ret = do   vals' <- mapM infer vals@@ -822,8 +823,8 @@ -- | -- Check the type of a function application, rethrowing errors to provide a better error message ---checkFunctionApplication :: Value -> Type -> Value -> UnifyT Type Check (Type, Value)-checkFunctionApplication fn fnTy arg = rethrow errorMessage $ checkFunctionApplication' fn fnTy arg+checkFunctionApplication :: Value -> Type -> Value -> Maybe Type -> UnifyT Type Check (Type, Value)+checkFunctionApplication fn fnTy arg ret = rethrow errorMessage $ checkFunctionApplication' fn fnTy arg ret   where   errorMessage msg = "Error applying function of type "     ++ prettyPrintType fnTy@@ -833,30 +834,32 @@ -- | -- Check the type of a function application ---checkFunctionApplication' :: Value -> Type -> Value -> UnifyT Type Check (Type, Value)-checkFunctionApplication' fn (TypeApp (TypeApp tyFunction' argTy) retTy) arg = do+checkFunctionApplication' :: Value -> Type -> Value -> Maybe Type -> UnifyT Type Check (Type, Value)+checkFunctionApplication' fn (TypeApp (TypeApp tyFunction' argTy) retTy) arg ret = do   tyFunction' =?= tyFunction-  arg' <- check arg argTy+  _ <- maybe (return Nothing) (subsumes Nothing retTy) ret+  subst <- unifyCurrentSubstitution <$> UnifyT get+  arg' <- check arg (subst $? argTy)   return (retTy, App fn arg')-checkFunctionApplication' fn (ForAll ident ty _) arg = do+checkFunctionApplication' fn (ForAll ident ty _) arg ret = do   replaced <- replaceVarWithUnknown ident ty-  checkFunctionApplication fn replaced arg-checkFunctionApplication' fn u@(TUnknown _) arg = do+  checkFunctionApplication fn replaced arg ret+checkFunctionApplication' fn u@(TUnknown _) arg ret = do   arg' <- do     TypedValue _ arg' t <- infer arg     (arg'', t') <- instantiatePolyTypeWithUnknowns arg' t     return $ TypedValue True arg'' t'   let ty = (\(TypedValue _ _ t) -> t) arg'-  ret <- fresh-  u =?= function ty ret-  return (ret, App fn arg')-checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg = do+  ret' <- maybe fresh return ret+  u =?= function ty ret'+  return (ret', App fn arg')+checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg ret = do   ty <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs-  checkFunctionApplication fn ty arg-checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg = do+  checkFunctionApplication fn ty arg ret+checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do   dicts <- getTypeClassDictionaries-  checkFunctionApplication' (foldl App fn (map (flip TypeClassDictionary dicts) constraints)) fnTy arg-checkFunctionApplication' _ fnTy arg = throwError $ "Cannot apply a function of type "+  checkFunctionApplication' (foldl App fn (map (flip TypeClassDictionary dicts) constraints)) fnTy arg ret+checkFunctionApplication' _ fnTy arg _ = throwError $ "Cannot apply a function of type "   ++ prettyPrintType fnTy   ++ " to argument " ++ prettyPrintValue arg
src/Language/PureScript/Values.hs view
@@ -174,6 +174,13 @@   | TCDAlias (Qualified Ident) deriving (Show, Eq, Data, Typeable)  -- |+-- Find the original dictionary which a type class dictionary in scope refers to+--+canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident+canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm+canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm++-- | -- A statement in a do-notation block -- data DoNotationElement
tests/Main.hs view
@@ -25,7 +25,7 @@ import System.Exit import System.Process import System.FilePath (pathSeparator)-import System.Directory (getCurrentDirectory, getDirectoryContents, findExecutable)+import System.Directory (getCurrentDirectory, getTemporaryDirectory, getDirectoryContents, findExecutable) import Text.Parsec (ParseError) import qualified Paths_purescript as Paths import qualified System.IO.UTF8 as U@@ -38,62 +38,66 @@   text <- U.readFile inputFile   return $ P.runIndentParser inputFile P.parseModules text -compile :: P.Options -> [FilePath] -> IO (Either String String)+compile :: P.Options -> [FilePath] -> IO (Either String (String, String, P.Environment)) compile opts inputFiles = do   modules <- readInput inputFiles   case modules of     Left parseError ->       return (Left $ show parseError)-    Right ms ->-      case P.compile opts ms of-        Left typeError ->-          return (Left typeError)-        Right (js, _, _) ->-          return (Right js)+    Right ms -> return $ P.compile opts ms -assert :: P.Options -> [FilePath] -> (Either String String -> IO (Maybe String)) -> IO ()-assert opts inputFiles f = do-  e <- compile opts inputFiles+assert :: FilePath -> P.Options -> FilePath -> (Either String (String, String, P.Environment) -> IO (Maybe String)) -> IO ()+assert preludeExterns opts inputFile f = do+  e <- compile opts [preludeExterns, inputFile]   maybeErr <- f e   case maybeErr of     Just err -> putStrLn err >> exitFailure     Nothing -> return () -assertCompiles :: FilePath -> IO ()-assertCompiles inputFile = do-  putStrLn $ "assert " ++ inputFile ++ " compiles successfully"-  prelude <- preludeFilename-  assert (P.defaultOptions { P.optionsMain = Just "Main", P.optionsNoOptimizations = True, P.optionsModules = ["Main"] }) [prelude, inputFile] $ either (return . Just) $ \js -> do+assertCompiles :: FilePath -> FilePath -> FilePath -> IO ()+assertCompiles preludeJs preludeExterns inputFile = do+  putStrLn $ "Assert " ++ inputFile ++ " compiles successfully"+  let options = P.defaultOptions { P.optionsMain = Just "Main", P.optionsModules = ["Main"], P.optionsCodeGenModules = ["Main"] }+  assert preludeExterns options inputFile $ either (return . Just) $ \(js, _, _) -> do     process <- findNodeProcess-    result <- traverse (\node -> readProcessWithExitCode node [] js) process+    result <- traverse (\node -> readProcessWithExitCode node [] (preludeJs ++ 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" -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"-  assert P.defaultOptions [inputFile] $ \e ->+assertDoesNotCompile :: FilePath -> FilePath -> IO ()+assertDoesNotCompile preludeExterns inputFile = do+  putStrLn $ "Assert " ++ inputFile ++ " does not compile"+  assert preludeExterns P.defaultOptions inputFile $ \e ->     case e of       Left _ -> return Nothing       Right _ -> return $ Just "Should not have compiled" +findNodeProcess :: IO (Maybe String)+findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names+    where names = ["nodejs", "node"]+ main :: IO () main = do-  cd <- getCurrentDirectory-  putStrLn cd-  let examples = cd ++ pathSeparator : "examples"-  let passing = examples ++ pathSeparator : "passing"-  passingTestCases <- getDirectoryContents passing-  forM_ passingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $-    assertCompiles (passing ++ pathSeparator : inputFile)-  let failing = examples ++ pathSeparator : "failing"-  failingTestCases <- getDirectoryContents failing-  forM_ failingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $-    assertDoesNotCompile (failing ++ pathSeparator : inputFile)-  exitSuccess+  prelude <- preludeFilename+  putStrLn "Compiling Prelude"+  preludeResult <- compile P.defaultOptions [prelude]+  case preludeResult of+    Left err -> putStrLn err >> exitFailure+    Right (preludeJs, exts, _) -> do+      tmp <- getTemporaryDirectory+      let preludeExterns = tmp ++ pathSeparator : "prelude.externs"+      writeFile preludeExterns exts+      putStrLn $ "Wrote " ++ preludeExterns+      cd <- getCurrentDirectory+      let examples = cd ++ pathSeparator : "examples"+      let passing = examples ++ pathSeparator : "passing"+      passingTestCases <- getDirectoryContents passing+      forM_ passingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $+        assertCompiles preludeJs preludeExterns (passing ++ pathSeparator : inputFile)+      let failing = examples ++ pathSeparator : "failing"+      failingTestCases <- getDirectoryContents failing+      forM_ failingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $+        assertDoesNotCompile preludeExterns (failing ++ pathSeparator : inputFile)+      exitSuccess