summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-03-18 22:31:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-03-18 22:31:00 (GMT)
commit22f2ab9d5dabb1a6265ce8308bf7ef2c6cd05983 (patch)
tree574b27edc0c444a378ade9d544b761f51cf845c6
parent8479f575b85a65974e778a41135fdf866977bb15 (diff)
version 0.4.60.4.6
-rw-r--r--prelude/prelude.purs337
-rw-r--r--psc/Main.hs111
-rw-r--r--psci/Main.hs4
-rw-r--r--purescript.cabal6
-rw-r--r--src/Language/PureScript.hs123
-rw-r--r--src/Language/PureScript/CodeGen/Externs.hs2
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs9
-rw-r--r--src/Language/PureScript/Declarations.hs5
-rw-r--r--src/Language/PureScript/ModuleDependencies.hs2
-rw-r--r--src/Language/PureScript/Options.hs6
-rw-r--r--src/Language/PureScript/Parser/Common.hs2
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs17
-rw-r--r--src/Language/PureScript/Sugar.hs4
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs5
-rw-r--r--src/Language/PureScript/Sugar/Names.hs107
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs103
-rw-r--r--src/Language/PureScript/TypeChecker.hs14
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs2
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs12
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs131
-rw-r--r--src/Language/PureScript/Values.hs7
-rw-r--r--tests/Main.hs78
22 files changed, 739 insertions, 348 deletions
diff --git a/prelude/prelude.purs b/prelude/prelude.purs
index f366525..bb64b87 100644
--- a/prelude/prelude.purs
+++ b/prelude/prelude.purs
@@ -6,18 +6,22 @@ module Prelude where
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 @@ module Prelude where
(==) _ _ = 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 >
+
+ (>) :: forall a. (Ord a) => a -> a -> Boolean
+ (>) a1 a2 = case a1 `compare` a2 of
+ GT -> true
+ _ -> false
+
infixl 4 <=
- infixl 4 >=
- class Ord a where
- (<) :: a -> a -> Boolean
- (>) :: a -> a -> Boolean
- (<=) :: a -> a -> Boolean
- (>=) :: a -> a -> Boolean
-
- foreign import numLess "function numLess(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 numLessEq "function numLessEq(n1) {\
- \ return function(n2) {\
- \ return n1 <= n2;\
- \ };\
- \}" :: Number -> Number -> Boolean
+ infixl 4 >=
- foreign import numGreater "function numGreater(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 numGreaterEq "function numGreaterEq(n1) {\
- \ return function(n2) {\
- \ return n1 >= n2;\
- \ };\
- \}" :: Number -> Number -> Boolean
+ 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 Prelude where
module Data.Monoid where
import Prelude
- import Data.Array (foldl)
infixr 6 <>
@@ -339,13 +349,30 @@ module Data.Monoid where
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 @@ module Control.Monad where
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 @@ module Control.Monad where
(<=<) :: 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 @@ module Control.Monad where
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 @@ module Data.Maybe where
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 @@ module Data.Either where
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 @@ module Data.Array where
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 @@ module Data.Array where
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 @@ module Data.Array where
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 @@ module Data.Array where
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 @@ module Data.Tuple where
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 @@ module Data.Tuple where
(==) (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 @@ module Data.String where
foreign import split "function split(sep) {\
\ return function(s) {\
- \ return s.split(s);\
+ \ return s.split(sep);\
\ };\
\}" :: String -> String -> [String]
@@ -909,19 +929,19 @@ module Math where
\}" :: 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 @@ module Random where
\ 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 @@ module Data.Enum where
class Enum a where
toEnum :: Number -> Maybe a
fromEnum :: a -> Number
-
+
module Text.Parsing.Read where
class Read a where
@@ -1223,3 +1243,154 @@ module Text.Parsing.Read where
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
diff --git a/psc/Main.hs b/psc/Main.hs
index 86baae9..bb6bd9c 100644
--- a/psc/Main.hs
+++ b/psc/Main.hs
@@ -12,47 +12,98 @@
--
-----------------------------------------------------------------------------
+{-# 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
-
-compile :: P.Options -> Maybe [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()
-compile opts input output externs = do
+ 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)
+
+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" ])
@@ -94,6 +145,10 @@ noOpts :: Term Bool
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 :: Term [String]
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 @@ stdInOrInputFiles prelude = combine <$> useStdIn <*> (not <$> noPrelude) <*> inp
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
diff --git a/psci/Main.hs b/psci/Main.hs
index 8e0d236..5d2e787 100644
--- a/psci/Main.hs
+++ b/psci/Main.hs
@@ -195,7 +195,7 @@ completion = completeWord Nothing " \t\n\r" findCompletions
-- | 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 :: Bool -> PSCiState -> P.Value -> P.Module
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
diff --git a/purescript.cabal b/purescript.cabal
index e4a7984..78b6568 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -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 @@ 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, 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 psc
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
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index d0b2562..ad3c08c 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -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 Language.PureScript.DeadCodeElimination as P
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 @@ import qualified Data.Map as M
-- * 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
diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs
index ccb88da..bf37fb9 100644
--- a/src/Language/PureScript/CodeGen/Externs.hs
+++ b/src/Language/PureScript/CodeGen/Externs.hs
@@ -57,7 +57,7 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite
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"
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index eb20d6a..b224ea9 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -52,11 +52,14 @@ moduleToJs opts (Module name decls (Just exps)) env =
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"
-- |
diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs
index 53ce6a9..1410f5f 100644
--- a/src/Language/PureScript/Declarations.hs
+++ b/src/Language/PureScript/Declarations.hs
@@ -117,9 +117,10 @@ data Declaration
--
| 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)
--
diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs
index 19f7aeb..77446ca 100644
--- a/src/Language/PureScript/ModuleDependencies.hs
+++ b/src/Language/PureScript/ModuleDependencies.hs
@@ -47,7 +47,7 @@ usedModules = nub . everything (++) (mkQ [] qualifiedIdents `extQ` qualifiedProp
qualifiedProperNames (Qualified (Just mn) _) = [mn]
qualifiedProperNames _ = []
imports :: Declaration -> [ModuleName]
- imports (ImportDeclaration mn _) = [mn]
+ imports (ImportDeclaration mn _ _) = [mn]
imports _ = []
getModuleName :: Module -> ModuleName
diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs
index 1ddcb3c..d701d70 100644
--- a/src/Language/PureScript/Options.hs
+++ b/src/Language/PureScript/Options.hs
@@ -49,10 +49,14 @@ data Options = Options {
-- 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" [] []
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index dde950d..810680a 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -328,7 +328,7 @@ buildPostfixParser fs first = do
-- 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
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index edcf656..0b011eb 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -99,9 +99,20 @@ parseImportDeclaration :: P.Parsec String ParseState Declaration
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
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index aa2abe3..2aa7af9 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -49,11 +49,11 @@ import Language.PureScript.Sugar.Names as S
-- * Qualify any unqualified names and types
--
desugar :: [Module] -> Either String [Module]
-desugar = rebracket
- >=> desugarDo
+desugar = desugarDo
>=> desugarLetBindings
>>> desugarCasesModule
>=> desugarImports
+ >=> rebracket
>=> desugarTypeDeclarationsModule
>=> desugarTypeClasses
>=> createBindingGroupsModule
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index a729969..c695dcd 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -25,6 +25,7 @@ import Data.Data
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 :: (Data d) => ModuleName -> d -> [ProperName]
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 _ = []
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index fcebe16..92eb722 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -16,7 +16,7 @@ module Language.PureScript.Sugar.Names (
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 @@ data ImportEnvironment = ImportEnvironment
-- |
-- 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 @@ updateExportedModule env mn update = do
-- |
-- 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 @@ renameInModule imports exports (Module mn decls exps) =
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 @@ renameInModule imports exports (Module mn decls exps) =
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)
-
- -- 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) ++ "'"
+ 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))
+
+ -- 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 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) pri
-- 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 @@ type ExplicitImports = [DeclarationRef]
-- 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 @@ resolveImports env (Module currentModule decls _) =
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 @@ resolveImport currentModule importModule exps imps = maybe importAll (foldM impo
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
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index 5320404..6252c92 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -17,7 +17,7 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE Rank2Types, FlexibleContexts #-}
module Language.PureScript.Sugar.Operators (
rebracket
@@ -28,13 +28,14 @@ import Language.PureScript.Declarations
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 @@ import qualified Text.Parsec.Expr as P
-- 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 (Parens val) = val
+ go 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 _ = []
+
+ensureNoDuplicates :: [Qualified Ident] -> Either String ()
+ensureNoDuplicates m = go $ sort m
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
-
-removeParens :: Value -> Value
-removeParens (Parens val) = val
-removeParens val = val
-
-customOperatorTable :: M.Map (Qualified Ident) Fixity -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]]
+ 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 @@ customOperatorTable fixities =
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 @@ matchOperators moduleName ops = G.everywhereM' (G.mkM parseChains)
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
+
+parseTicks :: P.Parsec Chain () (Qualified Ident)
+parseTicks = token (either (const Nothing) fromOp) P.<?> "infix function"
+ where
+ fromOp q@(Qualified _ (Ident _)) = Just q
+ fromOp _ = Nothing
-matchOp :: ModuleName -> Qualified Ident -> P.Parsec Chain () ()
-matchOp moduleName op = do
+matchOp :: Qualified Ident -> P.Parsec Chain () ()
+matchOp op = do
ident <- parseOp
- guard (qualify moduleName ident == qualify moduleName op)
-
-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
+ guard $ ident == op
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 6af31a7..8f26f01 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -36,6 +36,7 @@ import Language.PureScript.Values
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 @@ checkTypeClassInstance _ (TypeConstructor ctor) = do
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 @@ typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = d
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
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index aac09b8..fbe9eaa 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -134,7 +134,7 @@ infer (TypeVar v) = do
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
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index c4a5312..6f3427e 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -153,11 +153,17 @@ modifyEnv :: (MonadState CheckState m) => (Environment -> Environment) -> m ()
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)
-- |
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 40a7703..d4749fe 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -118,6 +118,9 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +
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 @@ typesOf mainModuleName moduleName vals = do
-- 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 @@ typesOf mainModuleName moduleName vals = do
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 @@ overTypes f = everywhere (mkT f)
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 @@ entails moduleName context goal@(className, tys) = do
-- 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 @@ entails moduleName context goal@(className, tys) = do
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 (Left arg) ret) = do
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 @@ check' v@(StringLiteral _) t | t == tyString =
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 (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) | t == tyFuncti
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 @@ check' (TypedValue checkType val ty1) ty2 = do
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 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
-- |
-- 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 @@ checkFunctionApplication fn fnTy arg = rethrow errorMessage $ checkFunctionAppli
-- |
-- 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
diff --git a/src/Language/PureScript/Values.hs b/src/Language/PureScript/Values.hs
index 76c900b..29ba4ae 100644
--- a/src/Language/PureScript/Values.hs
+++ b/src/Language/PureScript/Values.hs
@@ -174,6 +174,13 @@ data TypeClassDictionaryType
| 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
diff --git a/tests/Main.hs b/tests/Main.hs
index 03b0ed0..7981faf 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -25,7 +25,7 @@ import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
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 @@ readInput inputFiles = fmap (fmap concat . sequence) $ forM inputFiles $ \inputF
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