diff options
author | PhilFreeman <> | 2014-11-08 21:23:00 (GMT) |
---|---|---|
committer | hdiff <hdiff@hdiff.luite.com> | 2014-11-08 21:23:00 (GMT) |
commit | ffa65f27c5b68bd44bab7169c36cc05b651c29f8 (patch) | |
tree | 07952979b9b4f5c1f06a846384084b9376bc014c | |
parent | 657524098de0309d959c2e93175116bc3e20db5e (diff) |
version 0.6.00.6.0
29 files changed, 368 insertions, 1147 deletions
@@ -1,6 +1,6 @@ The MIT License (MIT) -Copyright (c) 2013 Phil Freeman +Copyright (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in diff --git a/examples/failing/MultipleErrors2.purs b/examples/failing/MultipleErrors2.purs new file mode 100644 index 0000000..f4f4a98 --- /dev/null +++ b/examples/failing/MultipleErrors2.purs @@ -0,0 +1,5 @@ +module MultipleErrors2 where + +foo = itDoesntExist + +bar = neitherDoesThis diff --git a/examples/passing/MutRec2.purs b/examples/passing/MutRec2.purs new file mode 100644 index 0000000..6f828b0 --- /dev/null +++ b/examples/passing/MutRec2.purs @@ -0,0 +1,17 @@ +module Main where + +data A = A B + +data B = B A + +foreign import data S :: * + +f :: A -> S +f a = case a of A b -> g b + +g b = case b of B a -> f a + +showN :: A -> S +showN a = f a + +main = Debug.Trace.trace "Done" diff --git a/examples/passing/MutRec3.purs b/examples/passing/MutRec3.purs new file mode 100644 index 0000000..0db2de8 --- /dev/null +++ b/examples/passing/MutRec3.purs @@ -0,0 +1,17 @@ +module Main where + +data A = A B + +data B = B A + +foreign import data S :: * + +f a = case a of A b -> g b + +g :: B -> S +g b = case b of B a -> f a + +showN :: A -> S +showN a = f a + +main = Debug.Trace.trace "Done" diff --git a/examples/passing/ObjectUpdate2.purs b/examples/passing/ObjectUpdate2.purs new file mode 100644 index 0000000..98af5d3 --- /dev/null +++ b/examples/passing/ObjectUpdate2.purs @@ -0,0 +1,14 @@ +module Main where + +type X r = { | r } + +foreign import x "var x = {};" :: forall r. X r + +blah :: forall r. X r -> X r +blah x = x + +test = blah x + { baz = "blah" + } + +main = Debug.Trace.trace "Done" diff --git a/examples/passing/TypeClassImport.purs b/examples/passing/TypeClassImport.purs new file mode 100644 index 0000000..4ddcaea --- /dev/null +++ b/examples/passing/TypeClassImport.purs @@ -0,0 +1,18 @@ +module Main where + +foreign import data T :: * + +foreign import data C :: * + +foreign import t "var t = null;" :: T + +foreign import inst """ + var inst = { + show: function(t) { + return 'Done'; + } + }""" :: C + +foreign import instance inst :: Show T + +main = Debug.Trace.print t diff --git a/prelude/prelude.purs b/prelude/prelude.purs deleted file mode 100644 index 8a4d317..0000000 --- a/prelude/prelude.purs +++ /dev/null @@ -1,944 +0,0 @@ -module Prelude - ( flip - , const - , asTypeOf - , Semigroupoid, (<<<), (>>>) - , Category, id - , ($), (#) - , (:), cons - , Show, show - , Functor, (<$>), void - , Apply, (<*>) - , Applicative, pure, liftA1 - , Bind, (>>=) - , Monad, return, liftM1, ap - , Num, (+), (-), (*), (/), (%) - , negate - , Eq, (==), (/=), refEq, refIneq - , Ord, Ordering(..), compare, (<), (>), (<=), (>=) - , Bits, (&), (|), (^), shl, shr, zshr, complement - , BoolLike, (&&), (||) - , not - , Semigroup, (<>), (++) - , Unit(..), unit - ) where - - flip :: forall a b c. (a -> b -> c) -> b -> a -> c - flip f b a = f a b - - const :: forall a b. a -> b -> a - const a _ = a - - asTypeOf :: forall a. a -> a -> a - asTypeOf x _ = x - - infixr 9 >>> - infixr 9 <<< - - class Semigroupoid a where - (<<<) :: forall b c d. a c d -> a b c -> a b d - - instance semigroupoidArr :: Semigroupoid (->) where - (<<<) f g x = f (g x) - - (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d - (>>>) f g = g <<< f - - class (Semigroupoid a) <= Category a where - id :: forall t. a t t - - instance categoryArr :: Category (->) where - id x = x - - infixr 0 $ - infixl 0 # - - ($) :: forall a b. (a -> b) -> a -> b - ($) f x = f x - - (#) :: forall a b. a -> (a -> b) -> b - (#) x f = f x - - infixr 6 : - - (:) :: forall a. a -> [a] -> [a] - (:) = cons - - foreign import cons - "function cons(e) {\ - \ return function(l) {\ - \ return [e].concat(l);\ - \ };\ - \}" :: forall a. a -> [a] -> [a] - - class Show a where - show :: a -> String - - foreign import showStringImpl - "function showStringImpl(s) {\ - \ return JSON.stringify(s);\ - \}" :: String -> String - - instance showUnit :: Show Unit where - show (Unit {}) = "Unit {}" - - instance showString :: Show String where - show = showStringImpl - - instance showBoolean :: Show Boolean where - show true = "true" - show false = "false" - - foreign import showNumberImpl "function showNumberImpl(n) {\ - \ return n.toString();\ - \}" :: Number -> String - - instance showNumber :: Show Number where - show = showNumberImpl - - foreign import showArrayImpl - "function showArrayImpl(f) {\ - \ return function(xs) {\ - \ var ss = [];\ - \ for (var i = 0, l = xs.length; i < l; i++) {\ - \ ss[i] = f(xs[i]);\ - \ }\ - \ return '[' + ss.join(',') + ']';\ - \ };\ - \}" :: forall a. (a -> String) -> [a] -> String - - instance showArray :: (Show a) => Show [a] where - show = showArrayImpl show - - infixl 4 <$> - - class Functor f where - (<$>) :: forall a b. (a -> b) -> f a -> f b - - void :: forall f a. (Functor f) => f a -> f Unit - void fa = const unit <$> fa - - infixl 4 <*> - - class (Functor f) <= Apply f where - (<*>) :: forall a b. f (a -> b) -> f a -> f b - - class (Apply f) <= Applicative f where - pure :: forall a. a -> f a - - liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b - liftA1 f a = pure f <*> a - - infixl 1 >>= - - class (Apply m) <= Bind m where - (>>=) :: forall a b. m a -> (a -> m b) -> m b - - class (Applicative m, Bind m) <= Monad m - - return :: forall m a. (Monad m) => a -> m a - return = pure - - liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b - liftM1 f a = do - a' <- a - return (f a') - - ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b - ap f a = do - f' <- f - a' <- a - return (f' a') - - instance functorArr :: Functor ((->) r) where - (<$>) = (<<<) - - instance applyArr :: Apply ((->) r) where - (<*>) f g x = f x (g x) - - instance applicativeArr :: Applicative ((->) r) where - pure = const - - instance bindArr :: Bind ((->) r) where - (>>=) m f x = f (m x) x - - instance monadArr :: Monad ((->) r) - - infixl 7 * - infixl 7 / - infixl 7 % - - infixl 6 - - infixl 6 + - - class Num a where - (+) :: a -> a -> a - (-) :: a -> a -> a - (*) :: a -> a -> a - (/) :: a -> a -> a - (%) :: a -> a -> a - negate :: a -> a - - foreign import numAdd "function numAdd(n1) {\ - \ return function(n2) {\ - \ return n1 + n2;\ - \ };\ - \}" :: Number -> Number -> Number - - foreign import numSub "function numSub(n1) {\ - \ return function(n2) {\ - \ return n1 - n2;\ - \ };\ - \}" :: Number -> Number -> Number - - foreign import numMul "function numMul(n1) {\ - \ return function(n2) {\ - \ return n1 * n2;\ - \ };\ - \}" :: Number -> Number -> Number - - foreign import numDiv "function numDiv(n1) {\ - \ return function(n2) {\ - \ return n1 / n2;\ - \ };\ - \}" :: Number -> Number -> Number - - foreign import numMod "function numMod(n1) {\ - \ return function(n2) {\ - \ return n1 % n2;\ - \ };\ - \}" :: Number -> Number -> Number - - foreign import numNegate "function numNegate(n) {\ - \ return -n;\ - \}" :: Number -> Number - - instance numNumber :: Num Number where - (+) = numAdd - (-) = numSub - (*) = numMul - (/) = numDiv - (%) = numMod - negate = numNegate - - newtype Unit = Unit {} - - unit :: Unit - unit = Unit {} - - infix 4 == - infix 4 /= - - class Eq a where - (==) :: a -> a -> Boolean - (/=) :: a -> a -> Boolean - - foreign import refEq - "function refEq(r1) {\ - \ return function(r2) {\ - \ return r1 === r2;\ - \ };\ - \}" :: forall a. a -> a -> Boolean - - foreign import refIneq - "function refIneq(r1) {\ - \ return function(r2) {\ - \ return r1 !== r2;\ - \ };\ - \}" :: forall a. a -> a -> Boolean - - instance eqUnit :: Eq Unit where - (==) (Unit {}) (Unit {}) = true - (/=) (Unit {}) (Unit {}) = false - - instance eqString :: Eq String where - (==) = refEq - (/=) = refIneq - - instance eqNumber :: Eq Number where - (==) = refEq - (/=) = refIneq - - instance eqBoolean :: Eq Boolean where - (==) = refEq - (/=) = refIneq - - foreign import eqArrayImpl - "function eqArrayImpl(f) {\ - \ return function(xs) {\ - \ return function(ys) {\ - \ if (xs.length !== ys.length) return false;\ - \ for (var i = 0; i < xs.length; i++) {\ - \ if (!f(xs[i])(ys[i])) return false;\ - \ }\ - \ return true;\ - \ };\ - \ };\ - \}" :: forall a. (a -> a -> Boolean) -> [a] -> [a] -> Boolean - - instance eqArray :: (Eq a) => Eq [a] where - (==) xs ys = eqArrayImpl (==) xs ys - (/=) xs ys = not (xs == ys) - - data Ordering = LT | GT | EQ - - instance eqOrdering :: Eq Ordering where - (==) LT LT = true - (==) GT GT = true - (==) EQ EQ = true - (==) _ _ = false - (/=) x y = not (x == y) - - instance showOrdering :: Show Ordering where - show LT = "LT" - show GT = "GT" - show EQ = "EQ" - - class (Eq a) <= 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 <= - - (<=) :: forall a. (Ord a) => a -> a -> Boolean - (<=) a1 a2 = case a1 `compare` a2 of - GT -> false - _ -> true - - infixl 4 >= - - (>=) :: forall a. (Ord a) => a -> a -> Boolean - (>=) a1 a2 = case a1 `compare` a2 of - LT -> false - _ -> true - - foreign import unsafeCompareImpl - "function unsafeCompareImpl(lt) {\ - \ return function(eq) {\ - \ return function(gt) {\ - \ return function(x) {\ - \ return function(y) {\ - \ return x < y ? lt : x > y ? gt : eq;\ - \ };\ - \ };\ - \ };\ - \ };\ - \}" :: forall a. Ordering -> Ordering -> Ordering -> a -> a -> Ordering - - unsafeCompare :: forall a. a -> a -> Ordering - unsafeCompare = unsafeCompareImpl LT EQ GT - - instance ordUnit :: Ord Unit where - compare (Unit {}) (Unit {}) = EQ - - instance ordBoolean :: Ord Boolean where - compare false false = EQ - compare false true = LT - compare true true = EQ - compare true false = GT - - instance ordNumber :: Ord Number where - compare = unsafeCompare - - instance ordString :: Ord String where - compare = unsafeCompare - - instance ordArray :: (Ord a) => Ord [a] where - compare [] [] = EQ - compare [] _ = LT - compare _ [] = GT - compare (x:xs) (y:ys) = case compare x y of - EQ -> compare xs ys - other -> other - - infixl 10 & - infixl 10 | - infixl 10 ^ - - class Bits b where - (&) :: b -> b -> b - (|) :: b -> b -> b - (^) :: b -> b -> b - shl :: b -> Number -> b - shr :: b -> Number -> b - zshr :: b -> Number -> b - complement :: b -> b - - foreign import numShl "function numShl(n1) {\ - \ return function(n2) {\ - \ return n1 << n2;\ - \ };\ - \}" :: Number -> Number -> Number - - foreign import numShr "function numShr(n1) {\ - \ return function(n2) {\ - \ return n1 >> n2;\ - \ };\ - \}" :: Number -> Number -> Number - - foreign import numZshr "function numZshr(n1) {\ - \ return function(n2) {\ - \ return n1 >>> n2;\ - \ };\ - \}" :: Number -> Number -> Number - - foreign import numAnd "function numAnd(n1) {\ - \ return function(n2) {\ - \ return n1 & n2;\ - \ };\ - \}" :: Number -> Number -> Number - - foreign import numOr "function numOr(n1) {\ - \ return function(n2) {\ - \ return n1 | n2;\ - \ };\ - \}" :: Number -> Number -> Number - - foreign import numXor "function numXor(n1) {\ - \ return function(n2) {\ - \ return n1 ^ n2;\ - \ };\ - \}" :: Number -> Number -> Number - - foreign import numComplement "function numComplement(n) {\ - \ return ~n;\ - \}" :: Number -> Number - - instance bitsNumber :: Bits Number where - (&) = numAnd - (|) = numOr - (^) = numXor - shl = numShl - shr = numShr - zshr = numZshr - complement = numComplement - - infixr 2 || - infixr 3 && - - class BoolLike b where - (&&) :: b -> b -> b - (||) :: b -> b -> b - not :: b -> b - - foreign import boolAnd "function boolAnd(b1) {\ - \ return function(b2) {\ - \ return b1 && b2;\ - \ };\ - \}" :: Boolean -> Boolean -> Boolean - - foreign import boolOr "function boolOr(b1) {\ - \ return function(b2) {\ - \ return b1 || b2;\ - \ };\ - \}" :: Boolean -> Boolean -> Boolean - - foreign import boolNot "function boolNot(b) {\ - \ return !b;\ - \}" :: Boolean -> Boolean - - instance boolLikeBoolean :: BoolLike Boolean where - (&&) = boolAnd - (||) = boolOr - not = boolNot - - infixr 5 <> - - class Semigroup a where - (<>) :: a -> a -> a - - foreign import concatString - "function concatString(s1) {\ - \ return function(s2) {\ - \ return s1 + s2;\ - \ };\ - \}" :: String -> String -> String - - instance semigroupUnit :: Semigroup Unit where - (<>) (Unit {}) (Unit {}) = Unit {} - - instance semigroupString :: Semigroup String where - (<>) = concatString - - instance semigroupArr :: (Semigroup s') => Semigroup (s -> s') where - (<>) f g = \x -> f x <> g x - - infixr 5 ++ - - (++) :: forall s. (Semigroup s) => s -> s -> s - (++) = (<>) - -module Data.Function where - - on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c - on f g x y = g x `f` g y - - foreign import data Fn0 :: * -> * - foreign import data Fn1 :: * -> * -> * - foreign import data Fn2 :: * -> * -> * -> * - foreign import data Fn3 :: * -> * -> * -> * -> * - foreign import data Fn4 :: * -> * -> * -> * -> * -> * - foreign import data Fn5 :: * -> * -> * -> * -> * -> * -> * - foreign import data Fn6 :: * -> * -> * -> * -> * -> * -> * -> * - foreign import data Fn7 :: * -> * -> * -> * -> * -> * -> * -> * -> * - foreign import data Fn8 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * - foreign import data Fn9 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * - foreign import data Fn10 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * - - foreign import mkFn0 - "function mkFn0(fn) {\ - \ return function() {\ - \ return fn({});\ - \ };\ - \}" :: forall a. (Unit -> a) -> Fn0 a - - foreign import mkFn1 - "function mkFn1(fn) {\ - \ return function(a) {\ - \ return fn(a);\ - \ };\ - \}" :: forall a b. (a -> b) -> Fn1 a b - - foreign import mkFn2 - "function mkFn2(fn) {\ - \ return function(a, b) {\ - \ return fn(a)(b);\ - \ };\ - \}" :: forall a b c. (a -> b -> c) -> Fn2 a b c - - foreign import mkFn3 - "function mkFn3(fn) {\ - \ return function(a, b, c) {\ - \ return fn(a)(b)(c);\ - \ };\ - \}" :: forall a b c d. (a -> b -> c -> d) -> Fn3 a b c d - - foreign import mkFn4 - "function mkFn4(fn) {\ - \ return function(a, b, c, d) {\ - \ return fn(a)(b)(c)(d);\ - \ };\ - \}" :: forall a b c d e. (a -> b -> c -> d -> e) -> Fn4 a b c d e - - foreign import mkFn5 - "function mkFn5(fn) {\ - \ return function(a, b, c, d, e) {\ - \ return fn(a)(b)(c)(d)(e);\ - \ };\ - \}" :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Fn5 a b c d e f - - foreign import mkFn6 - "function mkFn6(fn) {\ - \ return function(a, b, c, d, e, f) {\ - \ return fn(a)(b)(c)(d)(e)(f);\ - \ };\ - \}" :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> Fn6 a b c d e f g - - foreign import mkFn7 - "function mkFn7(fn) {\ - \ return function(a, b, c, d, e, f, g) {\ - \ return fn(a)(b)(c)(d)(e)(f)(g);\ - \ };\ - \}" :: forall a b c d e f g h. (a -> b -> c -> d -> e -> f -> g -> h) -> Fn7 a b c d e f g h - - foreign import mkFn8 - "function mkFn8(fn) {\ - \ return function(a, b, c, d, e, f, g, h) {\ - \ return fn(a)(b)(c)(d)(e)(f)(g)(h);\ - \ };\ - \}" :: forall a b c d e f g h i. (a -> b -> c -> d -> e -> f -> g -> h -> i) -> Fn8 a b c d e f g h i - - foreign import mkFn9 - "function mkFn9(fn) {\ - \ return function(a, b, c, d, e, f, g, h, i) {\ - \ return fn(a)(b)(c)(d)(e)(f)(g)(h)(i);\ - \ };\ - \}" :: forall a b c d e f g h i j. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) -> Fn9 a b c d e f g h i j - - foreign import mkFn10 - "function mkFn10(fn) {\ - \ return function(a, b, c, d, e, f, g, h, i, j) {\ - \ return fn(a)(b)(c)(d)(e)(f)(g)(h)(i)(j);\ - \ };\ - \}" :: forall a b c d e f g h i j k. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) -> Fn10 a b c d e f g h i j k - - foreign import runFn0 - "function runFn0(fn) {\ - \ return fn();\ - \}" :: forall a. Fn0 a -> a - - foreign import runFn1 - "function runFn1(fn) {\ - \ return function(a) {\ - \ return fn(a);\ - \ };\ - \}" :: forall a b. Fn1 a b -> a -> b - - foreign import runFn2 - "function runFn2(fn) {\ - \ return function(a) {\ - \ return function(b) {\ - \ return fn(a, b);\ - \ };\ - \ };\ - \}" :: forall a b c. Fn2 a b c -> a -> b -> c - - foreign import runFn3 - "function runFn3(fn) {\ - \ return function(a) {\ - \ return function(b) {\ - \ return function(c) {\ - \ return fn(a, b, c);\ - \ };\ - \ };\ - \ };\ - \}" :: forall a b c d. Fn3 a b c d -> a -> b -> c -> d - - foreign import runFn4 - "function runFn4(fn) {\ - \ return function(a) {\ - \ return function(b) {\ - \ return function(c) {\ - \ return function(d) {\ - \ return fn(a, b, c, d);\ - \ };\ - \ };\ - \ };\ - \ };\ - \}" :: forall a b c d e. Fn4 a b c d e -> a -> b -> c -> d -> e - - foreign import runFn5 - "function runFn5(fn) {\ - \ return function(a) {\ - \ return function(b) {\ - \ return function(c) {\ - \ return function(d) {\ - \ return function(e) {\ - \ return fn(a, b, c, d, e);\ - \ };\ - \ };\ - \ };\ - \ };\ - \ };\ - \}" :: forall a b c d e f. Fn5 a b c d e f -> a -> b -> c -> d -> e -> f - - foreign import runFn6 - "function runFn6(fn) {\ - \ return function(a) {\ - \ return function(b) {\ - \ return function(c) {\ - \ return function(d) {\ - \ return function(e) {\ - \ return function(f) {\ - \ return fn(a, b, c, d, e, f);\ - \ };\ - \ };\ - \ };\ - \ };\ - \ };\ - \ };\ - \}" :: forall a b c d e f g. Fn6 a b c d e f g -> a -> b -> c -> d -> e -> f -> g - - foreign import runFn7 - "function runFn7(fn) {\ - \ return function(a) {\ - \ return function(b) {\ - \ return function(c) {\ - \ return function(d) {\ - \ return function(e) {\ - \ return function(f) {\ - \ return function(g) {\ - \ return fn(a, b, c, d, e, f, g);\ - \ };\ - \ };\ - \ };\ - \ };\ - \ };\ - \ };\ - \ };\ - \}" :: forall a b c d e f g h. Fn7 a b c d e f g h -> a -> b -> c -> d -> e -> f -> g -> h - - foreign import runFn8 - "function runFn8(fn) {\ - \ return function(a) {\ - \ return function(b) {\ - \ return function(c) {\ - \ return function(d) {\ - \ return function(e) {\ - \ return function(f) {\ - \ return function(g) {\ - \ return function(h) {\ - \ return fn(a, b, c, d, e, f, g, h);\ - \ };\ - \ };\ - \ };\ - \ };\ - \ };\ - \ };\ - \ };\ - \ };\ - \}" :: forall a b c d e f g h i. Fn8 a b c d e f g h i -> a -> b -> c -> d -> e -> f -> g -> h -> i - - foreign import runFn9 - "function runFn9(fn) {\ - \ return function(a) {\ - \ return function(b) {\ - \ return function(c) {\ - \ return function(d) {\ - \ return function(e) {\ - \ return function(f) {\ - \ return function(g) {\ - \ return function(h) {\ - \ return function(i) {\ - \ return fn(a, b, c, d, e, f, g, h, i);\ - \ };\ - \ };\ - \ };\ - \ };\ - \ };\ - \ };\ - \ };\ - \ };\ - \ };\ - \}" :: forall a b c d e f g h i j. Fn9 a b c d e f g h i j -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j - - foreign import runFn10 - "function runFn10(fn) {\ - \ return function(a) {\ - \ return function(b) {\ - \ return function(c) {\ - \ return function(d) {\ - \ return function(e) {\ - \ return function(f) {\ - \ return function(g) {\ - \ return function(h) {\ - \ return function(i) {\ - \ return function(j) {\ - \ return fn(a, b, c, d, e, f, g, h, i, j);\ - \ };\ - \ };\ - \ };\ - \ };\ - \ };\ - \ };\ - \ };\ - \ };\ - \ };\ - \ };\ - \}" :: forall a b c d e f g h i j k. Fn10 a b c d e f g h i j k -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k - -module Data.Eq where - - newtype Ref a = Ref a - - liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b - liftRef f (Ref x) (Ref y) = f x y - - instance eqRef :: Eq (Ref a) where - (==) = liftRef refEq - (/=) = liftRef refIneq - - instance functorRef :: Functor Ref where - (<$>) f (Ref x) = Ref (f x) - -module Prelude.Unsafe where - - foreign import unsafeIndex - "function unsafeIndex(xs) {\ - \ return function(n) {\ - \ return xs[n];\ - \ };\ - \}" :: forall a. [a] -> Number -> a - -module Control.Monad.Eff where - - foreign import data Eff :: # ! -> * -> * - - foreign import returnE "function returnE(a) {\ - \ return function() {\ - \ return a;\ - \ };\ - \}" :: forall e a. a -> Eff e a - - foreign import bindE "function bindE(a) {\ - \ return function(f) {\ - \ return function() {\ - \ return f(a())();\ - \ };\ - \ };\ - \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b - - type Pure a = forall e. Eff e a - - foreign import runPure "function runPure(f) {\ - \ return f();\ - \}" :: forall a. Pure a -> a - - instance functorEff :: Functor (Eff e) where - (<$>) = liftA1 - - instance applyEff :: Apply (Eff e) where - (<*>) = ap - - instance applicativeEff :: Applicative (Eff e) where - pure = returnE - - instance bindEff :: Bind (Eff e) where - (>>=) = bindE - - instance monadEff :: Monad (Eff e) - - foreign import untilE "function untilE(f) {\ - \ return function() {\ - \ while (!f());\ - \ return {};\ - \ };\ - \}" :: forall e. Eff e Boolean -> Eff e Unit - - foreign import whileE "function whileE(f) {\ - \ return function(a) {\ - \ return function() {\ - \ while (f()) {\ - \ a();\ - \ }\ - \ return {};\ - \ };\ - \ };\ - \}" :: forall e a. Eff e Boolean -> Eff e a -> Eff e Unit - - foreign import forE "function forE(lo) {\ - \ return function(hi) {\ - \ return function(f) {\ - \ return function() {\ - \ for (var i = lo; i < hi; i++) {\ - \ f(i)();\ - \ }\ - \ };\ - \ };\ - \ };\ - \}" :: forall e. Number -> Number -> (Number -> Eff e Unit) -> Eff e Unit - - - foreign import foreachE "function foreachE(as) {\ - \ return function(f) {\ - \ return function() {\ - \ for (var i = 0; i < as.length; i++) {\ - \ f(as[i])();\ - \ }\ - \ };\ - \ };\ - \}" :: forall e a. [a] -> (a -> Eff e Unit) -> Eff e Unit - -module Control.Monad.Eff.Unsafe where - - import Control.Monad.Eff - - foreign import unsafeInterleaveEff - "function unsafeInterleaveEff(f) {\ - \ return f;\ - \}" :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a - -module Debug.Trace where - - import Control.Monad.Eff - - foreign import data Trace :: ! - - foreign import trace "function trace(s) {\ - \ return function() {\ - \ console.log(s);\ - \ return {};\ - \ };\ - \}" :: forall r. String -> Eff (trace :: Trace | r) Unit - - print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) Unit - print o = trace (show o) - -module Control.Monad.ST where - - import Control.Monad.Eff - - foreign import data ST :: * -> ! - - foreign import data STRef :: * -> * -> * - - foreign import data STArray :: * -> * -> * - - foreign import newSTRef "function newSTRef(val) {\ - \ return function() {\ - \ return { value: val };\ - \ };\ - \}" :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a) - - foreign import readSTRef "function readSTRef(ref) {\ - \ return function() {\ - \ return ref.value;\ - \ };\ - \}" :: forall a h r. STRef h a -> Eff (st :: ST h | r) a - - foreign import modifySTRef "function modifySTRef(ref) {\ - \ return function(f) {\ - \ return function() {\ - \ return ref.value = f(ref.value);\ - \ };\ - \ };\ - \}" :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a - - foreign import writeSTRef "function writeSTRef(ref) {\ - \ return function(a) {\ - \ return function() {\ - \ return ref.value = a;\ - \ };\ - \ };\ - \}" :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a - - foreign import newSTArray "function newSTArray(len) {\ - \ return function(a) {\ - \ return function() {\ - \ var arr = [];\ - \ for (var i = 0; i < len; i++) {\ - \ arr[i] = a;\ - \ };\ - \ return arr;\ - \ };\ - \ };\ - \}" :: forall a h r. Number -> a -> Eff (st :: ST h | r) (STArray h a) - - foreign import peekSTArray "function peekSTArray(arr) {\ - \ return function(i) {\ - \ return function() {\ - \ return arr[i];\ - \ };\ - \ };\ - \}" :: forall a h r. STArray h a -> Number -> Eff (st :: ST h | r) a - - foreign import pokeSTArray "function pokeSTArray(arr) {\ - \ return function(i) {\ - \ return function(a) {\ - \ return function() {\ - \ return arr[i] = a;\ - \ };\ - \ };\ - \ };\ - \}" :: forall a h r. STArray h a -> Number -> a -> Eff (st :: ST h | r) a - - foreign import runST "function runST(f) {\ - \ return f;\ - \}" :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a - - foreign import runSTArray "function runSTArray(f) {\ - \ return f;\ - \}" :: forall a r. (forall h. Eff (st :: ST h | r) (STArray h a)) -> Eff r [a] diff --git a/docgen/Main.hs b/psc-docs/Main.hs index d8c61db..a9f5c00 100644 --- a/docgen/Main.hs +++ b/psc-docs/Main.hs @@ -17,6 +17,7 @@ module Main where import Control.Applicative import Control.Monad import Control.Monad.Writer +import Control.Arrow (first) import Data.Function (on) import Data.List import Data.Version (showVersion) @@ -29,19 +30,17 @@ import System.IO (stderr) docgen :: Bool -> [FilePath] -> IO () docgen showHierarchy input = do - ms <- mapM parseFile (nub input) - U.putStrLn . runDocs $ (renderModules showHierarchy) (concat ms) - exitSuccess - -parseFile :: FilePath -> IO [P.Module] -parseFile input = do - text <- U.readFile input - case P.runIndentParser input P.parseModules text of + e <- P.parseModulesFromFiles <$> mapM (fmap (first Just) . parseFile) (nub input) + case e of Left err -> do U.hPutStr stderr $ show err exitFailure Right ms -> do - return ms + U.putStrLn . runDocs $ (renderModules showHierarchy) (map snd ms) + exitSuccess + +parseFile :: FilePath -> IO (FilePath, String) +parseFile input = (,) input <$> U.readFile input type Docs = Writer [String] () @@ -229,7 +228,7 @@ term = docgen <$> includeHeirarcy <*> inputFiles termInfo :: TermInfo termInfo = defTI - { termName = "docgen" + { termName = "psc-docs" , version = showVersion Paths.version , termDoc = "Generate Markdown documentation from PureScript extern files" } diff --git a/psc-make/Main.hs b/psc-make/Main.hs index 1f00e69..67f0238 100644 --- a/psc-make/Main.hs +++ b/psc-make/Main.hs @@ -12,13 +12,14 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TupleSections, RecordWildCards #-} module Main where import Control.Applicative import Control.Monad.Error +import Data.Bool (bool) import Data.Version (showVersion) import System.Console.CmdTheLine @@ -28,19 +29,19 @@ import System.FilePath (takeDirectory) import System.Exit (exitSuccess, exitFailure) import System.IO.Error (tryIOError) -import Text.Parsec (ParseError) - import qualified Language.PureScript as P import qualified Paths_purescript as Paths import qualified System.IO.UTF8 as U -readInput :: [FilePath] -> IO (Either ParseError [(FilePath, P.Module)]) -readInput input = fmap collect $ forM input $ \inputFile -> do - text <- U.readFile inputFile - 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) +data InputOptions = InputOptions + { ioNoPrelude :: Bool + , ioInputFiles :: [FilePath] + } + +readInput :: InputOptions -> IO [(Maybe FilePath, String)] +readInput InputOptions{..} = do + content <- forM ioInputFiles $ \inputFile -> (Just inputFile, ) <$> U.readFile inputFile + return $ bool ((Nothing, P.prelude) :) id ioNoPrelude content newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadError String) @@ -66,9 +67,9 @@ instance P.MonadMake Make where liftError = either throwError return progress = makeIO . U.putStrLn -compile :: FilePath -> [FilePath] -> FilePath -> P.Options P.Make -> Bool -> IO () -compile prelude input outputDir opts usePrefix = do - modules <- readInput allInputFiles +compile :: [FilePath] -> FilePath -> P.Options P.Make -> Bool -> IO () +compile input outputDir opts usePrefix = do + modules <- P.parseModulesFromFiles <$> readInput (InputOptions (P.optionsNoPrelude opts) input) case modules of Left err -> do U.print err @@ -86,9 +87,6 @@ compile prelude input outputDir opts usePrefix = do then ["Generated by psc-make version " ++ showVersion Paths.version] else [] - allInputFiles | P.optionsNoPrelude opts = input - | otherwise = prelude : input - mkdirp :: FilePath -> IO () mkdirp = createDirectoryIfMissing True . takeDirectory @@ -127,8 +125,8 @@ noPrefix :: Term Bool noPrefix = value $ flag $ (optInfo ["p", "no-prefix" ]) { optDoc = "Do not include comment header"} -term :: FilePath -> Term (IO ()) -term prelude = compile prelude <$> inputFiles <*> outputDirectory <*> options <*> (not <$> noPrefix) +term :: Term (IO ()) +term = compile <$> inputFiles <*> outputDirectory <*> options <*> (not <$> noPrefix) termInfo :: TermInfo termInfo = defTI @@ -138,7 +136,5 @@ termInfo = defTI } main :: IO () -main = do - prelude <- P.preludeFilename - run (term prelude, termInfo) +main = run (term, termInfo) diff --git a/psc/Main.hs b/psc/Main.hs index a272ba9..713bcce 100644 --- a/psc/Main.hs +++ b/psc/Main.hs @@ -12,13 +12,14 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TupleSections, RecordWildCards #-} module Main where import Control.Applicative import Control.Monad.Error +import Data.Bool (bool) import Data.Version (showVersion) import System.Console.CmdTheLine @@ -27,26 +28,25 @@ import System.FilePath (takeDirectory) import System.Exit (exitSuccess, exitFailure) import System.IO (stderr) -import Text.Parsec (ParseError) - import qualified Language.PureScript as P import qualified Paths_purescript as Paths import qualified System.IO.UTF8 as U -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 $ (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) +data InputOptions = InputOptions + { ioNoPrelude :: Bool + , ioUseStdIn :: Bool + , ioInputFiles :: [FilePath] + } + +readInput :: InputOptions -> IO [(Maybe FilePath, String)] +readInput InputOptions{..} + | ioUseStdIn = return . (Nothing ,) <$> getContents + | otherwise = do content <- forM ioInputFiles $ \inputFile -> (Just inputFile, ) <$> U.readFile inputFile + return $ bool ((Nothing, P.prelude) :) id ioNoPrelude content -compile :: FilePath -> P.Options P.Compile -> Bool -> [FilePath] -> Maybe FilePath -> Maybe FilePath -> Bool -> IO () -compile prelude opts stdin input output externs usePrefix = do - modules <- readInput stdInOrInputFiles +compile :: P.Options P.Compile -> Bool -> [FilePath] -> Maybe FilePath -> Maybe FilePath -> Bool -> IO () +compile opts stdin input output externs usePrefix = do + modules <- P.parseModulesFromFiles <$> readInput (InputOptions (P.optionsNoPrelude opts) stdin input) case modules of Left err -> do U.hPutStr stderr $ show err @@ -65,10 +65,6 @@ compile prelude opts stdin input output externs usePrefix = do Nothing -> return () exitSuccess where - stdInOrInputFiles :: Maybe [FilePath] - stdInOrInputFiles | stdin = Nothing - | P.optionsNoPrelude opts = Just input - | otherwise = Just $ prelude : input prefix = if usePrefix then ["Generated by psc version " ++ showVersion Paths.version] else [] @@ -137,8 +133,8 @@ options = P.Options <$> noPrelude <*> noTco <*> noMagicDo <*> runMain <*> noOpts where additionalOptions = P.CompileOptions <$> browserNamespace <*> dceModules <*> codeGenModules -term :: FilePath -> Term (IO ()) -term prelude = compile prelude <$> options <*> useStdIn <*> inputFiles <*> outputFile <*> externsFile <*> (not <$> noPrefix) +term :: Term (IO ()) +term = compile <$> options <*> useStdIn <*> inputFiles <*> outputFile <*> externsFile <*> (not <$> noPrefix) termInfo :: TermInfo termInfo = defTI @@ -148,8 +144,6 @@ termInfo = defTI } main :: IO () -main = do - prelude <- P.preludeFilename - run (term prelude, termInfo) +main = run (term, termInfo) diff --git a/psci/Commands.hs b/psci/Commands.hs index 88a67ac..67c6785 100644 --- a/psci/Commands.hs +++ b/psci/Commands.hs @@ -34,6 +34,10 @@ data Command -- | Import ModuleName -- | + -- Browse a module + -- + | Browse ModuleName + -- | -- Load a file for use with importing -- | LoadFile FilePath @@ -57,6 +61,10 @@ data Command -- Find the kind of an expression -- | KindOf Type + -- | + -- Show command + -- + | Show String -- | -- The help menu. @@ -65,9 +73,12 @@ help :: [[String]] help = [ [":? ", "Show this help menu"] , [":i <module> ", "Import <module> for use in PSCI"] + , [":b <module> ", "Browse <module>"] , [":m <file> ", "Load <file> for importing"] , [":q ", "Quit PSCi"] , [":r ", "Reset"] + , [":s import ", "Show imported modules"] + , [":s loaded ", "Show loaded modules"] , [":t <expr> ", "Show the type of <expr>"] , [":k <type> ", "Show the kind of <type>"] ] diff --git a/psci/Main.hs b/psci/Main.hs index e498c99..87b9adf 100644 --- a/psci/Main.hs +++ b/psci/Main.hs @@ -28,7 +28,7 @@ import qualified Control.Monad.Trans.State.Lazy as L import Control.Monad.Error (ErrorT(..), MonadError) import Control.Monad.Error.Class (MonadError(..)) -import Data.List (intercalate, isPrefixOf, nub, sortBy) +import Data.List (intercalate, isPrefixOf, nub, sortBy, sort) import Data.Maybe (mapMaybe) import Data.Foldable (traverse_) import Data.Version (showVersion) @@ -54,6 +54,8 @@ import qualified Language.PureScript as P import qualified Paths_purescript as Paths import qualified System.IO.UTF8 as U (writeFile, putStrLn, print, readFile) +import qualified Language.PureScript.Names as N +import qualified Language.PureScript.Declarations as D -- | -- The PSCI state. @@ -64,7 +66,7 @@ import qualified System.IO.UTF8 as U data PSCiState = PSCiState { psciImportedFilenames :: [FilePath] , psciImportedModuleNames :: [P.ModuleName] - , psciLoadedModules :: [(FilePath, P.Module)] + , psciLoadedModules :: [(Maybe FilePath, P.Module)] , psciLetBindings :: [P.Expr -> P.Expr] } @@ -85,7 +87,7 @@ updateImports name st = st { psciImportedModuleNames = name : psciImportedModule -- | -- Updates the state to have more loaded files. -- -updateModules :: [(FilePath, P.Module)] -> PSCiState -> PSCiState +updateModules :: [(Maybe FilePath, P.Module)] -> PSCiState -> PSCiState updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modules } -- | @@ -126,6 +128,17 @@ loadModule :: FilePath -> IO (Either String [P.Module]) loadModule filename = either (Left . show) Right . P.runIndentParser filename P.parseModules <$> U.readFile filename -- | +-- Load all modules, including the Prelude +-- +loadAllModules :: [FilePath] -> IO (Either ParseError [(Maybe FilePath, P.Module)]) +loadAllModules files = do + filesAndContent <- forM files $ \filename -> do + content <- U.readFile filename + return (Just filename, content) + return $ P.parseModulesFromFiles $ (Nothing, P.prelude) : filesAndContent + + +-- | -- Expands tilde in path. -- expandTilde :: FilePath -> IO FilePath @@ -290,7 +303,7 @@ handleDeclaration :: P.Expr -> PSCI () handleDeclaration value = do st <- PSCI $ lift get let m = createTemporaryModule True st value - e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)]) [] + e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Nothing, m)]) [] case e of Left err -> PSCI $ outputStrLn err Right _ -> do @@ -303,17 +316,38 @@ handleDeclaration value = do Nothing -> PSCI $ outputStrLn "Couldn't find node.js" -- | +-- Show actual loaded modules in psci. +-- +handleShowLoadedModules :: PSCI () +handleShowLoadedModules = do + PSCiState { psciLoadedModules = loadedModules } <- PSCI $ lift get + psciIO $ readModules loadedModules >>= putStrLn + return () + where readModules = return . unlines . sort . nub . map toModuleName + toModuleName = N.runModuleName . (\ (D.Module mdName _ _) -> mdName) . snd + +-- | +-- Show the imported modules in psci. +-- +handleShowImportedModules :: PSCI () +handleShowImportedModules = do + PSCiState { psciImportedModuleNames = importedModuleNames } <- PSCI $ lift get + psciIO $ readModules importedModuleNames >>= putStrLn + return () + where readModules = return . unlines . sort . map N.runModuleName + +-- | -- Imports a module, preserving the initial state on failure. -- handleImport :: P.ModuleName -> PSCI () handleImport moduleName = do - s <- liftM (updateImports moduleName) $ PSCI $ lift get - let m = createTemporaryModuleForImports s - e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules s ++ [("$PSCI.purs", m)]) [] + st <- updateImports moduleName <$> PSCI (lift get) + let m = createTemporaryModuleForImports st + e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Nothing, m)]) [] case e of Left err -> PSCI $ outputStrLn err Right _ -> do - PSCI $ lift $ put s + PSCI $ lift $ put st return () -- | @@ -323,7 +357,7 @@ handleTypeOf :: P.Expr -> PSCI () handleTypeOf value = do st <- PSCI $ lift get let m = createTemporaryModule False st value - e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)]) [] + e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Nothing, m)]) [] case e of Left err -> PSCI $ outputStrLn err Right env' -> @@ -332,6 +366,40 @@ handleTypeOf value = do Nothing -> PSCI $ outputStrLn "Could not find type" -- | +-- Pretty print a module's signatures +-- +printModuleSignatures :: P.ModuleName -> P.Environment -> PSCI () +printModuleSignatures moduleName env = + PSCI $ let namesEnv = P.names env + moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) namesEnv + in case moduleNamesIdent of + [] -> outputStrLn $ "This module '"++ P.runModuleName moduleName ++"' does not export functions." + _ -> ( outputStrLn + . unlines + . sort + . map (showType . findType namesEnv)) moduleNamesIdent + where findType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) + findType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames) + showType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> String + showType (mIdent, Just (mType, _, _)) = show mIdent ++ " :: " ++ P.prettyPrintType mType + showType _ = error "The impossible happened in printModuleSignatures." + +-- | +-- Browse a module and displays its signature (if module exists). +-- +handleBrowse :: P.ModuleName -> PSCI () +handleBrowse moduleName = do + st <- PSCI $ lift get + let loadedModules = psciLoadedModules st + env <- psciIO . runMake $ P.make modulesDir options loadedModules [] + case env of + Left err -> PSCI $ outputStrLn err + Right env' -> + if moduleName `notElem` (nub . map ((\ (P.Module modName _ _ ) -> modName) . snd)) loadedModules + then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid." + else printModuleSignatures moduleName env' + +-- | -- Takes a value and prints its kind -- handleKindOf :: P.Type -> PSCI () @@ -339,7 +407,7 @@ handleKindOf typ = do st <- PSCI $ lift get let m = createTemporaryModuleForKind st typ mName = P.ModuleName [P.ProperName "$PSCI"] - e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)]) [] + e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Nothing, m)]) [] case e of Left err -> PSCI $ outputStrLn err Right env' -> @@ -385,18 +453,20 @@ handleCommand (LoadFile filePath) = do m <- psciIO $ loadModule absPath case m of Left err -> PSCI $ outputStrLn err - Right mods -> PSCI . lift $ modify (updateModules (map ((,) absPath) mods)) + Right mods -> PSCI . lift $ modify (updateModules (map ((,) (Just absPath)) mods)) else PSCI . outputStrLn $ "Couldn't locate: " ++ filePath handleCommand Reset = do files <- psciImportedFilenames <$> PSCI (lift get) - filesAndModules <- mapM (\file -> fmap (fmap (map ((,) file))) . psciIO . loadModule $ file) files - let modulesOrFirstError = fmap concat $ sequence filesAndModules + modulesOrFirstError <- psciIO $ loadAllModules files case modulesOrFirstError of - Left err -> psciIO $ putStrLn err >> exitFailure + Left err -> psciIO $ putStrLn (show err) >> exitFailure Right modules -> PSCI . lift $ put (PSCiState files defaultImports modules []) handleCommand (TypeOf val) = handleTypeOf val handleCommand (KindOf typ) = handleKindOf typ +handleCommand (Browse moduleName) = handleBrowse moduleName +handleCommand (Show "loaded") = handleShowLoadedModules +handleCommand (Show "import") = handleShowImportedModules handleCommand _ = PSCI $ outputStrLn "Unknown command" singleLineFlag :: Cmd.Term Bool @@ -429,15 +499,13 @@ loadUserConfig = do loop :: Bool -> [FilePath] -> IO () loop singleLineMode files = do config <- loadUserConfig - preludeFilename <- P.preludeFilename - filesAndModules <- mapM (\file -> fmap (fmap (map ((,) file))) . loadModule $ file) (preludeFilename : files) - let modulesOrFirstError = fmap concat $ sequence filesAndModules + modulesOrFirstError <- loadAllModules files case modulesOrFirstError of - Left err -> putStrLn err >> exitFailure + Left err -> putStrLn (show err) >> exitFailure Right modules -> do historyFilename <- getHistoryFilename - let settings = defaultSettings {historyFile = Just historyFilename} - flip evalStateT (PSCiState (preludeFilename : files) defaultImports modules []) . runInputT (setComplete completion settings) $ do + let settings = defaultSettings { historyFile = Just historyFilename } + flip evalStateT (PSCiState files defaultImports modules []) . runInputT (setComplete completion settings) $ do outputStrLn prologueMessage traverse_ (mapM_ (runPSCI . handleCommand)) config go diff --git a/psci/Parser.hs b/psci/Parser.hs index b507f1e..9fe45cc 100644 --- a/psci/Parser.hs +++ b/psci/Parser.hs @@ -42,7 +42,7 @@ psciLet = Let <$> (P.Let <$> (P.reserved "let" *> P.indented *> C.mark (many1 (C -- parseCommand :: String -> Either ParseError Command parseCommand = P.runIndentParser "" $ choice - [ P.whiteSpace *> char ':' *> (psciHelp <|> psciImport <|> psciLoadFile <|> psciQuit <|> psciReload <|> psciTypeOf <|> psciKindOf) + [ P.whiteSpace *> char ':' *> (psciHelp <|> psciImport <|> psciLoadFile <|> psciQuit <|> psciReload <|> psciTypeOf <|> psciKindOf <|> psciBrowse <|> psciShowModules) , try psciLet , psciExpression ] <* eof @@ -70,8 +70,10 @@ psciImport = Import <$> (char 'i' *> P.whiteSpace *> P.moduleName) -- psciLoadFile :: Parsec String P.ParseState Command psciLoadFile = LoadFile . trimEnd <$> (char 'm' *> P.whiteSpace *> manyTill anyChar eof) - where - trimEnd = reverse . dropWhile isSpace . reverse + +-- | Trim end of input string +trimEnd :: String -> String +trimEnd = reverse . dropWhile isSpace . reverse -- | -- Parses 'Commands.Quit' command. @@ -97,3 +99,14 @@ psciTypeOf = TypeOf <$> (char 't' *> P.whiteSpace *> P.parseValue) -- psciKindOf :: Parsec String P.ParseState Command psciKindOf = KindOf <$> (char 'k' *> P.whiteSpace *> P.parseType) + +-- | +-- Parses 'Commands.Browse' command. +-- +psciBrowse :: Parsec String P.ParseState Command +psciBrowse = Browse <$> (char 'b' *> P.whiteSpace *> P.moduleName) + +-- | +-- Show Command +psciShowModules :: Parsec String P.ParseState Command +psciShowModules = Show . trimEnd <$> (char 's' *> P.whiteSpace *> manyTill anyChar eof) diff --git a/purescript.cabal b/purescript.cabal index f756633..4c0f3be 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.5.7.1 +version: 0.6.0 cabal-version: >=1.8 build-type: Simple license: MIT @@ -14,8 +14,6 @@ Homepage: http://www.purescript.org/ author: Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>, Hardy Jones <jones3.hardy@gmail.com> -data-files: prelude/prelude.purs -data-dir: "" extra-source-files: examples/passing/*.purs , examples/failing/*.purs @@ -25,14 +23,20 @@ source-repository head location: https://github.com/purescript/purescript.git library - build-depends: base >=4 && <5, cmdtheline == 0.2.*, containers -any, unordered-containers -any, - directory >= 1.2, filepath -any, mtl >= 2.1.0 && < 2.3.0, parsec -any, - transformers >= 0.3 && < 0.5, utf8-string -any, + build-depends: base >=4 && <5, + cmdtheline == 0.2.*, + containers -any, + unordered-containers -any, + directory >= 1.2, + filepath -any, + mtl >= 2.1.0 && < 2.3.0, + parsec -any, + transformers >= 0.3 && < 0.5, + utf8-string -any, pattern-arrows >= 0.0.2 && < 0.1, - monad-unify >= 0.2.2 && < 0.3, + monad-unify >= 0.2.2 && < 0.3, + file-embed >= 0.0.7 && < 0.0.8, time -any - if (!os(windows)) - build-depends: unix -any exposed-modules: Language.PureScript Language.PureScript.Constants Language.PureScript.Options @@ -123,12 +127,12 @@ executable psci Parser ghc-options: -Wall -O2 -executable docgen +executable psc-docs build-depends: base >=4 && <5, cmdtheline -any, purescript -any, utf8-string -any, process -any, mtl -any main-is: Main.hs buildable: True - hs-source-dirs: docgen + hs-source-dirs: psc-docs other-modules: ghc-options: -Wall -O2 diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs index f4cc5dd..c8bc10c 100644 --- a/src/Language/PureScript.hs +++ b/src/Language/PureScript.hs @@ -13,9 +13,9 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds, QuasiQuotes, TemplateHaskell #-} -module Language.PureScript (module P, compile, compile', MonadMake(..), make, preludeFilename) where +module Language.PureScript (module P, compile, compile', MonadMake(..), make, prelude) where import Language.PureScript.Types as P import Language.PureScript.Kinds as P @@ -36,20 +36,23 @@ import Language.PureScript.Supply as P import Language.PureScript.Renamer as P import qualified Language.PureScript.Constants as C -import qualified Paths_purescript as Paths import Data.List (sortBy, groupBy, intercalate) import Data.Time.Clock import Data.Function (on) -import Data.Maybe (listToMaybe, fromMaybe) +import Data.Maybe (fromMaybe) +import Data.FileEmbed (embedFile) +import Data.Traversable (traverse) + import Control.Monad.Error import Control.Arrow ((&&&)) import Control.Applicative + import qualified Data.Map as M import qualified Data.Set as S +import qualified Data.ByteString.UTF8 as BU -import System.FilePath ((</>), pathSeparator) -import System.Directory (getHomeDirectory, doesFileExist) +import System.FilePath ((</>)) -- | -- Compile a collection of modules @@ -136,7 +139,7 @@ class MonadMake m where -- 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, Applicative m, Monad m, MonadMake m) => FilePath -> Options Make -> [(FilePath, Module)] -> [String] -> m Environment +make :: (Functor m, Applicative m, Monad m, MonadMake m) => FilePath -> Options Make -> [(Maybe FilePath, Module)] -> [String] -> m Environment make outputDir opts ms prefix = do let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms) @@ -145,13 +148,13 @@ make outputDir opts ms prefix = do toRebuild <- foldM (\s (Module moduleName' _ _) -> do let filePath = runModuleName moduleName' - jsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "index.js" - externsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "externs.purs" - inputFile = fromMaybe (error "Input file is undefined in make") $ M.lookup moduleName' filePathMap + jsFile = outputDir </> filePath </> "index.js" + externsFile = outputDir </> filePath </> "externs.purs" + inputFile = join $ M.lookup moduleName' filePathMap jsTimestamp <- getTimestamp jsFile externsTimestamp <- getTimestamp externsFile - inputTimestamp <- getTimestamp inputFile + inputTimestamp <- join <$> traverse getTimestamp inputFile return $ case (inputTimestamp, jsTimestamp, externsTimestamp) of (Just t1, Just t2, Just t3) | t1 < min t2 t3 -> s @@ -172,8 +175,8 @@ make outputDir opts ms prefix = do go env' ms' go env ((True, m@(Module moduleName' _ exps)) : ms') = do let filePath = runModuleName moduleName' - jsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "index.js" - externsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "externs.purs" + jsFile = outputDir </> filePath </> "index.js" + externsFile = outputDir </> filePath </> "externs.purs" lift . progress $ "Compiling " ++ runModuleName moduleName' @@ -200,7 +203,7 @@ make outputDir opts ms prefix = do toRebuild' = toRebuild `S.union` S.fromList deps (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms' rebuildIfNecessary graph toRebuild (Module moduleName' _ _ : ms') = do - let externsFile = outputDir ++ pathSeparator : runModuleName moduleName' ++ pathSeparator : "externs.purs" + let externsFile = outputDir </> runModuleName moduleName' </> "externs.purs" externs <- readTextFile externsFile externsModules <- liftError . either (Left . show) Right $ P.runIndentParser externsFile P.parseModules externs case externsModules of @@ -231,18 +234,5 @@ importPrim = addDefaultImport (ModuleName [ProperName C.prim]) importPrelude :: Module -> Module importPrelude = addDefaultImport (ModuleName [ProperName C.prelude]) -preludeFilename :: IO FilePath -preludeFilename = fromMaybe missingPrelude . listToMaybe <$> do - fs <- sequence [homePrelude, cabalPrelude] - filterM doesFileExist fs - where - missingPrelude :: FilePath - missingPrelude = error "No Prelude found in user home or cabal path." - - homePrelude :: IO FilePath - homePrelude = do - homeDir <- getHomeDirectory - return $ homeDir </> ".purescript" </> "prelude" </> "prelude.purs" - - cabalPrelude :: IO FilePath - cabalPrelude = Paths.getDataFileName "prelude/prelude.purs" +prelude :: String +prelude = BU.toString $(embedFile "prelude/prelude.purs") diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 9fead75..db8b6e9 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -26,8 +26,11 @@ import Data.Maybe (catMaybes) import Data.Function (on) import Data.List (nub, (\\), delete, sortBy) +import qualified Data.Map as M + import Control.Monad (foldM, replicateM, forM) import Control.Applicative +import Control.Arrow (second) import Language.PureScript.Names import Language.PureScript.Declarations @@ -51,7 +54,7 @@ moduleToJs opts (Module name decls (Just exps)) env = do let optimized = concat $ map (map $ optimize opts) $ catMaybes jsDecls let isModuleEmpty = null exps let moduleBody = JSStringLiteral "use strict" : jsImports ++ optimized - let moduleExports = JSObjectLiteral $ concatMap exportToJs exps + let moduleExports = JSObjectLiteral . map (second var) . M.toList . M.unions $ map exportToJs exps return $ case optionsAdditional opts of MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) moduleExports] CompileOptions ns _ _ | not isModuleEmpty -> @@ -154,12 +157,12 @@ declToJs _ _ _ _ = return Nothing -- | -- Generate key//value pairs for an object literal exporting values from a module. -- -exportToJs :: DeclarationRef -> [(String, JS)] -exportToJs (TypeRef _ (Just dctors)) = map ((\n -> (n, var (Ident n))) . runProperName) dctors -exportToJs (ValueRef name) = [(runIdent name, var name)] -exportToJs (TypeInstanceRef name) = [(runIdent name, var name)] -exportToJs (TypeClassRef name) = [(runProperName name, var $ Ident $ runProperName name)] -exportToJs _ = [] +exportToJs :: DeclarationRef -> M.Map String Ident +exportToJs (TypeRef _ (Just dctors)) = M.fromList [ (n, Ident n) | (ProperName n) <- dctors ] +exportToJs (ValueRef name) = M.singleton (runIdent name) name +exportToJs (TypeInstanceRef name) = M.singleton (runIdent name) name +exportToJs (TypeClassRef name) = M.singleton (runProperName name) (Ident $ runProperName name) +exportToJs _ = M.empty -- | -- Generate code in the simplified Javascript intermediate representation for a variable based on a diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 9c0179b..11555ff 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -16,10 +16,12 @@ module Language.PureScript.Errors where +import Data.Either (lefts, rights) import Data.List (intersperse, intercalate) import Data.Monoid import Control.Monad.Error +import Control.Applicative ((<$>)) import Language.PureScript.Declarations import Language.PureScript.Pretty @@ -121,3 +123,18 @@ rethrow f = flip catchError $ \e -> throwError (f e) -- rethrowWithPosition :: (MonadError ErrorStack m) => SourcePos -> m a -> m a rethrowWithPosition pos = rethrow (positionError pos <>) + +-- | +-- Collect errors in in parallel +-- +parU :: (MonadError ErrorStack m, Functor m) => [a] -> (a -> m b) -> m [b] +parU xs f = forM xs (withError . f) >>= collectErrors + where + withError :: (MonadError ErrorStack m, Functor m) => m a -> m (Either ErrorStack a) + withError u = catchError (Right <$> u) (return . Left) + + collectErrors :: (MonadError ErrorStack m, Functor m) => [Either ErrorStack a] -> m [a] + collectErrors es = case lefts es of + [err] -> throwError err + [] -> return $ rights es + errs -> throwError $ MultipleErrors errs diff --git a/src/Language/PureScript/Parser.hs b/src/Language/PureScript/Parser.hs index 81c1baf..4176ed8 100644 --- a/src/Language/PureScript/Parser.hs +++ b/src/Language/PureScript/Parser.hs @@ -31,4 +31,4 @@ import Language.PureScript.Parser.Common as P import Language.PureScript.Parser.Types as P import Language.PureScript.Parser.State as P import Language.PureScript.Parser.Kinds as P -import Language.PureScript.Parser.Declarations as P +import Language.PureScript.Parser.Declarations as P
\ No newline at end of file diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index db9fee6..fc62868 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -19,6 +19,7 @@ module Language.PureScript.Parser.Declarations ( parseDeclaration, parseModule, parseModules, + parseModulesFromFiles, parseValue, parseGuard, parseBinder, @@ -26,6 +27,7 @@ module Language.PureScript.Parser.Declarations ( ) where import Data.Maybe (isJust, fromMaybe) +import Data.Traversable (forM) import Control.Applicative import Control.Arrow ((+++)) @@ -231,6 +233,18 @@ parseModule = do return $ Module name decls exports -- | +-- Parse a collection of modules +-- +parseModulesFromFiles :: [(Maybe FilePath, String)] -> Either P.ParseError [(Maybe FilePath, Module)] +parseModulesFromFiles input = + fmap collect . forM input $ \(filename, content) -> do + ms <- runIndentParser (fromMaybe "" filename) parseModules content + return (filename, ms) + where + collect :: [(k, [v])] -> [(k, v)] + collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ] + +-- | -- Parse a collection of modules -- parseModules :: P.Parsec String ParseState [Module] diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index c9d6f5c..5baf578 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -52,14 +52,14 @@ collapseBindingGroupsModule = map $ \(Module name ds exps) -> Module name (colla -- createBindingGroups :: ModuleName -> [Declaration] -> Either ErrorStack [Declaration] createBindingGroups moduleName ds = do - values <- mapM (createBindingGroupsForValue moduleName) $ filter isValueDecl ds + values <- parU (filter isValueDecl ds) (createBindingGroupsForValue moduleName) let dataDecls = filter isDataDecl ds allProperNames = map getProperName dataDecls dataVerts = map (\d -> (d, getProperName d, usedProperNames moduleName d `intersect` allProperNames)) dataDecls - dataBindingGroupDecls <- mapM toDataBindingGroup $ stronglyConnComp dataVerts + dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup let allIdents = map getIdent values valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values - bindingGroupDecls <- mapM (toBindingGroup moduleName) $ stronglyConnComp valueVerts + bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName) return $ filter isImportDecl ds ++ filter isExternDataDecl ds ++ filter isExternInstanceDecl ds ++ diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index 72178be..56ab9fb 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -43,7 +43,7 @@ desugarCasesModule ms = forM ms $ \(Module name ds exps) -> Module name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps desugarAbs :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration] -desugarAbs = mapM f +desugarAbs = flip parU f where (f, _, _) = everywhereOnValuesM return replace return @@ -57,7 +57,7 @@ desugarAbs = mapM f -- Replace all top-level binders with case expressions. -- desugarCases :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration] -desugarCases = desugarRest <=< fmap join . mapM toDecls . groupBy inSameGroup +desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup where desugarRest :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration] desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) = diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index 16ca51c..e9595f3 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -33,7 +33,7 @@ import Control.Monad.Trans.Class -- and all @DoNotationLet@ constructors with let expressions. -- desugarDoModule :: Module -> SupplyT (Either ErrorStack) Module -desugarDoModule (Module mn ds exts) = Module mn <$> mapM desugarDo ds <*> pure exts +desugarDoModule (Module mn ds exts) = Module mn <$> parU ds desugarDo <*> pure exts desugarDo :: Declaration -> SupplyT (Either ErrorStack) Declaration desugarDo (PositionedDeclaration pos d) = (PositionedDeclaration pos) <$> (rethrowWithPosition pos $ desugarDo d) diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 97fd33d..80673be 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -176,7 +176,7 @@ elaborateExports exps (Module mn decls _) = Module mn decls (Just $ -- renameInModule :: ImportEnvironment -> ExportEnvironment -> Module -> Either ErrorStack Module renameInModule imports exports (Module mn decls exps) = - Module mn <$> mapM go decls <*> pure exps + Module mn <$> parU decls go <*> pure exps where (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 7ecf7af..e5cc304 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -66,7 +66,7 @@ removeSignedLiterals (Module mn ds exts) = Module mn (map f' ds) exts rebracketModule :: [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> Either ErrorStack Module rebracketModule opTable (Module mn ds exts) = let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return - in Module mn <$> (map removeParens <$> mapM f ds) <*> pure exts + in Module mn <$> (map removeParens <$> parU ds f) <*> pure exts removeParens :: Declaration -> Declaration removeParens = diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 697cff6..b131cb9 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -53,7 +53,7 @@ desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule desugarModule :: Module -> Desugar Module desugarModule (Module name decls (Just exps)) = do - (newExpss, declss) <- unzip <$> mapM (desugarDecl name exps) decls + (newExpss, declss) <- unzip <$> parU decls (desugarDecl name exps) return $ Module name (concat declss) $ Just (exps ++ catMaybes newExpss) desugarModule _ = error "Exports should have been elaborated in name desugaring" diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 6bedf85..fc1ebed 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -183,7 +183,11 @@ typeCheckAll mainModuleName moduleName exps = go forM_ (map (\(ident, _, _) -> ident) vals) $ \name -> valueIsNotDefined moduleName name tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals - vals' <- forM (zipWith (\(name, nameKind, _) (_, (val, ty)) -> (name, val, nameKind, ty)) vals tys) $ \(name, val, nameKind, ty) -> do + vals' <- forM [ (name, val, nameKind, ty) + | (name, nameKind, _) <- vals + , (name', (val, ty)) <- tys + , name == name' + ] $ \(name, val, nameKind, ty) -> do addValue moduleName name ty nameKind return (name, nameKind, val) return $ BindingGroupDeclaration vals' diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 521c6c6..e8b1935 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -28,7 +28,6 @@ import Language.PureScript.Options import Language.PureScript.Errors import Data.Maybe -import Data.Either (lefts, rights) import Control.Applicative import Control.Monad.State @@ -233,19 +232,3 @@ liftUnify unify = do (a, ust) <- runUnify (defaultUnifyState { unifyNextVar = checkNextVar st }) unify modify $ \st' -> st' { checkNextVar = unifyNextVar ust } return (a, unifyCurrentSubstitution ust) - --- | --- Typecheck in parallel --- -parU :: [a] -> (a -> UnifyT t Check b) -> UnifyT t Check [b] -parU xs f = forM xs (withError . f) >>= collectErrors - where - withError :: UnifyT t Check a -> UnifyT t Check (Either ErrorStack a) - withError u = catchError (Right <$> u) (return . Left) - - collectErrors :: [Either ErrorStack a] -> UnifyT t Check [a] - collectErrors es = case lefts es of - [err] -> throwError err - [] -> return $ rights es - errs -> throwError $ MultipleErrors errs - diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index a9c45b2..f8988e0 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -192,10 +192,10 @@ typesOf mainModuleName moduleName vals = do skolemEscapeCheck val' -- Check rows do not contain duplicate labels checkDuplicateLabels val' - -- Remove type synonyms placeholders, remove duplicate row fields, and replace + -- Remove type synonyms placeholders, and replace -- top-level unification variables with named type variables. - let val'' = overTypes (desaturateAllTypeSynonyms . setifyAll) val' - ty' = varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty + let val'' = overTypes desaturateAllTypeSynonyms val' + ty' = varIfUnknown . desaturateAllTypeSynonyms $ ty return (ident, (val'', ty')) where -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values @@ -527,41 +527,33 @@ checkDuplicateLabels = def = return go :: Expr -> Check Expr - go e@(TypedValue _ _ ty) = checkDups ty >> return e - go other = return other + go e@(TypedValue _ val ty) = do + checkDups ty + return e + + where + checkDups :: Type -> Check () + checkDups (TypeApp t1 t2) = checkDups t1 >> checkDups t2 + checkDups (SaturatedTypeSynonym _ ts) = mapM_ checkDups ts + checkDups (ForAll _ t _) = checkDups t + checkDups (ConstrainedType args t) = do + mapM_ (checkDups) $ concatMap snd args + checkDups t + checkDups r@(RCons _ _ _) = + let (ls, _) = rowToList r in + case firstDup . sort . map fst $ ls of + Just l -> throwError $ mkErrorStack ("Duplicate label " ++ show l ++ " in row") $ Just (ExprError val) + Nothing -> return () + checkDups _ = return () - checkDups :: Type -> Check () - checkDups (TypeApp t1 t2) = checkDups t1 >> checkDups t2 - checkDups (SaturatedTypeSynonym _ ts) = mapM_ checkDups ts - checkDups (ForAll _ t _) = checkDups t - checkDups (ConstrainedType args t) = do - mapM_ (checkDups) $ concatMap snd args - checkDups t - checkDups r@(RCons _ _ _) = - let (ls, _) = rowToList r in - case firstDup . sort . map fst $ ls of - Just l -> throwError . strMsg $ "Duplicate label " ++ show l ++ " in row" - Nothing -> return () - checkDups _ = return () + firstDup :: (Eq a) => [a] -> Maybe a + firstDup (x : xs@(x' : _)) + | x == x' = Just x + | otherwise = firstDup xs + firstDup _ = Nothing + + go other = return other - firstDup :: (Eq a) => [a] -> Maybe a - firstDup (x : xs@(x' : _)) - | x == x' = Just x - | otherwise = firstDup xs - firstDup _ = Nothing - --- | --- Ensure a row contains no duplicate labels --- -setify :: Type -> Type -setify = rowFromList . first (M.toList . M.fromList) . rowToList - --- | --- \"Setify\" all rows occuring inside a value --- -setifyAll :: Type -> Type -setifyAll = everywhereOnTypes setify - -- | -- Replace outermost unsolved unification variables with named type variables -- @@ -1018,10 +1010,11 @@ check' (TypeClassDictionaryConstructorApp name ps) t = do return $ TypedValue True (TypeClassDictionaryConstructorApp name ps') t check' (ObjectUpdate obj ps) t@(TypeApp o row) | o == tyObject = do ensureNoDuplicateProperties ps - us <- zip (map fst ps) <$> replicateM (length ps) fresh + -- We need to be careful to avoid duplicate labels here. + -- We check _obj_ agaist the type _t_ with the types in _ps_ replaced with unknowns. let (propsToCheck, rest) = rowToList row - propsToRemove = map fst ps - remainingProps = filter (\(p, _) -> p `notElem` propsToRemove) propsToCheck + (removedProps, remainingProps) = partition (\(p, _) -> p `elem` map fst ps) propsToCheck + us <- zip (map fst removedProps) <$> replicateM (length ps) fresh obj' <- check obj (TypeApp tyObject (rowFromList (us ++ remainingProps, rest))) ps' <- checkProperties ps row True return $ TypedValue True (ObjectUpdate obj' ps') t diff --git a/tests/Main.hs b/tests/Main.hs index 390dab7..8bbdcd5 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -22,6 +22,7 @@ import Data.List (isSuffixOf) import Data.Traversable (traverse) import Control.Monad import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +import Control.Applicative import System.Exit import System.Process import System.FilePath (pathSeparator) @@ -29,18 +30,24 @@ import System.Directory (getCurrentDirectory, getTemporaryDirectory, getDirector import Text.Parsec (ParseError) import qualified System.IO.UTF8 as U -readInput :: [FilePath] -> IO (Either ParseError [P.Module]) -readInput inputFiles = fmap (fmap concat . sequence) $ forM inputFiles $ \inputFile -> do +readInput :: [FilePath] -> IO [(Maybe FilePath, String)] +readInput inputFiles = forM inputFiles $ \inputFile -> do text <- U.readFile inputFile - return $ P.runIndentParser inputFile P.parseModules text + return (Just inputFile, text) + +loadPrelude :: Either String (String, String, P.Environment) +loadPrelude = + case P.parseModulesFromFiles [(Nothing, P.prelude)] of + Left parseError -> Left (show parseError) + Right ms -> P.compile (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }) (map snd ms) [] compile :: P.Options P.Compile -> [FilePath] -> IO (Either String (String, String, P.Environment)) compile opts inputFiles = do - modules <- readInput inputFiles + modules <- P.parseModulesFromFiles <$> readInput inputFiles case modules of Left parseError -> return (Left $ show parseError) - Right ms -> return $ P.compile opts ms [] + Right ms -> return $ P.compile opts (map snd ms) [] assert :: FilePath -> P.Options P.Compile -> FilePath -> (Either String (String, String, P.Environment) -> IO (Maybe String)) -> IO () assert preludeExterns opts inputFile f = do @@ -79,10 +86,8 @@ findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names main :: IO () main = do - prelude <- P.preludeFilename - putStrLn "Compiling Prelude" - preludeResult <- compile (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }) [prelude] - case preludeResult of + putStrLn "Compiling Prelude" + case loadPrelude of Left err -> putStrLn err >> exitFailure Right (preludeJs, exts, _) -> do tmp <- getTemporaryDirectory |