diff options
42 files changed, 1050 insertions, 1888 deletions
diff --git a/examples/failing/365.purs b/examples/failing/365.purs deleted file mode 100644 index 9a97030..0000000 --- a/examples/failing/365.purs +++ /dev/null @@ -1,11 +0,0 @@ -module Main where - -class C a where - f :: a -> a - g :: a -> a - -instance cS :: C String where - f s = s - g = f - -main = g "Done" diff --git a/examples/failing/RowConstructors1.purs b/examples/failing/RowConstructors1.purs deleted file mode 100644 index 29cad3f..0000000 --- a/examples/failing/RowConstructors1.purs +++ /dev/null @@ -1,6 +0,0 @@ -module Main where - -data Foo = Bar -type Baz = { | Foo } - -main = Debug.Trace.trace "Done" diff --git a/examples/failing/RowConstructors2.purs b/examples/failing/RowConstructors2.purs deleted file mode 100644 index 36ff33b..0000000 --- a/examples/failing/RowConstructors2.purs +++ /dev/null @@ -1,6 +0,0 @@ -module Main where - -type Foo r = (x :: Number | r) -type Bar = { | Foo } - -main = Debug.Trace.trace "Done" diff --git a/examples/failing/RowConstructors3.purs b/examples/failing/RowConstructors3.purs deleted file mode 100644 index ce321ef..0000000 --- a/examples/failing/RowConstructors3.purs +++ /dev/null @@ -1,6 +0,0 @@ -module Main where - -type Foo = { x :: Number } -type Bar = { | Foo } - -main = Debug.Trace.trace "Done" diff --git a/examples/failing/TypeSynonyms5.purs b/examples/failing/TypeSynonyms5.purs deleted file mode 100644 index c34eaae..0000000 --- a/examples/failing/TypeSynonyms5.purs +++ /dev/null @@ -1,3 +0,0 @@ -module Main where - -type T = T diff --git a/examples/passing/Collatz.purs b/examples/passing/Collatz.purs index 5398249..f61a950 100644 --- a/examples/passing/Collatz.purs +++ b/examples/passing/Collatz.purs @@ -1,20 +1,9 @@ module Main where +import Prelude import Control.Monad.Eff import Control.Monad.ST -foreign import jsMod - """ - function jsMod(x) { - return function (y) { - return x % y; - }; - } - """ :: Number -> Number -> Number - -infixl 7 % -(%) = jsMod - collatz :: Number -> Number collatz n = runPure (runST (do r <- newSTRef n diff --git a/examples/passing/Guards.purs b/examples/passing/Guards.purs index af68c40..b883a4e 100644 --- a/examples/passing/Guards.purs +++ b/examples/passing/Guards.purs @@ -1,39 +1,29 @@ module Main where -foreign import jsMod - """ - function jsMod(x) { - return function (y) { - return x % y; - }; - } - """ :: Number -> Number -> Number + import Prelude -infixl 7 % -(%) = jsMod + collatz = \x -> case x of + y | y % 2 == 0 -> y / 2 + y -> y * 3 + 1 -collatz = \x -> case x of - y | y % 2 == 0 -> y / 2 - y -> y * 3 + 1 + -- Guards have access to current scope + collatz2 = \x y -> case x of + z | y > 0 -> z / 2 + z -> z * 3 + 1 --- Guards have access to current scope -collatz2 = \x y -> case x of - z | y > 0 -> z / 2 - z -> z * 3 + 1 + min :: forall a. (Ord a) => a -> a -> a + min n m | n < m = n + | otherwise = m -min :: forall a. (Ord a) => a -> a -> a -min n m | n < m = n - | otherwise = m + max :: forall a. (Ord a) => a -> a -> a + max n m = case unit of + _ | m < n -> n + | otherwise -> m -max :: forall a. (Ord a) => a -> a -> a -max n m = case unit of - _ | m < n -> n - | otherwise -> m + testIndentation :: Number -> Number -> Number + testIndentation x y | x > 0 + = x + y + | otherwise + = y - x -testIndentation :: Number -> Number -> Number -testIndentation x y | x > 0 - = x + y - | otherwise - = y - x - -main = Debug.Trace.trace $ min "Done" "ZZZZ" + main = Debug.Trace.trace $ min "Done" "ZZZZ" diff --git a/examples/passing/Let2.purs b/examples/passing/Let2.purs deleted file mode 100644 index e4ef059..0000000 --- a/examples/passing/Let2.purs +++ /dev/null @@ -1,15 +0,0 @@ -module Main where - -test = - let f :: Number -> Boolean - f 0 = false - f n = g (n - 1) - - g :: Number -> Boolean - g 0 = true - g n = f (n - 1) - - x = f 1 - in not x - -main = Debug.Trace.print test diff --git a/examples/passing/OperatorAssociativity.purs b/examples/passing/OperatorAssociativity.purs index 5536772..9ee7a5d 100644 --- a/examples/passing/OperatorAssociativity.purs +++ b/examples/passing/OperatorAssociativity.purs @@ -35,13 +35,21 @@ main = do assert (6 / (3 * 2) == 1) "6 / (3 * 2) == 1" assert ((6 / 3) * 2 == 4) "(6 / 3) * 2 == 4" + assert (6 % (2 * 2) == 2) "6 % (2 * 2) == 2" + assert ((6 % 2) * 2 == 0) "(6 % 2) * 2 == 0" + + assert (4 % (9 / 3) == 1) "4 % (9 / 3) == 1" + assert ((4 % 9) / 2 == 2) "(4 % 9) / 2 == 2" + assert (not (1 < 0) == true) "not (1 < 0) == true" + assert (not (complement (1 + 10) == 8) == true) "not (complement (1 + 10) == 8) == true" assert (not ((negate 1) < 0) == false) "not ((negate 1) < 0) == false" assert (negate (1 + 10) == -11) "negate (1 + 10) == -11" assert (2 * 3 / 4 == 1.5) "2 * 3 / 4 == 1.5" assert (1 * 2 * 3 * 4 * 5 / 6 == 20) "1 * 2 * 3 * 4 * 5 / 6 == 20" + assert (complement (2 / 3 * 4) == -3) "complement (2 / 3 * 4) == -3" assert (1 + 10 - 5 == 6) "1 + 10 - 5 == 6" assert (1 + 10 * 5 == 51) "1 + 10 * 5 == 51" diff --git a/examples/passing/OperatorInlining.purs b/examples/passing/OperatorInlining.purs deleted file mode 100644 index ae3104e..0000000 --- a/examples/passing/OperatorInlining.purs +++ /dev/null @@ -1,46 +0,0 @@ -module Main where - -import Debug.Trace - -main = do - - -- semiringNumber - print (1 + 2) - print (1 * 2) - - -- ringNumber - print (1 - 2) - print (negate 1) - - -- moduleSemiringNumber - print (1 / 2) - - -- ordNumber - print (1 > 2) - print (1 < 2) - print (1 <= 2) - print (1 >= 2) - print (1 == 2) - - -- eqNumber - print (1 == 2) - print (1 /= 2) - - -- eqString - print ("foo" == "bar") - print ("foo" /= "bar") - - -- eqBoolean - print (true == false) - print (true /= false) - - -- semigroupString - print ("foo" ++ "bar") - print ("foo" <> "bar") - - -- latticeBoolean - print (top && true) - print (bottom || false) - - -- complementedLatticeBoolean - print (not true) diff --git a/examples/passing/Operators.purs b/examples/passing/Operators.purs index a222fe1..d38f7ed 100644 --- a/examples/passing/Operators.purs +++ b/examples/passing/Operators.purs @@ -61,6 +61,9 @@ module Main where test15 :: Number -> Number -> Boolean test15 a b = const false $ a `test14` b + test16 :: Number -> Number -> Number + test16 x y = x .|. y .&. y + test17 :: Number test17 = negate (-1) @@ -91,6 +94,7 @@ module Main where let t13 = test13 k 1 2 let t14 = test14 1 2 let t15 = test15 1 2 + let t16 = test16 1 2 let t17 = test17 let t18 = test18 let t19 = test19 diff --git a/examples/passing/RebindableSyntax.purs b/examples/passing/RebindableSyntax.purs deleted file mode 100644 index 8d2480c..0000000 --- a/examples/passing/RebindableSyntax.purs +++ /dev/null @@ -1,37 +0,0 @@ -module Main where - -example1 :: String -example1 = do - "Do" - " notation" - " for" - " Semigroup" - where - (>>=) x f = x <> f unit - -(*>) :: forall f a b. (Apply f) => f a -> f b -> f b -(*>) fa fb = const id <$> fa <*> fb - -newtype Const a b = Const a - -runConst :: forall a b. Const a b -> a -runConst (Const a) = a - -instance functorConst :: Functor (Const a) where - (<$>) _ (Const a) = Const a - -instance applyConst :: (Semigroup a) => Apply (Const a) where - (<*>) (Const a1) (Const a2) = Const (a1 <> a2) - -example2 :: Const String Unit -example2 = do - Const "Do" - Const " notation" - Const " for" - Const " Apply" - where - (>>=) x f = x *> f unit - -main = do - Debug.Trace.trace example1 - Debug.Trace.trace $ runConst example2 diff --git a/examples/passing/RowConstructors.purs b/examples/passing/RowConstructors.purs deleted file mode 100644 index b09e0d8..0000000 --- a/examples/passing/RowConstructors.purs +++ /dev/null @@ -1,40 +0,0 @@ -module Main where - -type Foo = (x :: Number | (y :: Number | (z :: Number))) -type Bar = (x :: Number, y :: Number, z :: Number) -type Baz = { w :: Number | Bar } - -foo :: { | Foo } -foo = { x: 0, y: 0, z: 0 } - -bar :: { | Bar } -bar = { x: 0, y: 0, z: 0 } - -id' :: Object Foo -> Object Bar -id' = id - -foo' :: { | Foo } -foo' = id' foo - -bar' :: { | Bar } -bar' = id' bar - -baz :: Baz -baz = { x: 0, y: 0, z: 0, w: 0 } - -type Quux r = (q :: Number | r) -type Norf r = (q' :: Number | Quux r) - -quux :: { f :: { | Foo } | Quux Bar } -quux = { f: foo', x: 0, y: 0, z: 0, q: 0 } - -quux' :: { | Norf Bar } -quux' = { x: 0, y: 0, z: 0, q: 0, q': 0 } - -wildcard :: { w :: Number | _ } -> Baz -wildcard { w: w } = { x: w, y: w, z: w, w: w } - -wildcard' :: { | Quux _ } -> Number -wildcard' { q: q } = q - -main = Debug.Trace.trace "Done" diff --git a/examples/passing/TopLevelCase.purs b/examples/passing/TopLevelCase.purs index a0ade1b..2c938d0 100644 --- a/examples/passing/TopLevelCase.purs +++ b/examples/passing/TopLevelCase.purs @@ -1,28 +1,18 @@ module Main where -foreign import jsMod - """ - function jsMod(x) { - return function (y) { - return x % y; - }; - } - """ :: Number -> Number -> Number + import Prelude -infixl 7 % -(%) = jsMod + gcd :: Number -> Number -> Number + gcd 0 x = x + gcd x 0 = x + gcd x y | x > y = gcd (x % y) y + gcd x y = gcd (y % x) x -gcd :: Number -> Number -> Number -gcd 0 x = x -gcd x 0 = x -gcd x y | x > y = gcd (x % y) y -gcd x y = gcd (y % x) x + guardsTest (x:xs) | x > 0 = guardsTest xs + guardsTest xs = xs -guardsTest (x:xs) | x > 0 = guardsTest xs -guardsTest xs = xs + data A = A -data A = A + parseTest A 0 = 0 -parseTest A 0 = 0 - -main = Debug.Trace.trace "Done" + main = Debug.Trace.trace "Done" diff --git a/prelude/prelude.purs b/prelude/prelude.purs index be4d07a..1531461 100644 --- a/prelude/prelude.purs +++ b/prelude/prelude.purs @@ -1,89 +1,50 @@ module Prelude - ( Unit(..), unit - , ($), (#) + ( otherwise , flip , const , asTypeOf - , otherwise - , (:), cons , Semigroupoid, (<<<), (>>>) , Category, id + , ($), (#) + , (:), cons + , Show, show , Functor, (<$>), (<#>), void , Apply, (<*>) , Applicative, pure, liftA1 , Bind, (>>=) , Monad, return, liftM1, ap - , Semigroup, (<>), (++) , Semiring, (+), zero, (*), one , ModuloSemiring, (/), mod - , Ring, (-), negate - , Num + , Ring, (-) + , (%) + , negate , DivisionRing + , Num , Eq, (==), (/=) - , Ordering(..), Ord, compare, (<), (>), (<=), (>=) - , Bounded, top, bottom - , Lattice, sup, inf, (||), (&&) - , BoundedLattice - , ComplementedLattice, not - , DistributiveLattice - , BooleanAlgebra - , Show, show + , Ord, Ordering(..), compare, (<), (>), (<=), (>=) + , Bits, (.&.), (.|.), (.^.), shl, shr, zshr, complement + , BoolLike, (&&), (||) + , not + , Semigroup, (<>), (++) + , Unit(..), unit ) where - -- | The `Unit` type has a single inhabitant, called `unit`. It represents - -- | values with no computational content. - -- | - -- | `Unit` is often used, wrapped in a monadic type constructor, as the - -- | return type of a computation where only - -- | the _effects_ are important. - newtype Unit = Unit {} - - -- | `unit` is the sole inhabitant of the `Unit` type. - unit :: Unit - unit = Unit {} - - infixr 0 $ - infixl 0 # - - -- | Applies a function to its argument. - -- | - -- | ```purescript - -- | length $ groupBy productCategory $ filter isInStock $ products - -- | ``` - -- | - -- | is equivalent to: - -- | - -- | ```purescript - -- | length (groupBy productCategory (filter isInStock products)) - -- | ``` - -- | - -- | `($)` is different from [`(#)`](#-2) because it is right-infix instead of - -- | left: `a $ b $ c $ d x = a $ (b $ (c $ (d $ x))) = a (b (c (d x)))` - ($) :: forall a b. (a -> b) -> a -> b - ($) f x = f x - - -- | Applies an argument to a function. - -- | - -- | ```purescript - -- | products # filter isInStock # groupBy productCategory # length - -- | ``` - -- | - -- | is equivalent to: + -- | An alias for `true`, which can be useful in guard clauses: -- | -- | ```purescript - -- | length (groupBy productCategory (filter isInStock products)) + -- | max x y | x >= y = x + -- | | otherwise = y -- | ``` -- | - -- | `(#)` is different from [`($)`](#-1) because it is left-infix instead of - -- | right: `x # a # b # c # d = (((x # a) # b) # c) # d = d (c (b (a x)))` - (#) :: forall a b. a -> (a -> b) -> b - (#) x f = f x + otherwise :: Boolean + otherwise = true -- | Flips the order of the arguments to a function of two arguments. -- | -- | ```purescript -- | flip const 1 2 = const 2 1 = 2 -- | ``` + -- | flip :: forall a b c. (a -> b -> c) -> b -> a -> c flip f b a = f a b @@ -92,29 +53,104 @@ module Prelude -- | ```purescript -- | const 1 "hello" = 1 -- | ``` + -- | const :: forall a b. a -> b -> a const a _ = a - -- | This function returns its first argument, and can be used to assert type - -- | equalities. This can be useful when types are otherwise ambiguous. + -- | This function returns its first argument, and can be used to assert type equalities. + -- | This can be useful when types are otherwise ambiguous. -- | -- | ```purescript -- | main = print $ [] `asTypeOf` [0] -- | ``` -- | - -- | If instead, we had written `main = print []`, the type of the argument - -- | `[]` would have been ambiguous, resulting in a compile-time error. + -- | If instead, we had written `main = print []`, the type of the argument `[]` would have + -- | been ambiguous, resulting in a compile-time error. asTypeOf :: forall a. a -> a -> a asTypeOf x _ = x - -- | An alias for `true`, which can be useful in guard clauses: + infixr 9 >>> + infixr 9 <<< + + -- | A `Semigroupoid` is similar to a [`Category`](#category) but does not require an identity + -- | element `id`, just composable morphisms. + -- | + -- | `Semigroupoid`s should obey the following rule: + -- | + -- | - Associativity: `p <<< (q <<< r) = (p <<< q) <<< r` + -- | + -- | One example of a `Semigroupoid` is the function type constructor `(->)`, with `(<<<)` defined + -- | as function composition. + 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) + + -- | Forwards composition, or `(<<<)` with its arguments reversed. + (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d + (>>>) f g = g <<< f + + -- | `Category`s consist of objects and composable morphisms between them, and as such are + -- | [`Semigroupoids`](#semigroupoid), but unlike `semigroupoids` must have an identity element. + -- | + -- | `Category`s should obey the following rules. + -- | + -- | - Left Identity: `id <<< p = p` + -- | - Right Identity: `p <<< id = p` + -- | + class (Semigroupoid a) <= Category a where + id :: forall t. a t t + + instance categoryArr :: Category (->) where + id x = x + + infixr 0 $ + infixl 0 # + + -- | Applies a function to its argument -- | -- | ```purescript - -- | max x y | x >= y = x - -- | | otherwise = y + -- | length $ groupBy productCategory $ filter isInStock products -- | ``` - otherwise :: Boolean - otherwise = true + -- | + -- | is equivalent to + -- | + -- | ```purescript + -- | length (groupBy productCategory (filter isInStock (products))) + -- | ``` + -- | + -- | `($)` is different from [`(#)`](#-2) because it is right-infix instead of left, so + -- | `a $ b $ c $ d x` = `a $ (b $ (c $ (d $ x)))` = `a (b (c (d x)))` + -- | + ($) :: forall a b. (a -> b) -> a -> b + ($) f x = f x + + -- | Applies a function to its argument + -- | + -- | ```purescript + -- | products # groupBy productCategory # filter isInStock # length + -- | ``` + -- | + -- | is equivalent to + -- | + -- | ```purescript + -- | length (groupBy productCategory (filter isInStock (products))) + -- | ``` + -- | + -- | `(#)` is different from [`($)`](#-1) because it is left-infix instead of right, so + -- | `x # a # b # c # d` = `(((x # a) # b) # c) # d` = `d (c (b (a x)))` + -- | + (#) :: forall a b. a -> (a -> b) -> b + (#) x f = f x + + infixr 6 : + + -- | An infix alias for `cons`. + -- | + -- | Note, the running time of this function is `O(n)`. + (:) :: forall a. a -> [a] -> [a] + (:) = cons -- | Attaches an element to the front of an array, creating a new array. -- | @@ -132,70 +168,72 @@ module Prelude } """ :: forall a. a -> [a] -> [a] - infixr 6 : - - -- | An infix alias for `cons`. + -- | The `Show` type class represents those types which can be converted into a human-readable `String` representation. -- | - -- | Note, the running time of this function is `O(n)`. - (:) :: forall a. a -> [a] -> [a] - (:) = cons + -- | While not required, it is recommended that for any expression `x`, the string `show x` be executable PureScript code + -- | which evaluates to the same value as the expression `x`. + class Show a where + show :: a -> String - infixr 9 >>> - infixr 9 <<< + foreign import showStringImpl + """ + function showStringImpl(s) { + return JSON.stringify(s); + } + """ :: String -> String - -- | A `Semigroupoid` is similar to a [`Category`](#category) but does not - -- | require an identity element `id`, just composable morphisms. - -- | - -- | `Semigroupoid`s must satisfy the following law: - -- | - -- | - Associativity: `p <<< (q <<< r) = (p <<< q) <<< r` - -- | - -- | One example of a `Semigroupoid` is the function type constructor `(->)`, - -- | with `(<<<)` defined as function composition. - class Semigroupoid a where - (<<<) :: forall b c d. a c d -> a b c -> a b d + instance showUnit :: Show Unit where + show (Unit {}) = "Unit {}" - instance semigroupoidArr :: Semigroupoid (->) where - (<<<) f g x = f (g x) + instance showString :: Show String where + show = showStringImpl - -- | Forwards composition, or `(<<<)` with its arguments reversed. - (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d - (>>>) f g = g <<< f + instance showBoolean :: Show Boolean where + show true = "true" + show false = "false" - -- | `Category`s consist of objects and composable morphisms between them, and - -- | as such are [`Semigroupoids`](#semigroupoid), but unlike `semigroupoids` - -- | must have an identity element. - -- | - -- | Instances must satisfy the following law in addition to the - -- | `Semigroupoid` law: - -- | - -- | - Identity: `id <<< p = p <<< id = p` - class (Semigroupoid a) <= Category a where - id :: forall t. a t t + foreign import showNumberImpl + """ + function showNumberImpl(n) { + return n.toString(); + } + """ :: Number -> String - instance categoryArr :: Category (->) where - id x = x + 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 <$> infixl 1 <#> - -- | A `Functor` is a type constructor which supports a mapping operation - -- | `(<$>)`. + -- | A `Functor` is a type constructor which supports a mapping operation `(<$>)`. -- | - -- | `(<$>)` can be used to turn functions `a -> b` into functions - -- | `f a -> f b` whose argument and return types use the type constructor `f` - -- | to represent some computational context. + -- | `(<$>)` can be used to turn functions `a -> b` into functions `f a -> f b` whose argument and return + -- | types use the type constructor `f` to represent some computational context. -- | - -- | Instances must satisfy the following laws: + -- | `Functor` instances should satisfy the following laws: -- | -- | - Identity: `(<$>) id = id` -- | - Composition: `(<$>) (f <<< g) = (f <$>) <<< (g <$>)` + -- | class Functor f where (<$>) :: forall a b. (a -> b) -> f a -> f b - instance functorArr :: Functor ((->) r) where - (<$>) = (<<<) - -- | `(<#>)` is `(<$>)` with its arguments reversed. For example: -- | -- | ```purescript @@ -204,12 +242,10 @@ module Prelude (<#>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b (<#>) fa f = f <$> fa - -- | The `void` function is used to ignore the type wrapped by a - -- | [`Functor`](#functor), replacing it with `Unit` and keeping only the type - -- | information provided by the type constructor itself. + -- | The `void` function is used to ignore the type wrapped by a [`Functor`](#functor), replacing it with `Unit` and + -- | keeping only the type information provided by the type constructor itself. -- | - -- | `void` is often useful when using `do` notation to change the return type - -- | of a monadic computation: + -- | `void` is often useful when using `do` notation to change the return type of a monadic computation: -- | -- | ```purescript -- | main = forE 1 10 \n -> void do @@ -221,69 +257,48 @@ module Prelude infixl 4 <*> - -- | The `Apply` class provides the `(<*>)` which is used to apply a function - -- | to an argument under a type constructor. + -- | The `Apply` class provides the `(<*>)` which is used to apply a function to an argument under a type constructor. -- | - -- | `Apply` can be used to lift functions of two or more arguments to work on - -- | values wrapped with the type constructor `f`. It might also be understood - -- | in terms of the `lift2` function: + -- | `Apply` can be used to lift functions of two or more arguments to work on values wrapped with the type constructor `f`. + -- | It might also be understood in terms of the `lift2` function: -- | -- | ```purescript -- | lift2 :: forall f a b c. (Apply f) => (a -> b -> c) -> f a -> f b -> f c -- | lift2 f a b = f <$> a <*> b -- | ``` -- | - -- | `(<*>)` is recovered from `lift2` as `lift2 ($)`. That is, `(<*>)` lifts - -- | the function application operator `($)` to arguments wrapped with the - -- | type constructor `f`. + -- | `(<*>)` is recovered from `lift2` as `lift2 ($)`. That is, `(<*>)` lifts the function application operator `($)` to arguments + -- | wrapped with the type constructor `f`. -- | - -- | Instances must satisfy the following law in addition to the `Functor` - -- | laws: + -- | `Apply` instances should satisfy the following law: -- | - -- | - Associative composition: `(<<<) <$> f <*> g <*> h = f <*> (g <*> h)` + -- | - Associative Composition: `(<<<) <$> f <*> g <*> h = f <*> (g <*> h)` -- | -- | Formally, `Apply` represents a strong lax semi-monoidal endofunctor. class (Functor f) <= Apply f where (<*>) :: forall a b. f (a -> b) -> f a -> f b - instance applyArr :: Apply ((->) r) where - (<*>) f g x = f x (g x) - - -- | The `Applicative` type class extends the [`Apply`](#apply) type class - -- | with a `pure` function, which can be used to create values of type `f a` - -- | from values of type `a`. + -- | The `Applicative` type class extends the [`Apply`](#apply) type class with a `pure` function, which can be used to + -- | create values of type `f a` from values of type `a`. -- | - -- | Where [`Apply`](#apply) provides the ability to lift functions of two or - -- | more arguments to functions whose arguments are wrapped using `f`, and - -- | [`Functor`](#functor) provides the ability to lift functions of one - -- | argument, `pure` can be seen as the function which lifts functions of - -- | _zero_ arguments. That is, `Applicative` functors support a lifting - -- | operation for any number of function arguments. + -- | Where [`Apply`](#apply) provides the ability to lift functions of two or more arguments to functions whose arguments are wrapped using `f`, + -- | and [`Functor`](#functor) provides the ability to lift functions of one argument, `pure` can be seen as the function which lifts functions of + -- | _zero_ arguments. That is, `Applicative` functors support a lifting operation for any number of function arguments. -- | - -- | Instances must satisfy the following laws in addition to the `Apply` - -- | laws: + -- | `Applicative` instances should satisfy the following laws: -- | -- | - Identity: `(pure id) <*> v = v` -- | - Composition: `(pure <<<) <*> f <*> g <*> h = f <*> (g <*> h)` -- | - Homomorphism: `(pure f) <*> (pure x) = pure (f x)` -- | - Interchange: `u <*> (pure y) = (pure ($ y)) <*> u` + -- | class (Apply f) <= Applicative f where pure :: forall a. a -> f a - instance applicativeArr :: Applicative ((->) r) where - pure = const - - -- | `return` is an alias for `pure`. - return :: forall m a. (Applicative m) => a -> m a - return = pure - - -- | `liftA1` provides a default implementation of `(<$>)` for any - -- | [`Applicative`](#applicative) functor, without using `(<$>)` as provided - -- | by the [`Functor`](#functor)-[`Applicative`](#applicative) superclass - -- | relationship. + -- | `liftA1` provides a default implementation of `(<$>)` for any [`Applicative`](#applicative) functor, + -- | without using `(<$>)` as provided by the [`Functor`](#functor)-[`Applicative`](#applicative) superclass relationship. -- | - -- | `liftA1` can therefore be used to write [`Functor`](#functor) instances - -- | as follows: + -- | `liftA1` can therefore be used to write [`Functor`](#functor) instances as follows: -- | -- | ```purescript -- | instance functorF :: Functor F where @@ -294,9 +309,8 @@ module Prelude infixl 1 >>= - -- | The `Bind` type class extends the [`Apply`](#apply) type class with a - -- | "bind" operation `(>>=)` which composes computations in sequence, using - -- | the return value of one computation to determine the next computation. + -- | The `Bind` type class extends the [`Apply`](#apply) type class with a "bind" operation `(>>=)` which composes computations + -- | in sequence, using the return value of one computation to determine the next computation. -- | -- | The `>>=` operator can also be expressed using `do` notation, as follows: -- | @@ -307,13 +321,15 @@ module Prelude -- | -- | where the function argument of `f` is given the name `y`. -- | - -- | Instances must satisfy the following law in addition to the `Apply` - -- | laws: + -- | `Bind` instances should satisfy the following law: -- | -- | - Associativity: `(x >>= f) >>= g = x >>= (\k => f k >>= g)` -- | - -- | Associativity tells us that we can regroup operations which use `do` - -- | notation so that we can unambiguously write, for example: + -- | Or, expressed using `do` notation: + -- | + -- | - Associativity: `do { z <- do { y <- x ; f y } ; g z } = do { k <- x ; do { y <- f k ; g y } }` + -- | + -- | Associativity tells us that we can regroup operations which use do-notation, so that we can unambiguously write, for example: -- | -- | ```purescript -- | do x <- m1 @@ -323,29 +339,29 @@ module Prelude class (Apply m) <= Bind m where (>>=) :: forall a b. m a -> (a -> m b) -> m b - instance bindArr :: Bind ((->) r) where - (>>=) m f x = f (m x) x - - -- | The `Monad` type class combines the operations of the `Bind` and - -- | `Applicative` type classes. Therefore, `Monad` instances represent type - -- | constructors which support sequential composition, and also lifting of - -- | functions of arbitrary arity. + -- | The `Monad` type class combines the operations of the `Bind` and `Applicative` type classes. Therefore, `Monad` instances + -- | represent type constructors which support sequential composition, and also lifting of functions of arbitrary arity. -- | - -- | Instances must satisfy the following laws in addition to the - -- | `Applicative` and `Bind` laws: + -- | `Monad` instances should satisfy the following laws: -- | -- | - Left Identity: `pure x >>= f = f x` -- | - Right Identity: `x >>= pure = x` + -- | + -- | Or, expressed using `do` notation: + -- | + -- | - Left Identity: `do { y <- pure x ; f y } = f x` + -- | - Right Identity: `do { y <- x ; pure y } = x` + -- | class (Applicative m, Bind m) <= Monad m - instance monadArr :: Monad ((->) r) + -- | `return` is an alias for `pure`. + return :: forall m a. (Monad m) => a -> m a + return = pure - -- | `liftM1` provides a default implementation of `(<$>)` for any - -- | [`Monad`](#monad), without using `(<$>)` as provided by the - -- | [`Functor`](#functor)-[`Monad`](#monad) superclass relationship. + -- | `liftM1` provides a default implementation of `(<$>)` for any [`Monad`](#monad), + -- | without using `(<$>)` as provided by the [`Functor`](#functor)-[`Monad`](#monad) superclass relationship. -- | - -- | `liftM1` can therefore be used to write [`Functor`](#functor) instances - -- | as follows: + -- | `liftM1` can therefore be used to write [`Functor`](#functor) instances as follows: -- | -- | ```purescript -- | instance functorF :: Functor F where @@ -356,12 +372,10 @@ module Prelude a' <- a return (f a') - -- | `ap` provides a default implementation of `(<*>)` for any - -- | [`Monad`](#monad), without using `(<*>)` as provided by the - -- | [`Apply`](#apply)-[`Monad`](#monad) superclass relationship. + -- | `ap` provides a default implementation of `(<*>)` for any [`Monad`](#monad), + -- | without using `(<*>)` as provided by the [`Apply`](#apply)-[`Monad`](#monad) superclass relationship. -- | - -- | `ap` can therefore be used to write [`Apply`](#apply) instances as - -- | follows: + -- | `ap` can therefore be used to write [`Apply`](#apply) instances as follows: -- | -- | ```purescript -- | instance applyF :: Apply F where @@ -373,152 +387,68 @@ module Prelude a' <- a return (f' a') - infixr 5 <> - infixr 5 ++ - - -- | The `Semigroup` type class identifies an associative operation on a type. - -- | - -- | Instances are required to satisfy the following law: - -- | - -- | - Associativity: `(x <> y) <> z = x <> (y <> z)` - -- | - -- | One example of a `Semigroup` is `String`, with `(<>)` defined as string - -- | concatenation. - class Semigroup a where - (<>) :: a -> a -> a - - -- | `(++)` is an alias for `(<>)`. - (++) :: forall s. (Semigroup s) => s -> s -> s - (++) = (<>) + instance functorArr :: Functor ((->) r) where + (<$>) = (<<<) - instance semigroupString :: Semigroup String where - (<>) = concatString + instance applyArr :: Apply ((->) r) where + (<*>) f g x = f x (g x) - instance semigroupUnit :: Semigroup Unit where - (<>) _ _ = unit + instance applicativeArr :: Applicative ((->) r) where + pure = const - instance semigroupArr :: (Semigroup s') => Semigroup (s -> s') where - (<>) f g = \x -> f x <> g x + instance bindArr :: Bind ((->) r) where + (>>=) m f x = f (m x) x - instance semigroupOrdering :: Semigroup Ordering where - (<>) LT _ = LT - (<>) GT _ = GT - (<>) EQ y = y + instance monadArr :: Monad ((->) r) - foreign import concatString - """ - function concatString(s1) { - return function(s2) { - return s1 + s2; - }; - } - """ :: String -> String -> String + infixl 7 * + infixl 7 / + infixl 7 % + infixl 6 - infixl 6 + - infixl 7 * - -- | The `Semiring` class is for types that support an addition and - -- | multiplication operation. - -- | - -- | Instances must satisfy the following laws: - -- | - -- | - Commutative monoid under addition: - -- | - Associativity: `(a + b) + c = a + (b + c)` - -- | - Identity: `zero + a = a + zero = a` - -- | - Commutative: `a + b = b + a` - -- | - Monoid under multiplication: - -- | - Associativity: `(a * b) * c = a * (b * c)` - -- | - Identity: `one * a = a * one = a` - -- | - Multiplication distributes over addition: - -- | - Left distributivity: `a * (b + c) = (a * b) + (a * c)` - -- | - Right distributivity: `(a + b) * c = (a * c) + (b * c)` - -- | - Annihiliation: `zero * a = a * zero = zero` + -- | Addition and multiplication, satisfying the following laws: + -- | + -- | - `a` is a commutative monoid under addition + -- | - `a` is a monoid under multiplication + -- | - multiplication distributes over addition + -- | - multiplication by `zero` annihilates `a` + -- | class Semiring a where (+) :: a -> a -> a zero :: a (*) :: a -> a -> a one :: a - instance semiringNumber :: Semiring Number where - (+) = numAdd - zero = 0 - (*) = numMul - one = 1 - - instance semiringUnit :: Semiring Unit where - (+) _ _ = unit - zero = unit - (*) _ _ = unit - one = unit - - infixl 6 - - - -- | The `Ring` class is for types that support addition, multiplication, - -- | and subtraction operations. - -- | - -- | Instances must satisfy the following law in addition to the `Semiring` - -- | laws: - -- | - -- | - Additive inverse: `a + (-a) = (-a) + a = zero` - class (Semiring a) <= Ring a where - (-) :: a -> a -> a - - instance ringNumber :: Ring Number where - (-) = numSub - - instance ringUnit :: Ring Unit where - (-) _ _ = unit - - negate :: forall a. (Ring a) => a -> a - negate a = zero - a - - infixl 7 / - - -- | The `ModuloSemiring` class is for types that support addition, - -- | multiplication, division, and modulo (division remainder) operations. + -- | Addition, multiplication, modulo operation and division, satisfying: -- | - -- | Instances must satisfy the following law in addition to the `Semiring` - -- | laws: + -- | - ```a / b * b + (a `mod` b) = a``` -- | - -- | - Remainder: `a / b * b + (a `mod` b) = a` class (Semiring a) <= ModuloSemiring a where (/) :: a -> a -> a mod :: a -> a -> a - instance moduloSemiringNumber :: ModuloSemiring Number where - (/) = numDiv - mod _ _ = 0 - - instance moduloSemiringUnit :: ModuloSemiring Unit where - (/) _ _ = unit - mod _ _ = unit - - -- | A `Ring` where every nonzero element has a multiplicative inverse. + -- | Addition, multiplication, and subtraction. -- | - -- | Instances must satisfy the following law in addition to the `Ring` and - -- | `ModuloSemiring` laws: + -- | Has the same laws as `Semiring` but additionally satisfying: -- | - -- | - Multiplicative inverse: `(one / x) * x = one` + -- | - `a` is an abelian group under addition -- | - -- | As a consequence of this ```a `mod` b = zero``` as no divide operation - -- | will have a remainder. - class (Ring a, ModuloSemiring a) <= DivisionRing a - - instance divisionRingNumber :: DivisionRing Number + class (Semiring a) <= Ring a where + (-) :: a -> a -> a - instance divisionRingUnit :: DivisionRing Unit + negate :: forall a. (Ring a) => a -> a + negate a = zero - a - -- | The `Num` class is for types that are commutative fields. + -- | Ring where every nonzero element has a multiplicative inverse so that: -- | - -- | Instances must satisfy the following law in addition to the - -- | `DivisionRing` laws: + -- | - ```a `mod` b = zero``` -- | - -- | - Commutative multiplication: `a * b = b * a` - class (DivisionRing a) <= Num a - - instance numNumber :: Num Number + class (Ring a, ModuloSemiring a) <= DivisionRing a - instance numUnit :: Num Unit + -- | A commutative field + class (DivisionRing a) <= Num a foreign import numAdd """ @@ -529,6 +459,15 @@ module Prelude } """ :: Number -> Number -> Number + foreign import numSub + """ + function numSub(n1) { + return function(n2) { + return n1 - n2; + }; + } + """ :: Number -> Number -> Number + foreign import numMul """ function numMul(n1) { @@ -547,15 +486,44 @@ module Prelude } """ :: Number -> Number -> Number - foreign import numSub + foreign import numMod """ - function numSub(n1) { + function numMod(n1) { return function(n2) { - return n1 - n2; + return n1 % n2; }; } """ :: Number -> Number -> Number + (%) = numMod + + instance semiringNumber :: Semiring Number where + (+) = numAdd + zero = 0 + (*) = numMul + one = 1 + + instance ringNumber :: Ring Number where + (-) = numSub + + instance moduloSemiringNumber :: ModuloSemiring Number where + (/) = numDiv + mod _ _ = 0 + + instance divisionRingNumber :: DivisionRing Number + + instance numNumber :: Num Number + + -- | The `Unit` type has a single inhabitant, called `unit`. It represents values with no computational content. + -- | + -- | `Unit` is often used, wrapped in a monadic type constructor, as the return type of a computation where only + -- | the _effects_ are important. + newtype Unit = Unit {} + + -- | `unit` is the sole inhabitant of the `Unit` type. + unit :: Unit + unit = Unit {} + infix 4 == infix 4 /= @@ -573,33 +541,6 @@ module Prelude (==) :: a -> a -> Boolean (/=) :: a -> a -> Boolean - instance eqBoolean :: Eq Boolean where - (==) = refEq - (/=) = refIneq - - instance eqNumber :: Eq Number where - (==) = refEq - (/=) = refIneq - - instance eqString :: Eq String where - (==) = refEq - (/=) = refIneq - - instance eqUnit :: Eq Unit where - (==) _ _ = true - (/=) _ _ = false - - instance eqArray :: (Eq a) => Eq [a] where - (==) = eqArrayImpl (==) - (/=) xs ys = not (xs == ys) - - instance eqOrdering :: Eq Ordering where - (==) LT LT = true - (==) GT GT = true - (==) EQ EQ = true - (==) _ _ = false - (/=) x y = not (x == y) - foreign import refEq """ function refEq(r1) { @@ -618,6 +559,22 @@ module Prelude } """ :: 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) { @@ -633,14 +590,34 @@ module Prelude } """ :: forall a. (a -> a -> Boolean) -> [a] -> [a] -> Boolean - -- | The `Ordering` data type represents the three possible outcomes of - -- | comparing two values: + instance eqArray :: (Eq a) => Eq [a] where + (==) xs ys = eqArrayImpl (==) xs ys + (/=) xs ys = not (xs == ys) + + -- | The `Ordering` data type represents the three possible outcomes of comparing two values: -- | -- | `LT` - The first value is _less than_ the second. -- | `GT` - The first value is _greater than_ the second. -- | `EQ` - The first value is _equal to_ or _incomparable to_ the second. 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" + + instance semigroupOrdering :: Semigroup Ordering where + (<>) LT _ = LT + (<>) GT _ = GT + (<>) EQ y = y + -- | The `Ord` type class represents types which support comparisons. -- | -- | `Ord` instances should satisfy the laws of _partially orderings_: @@ -648,45 +625,11 @@ module Prelude -- | - Reflexivity: `a <= a` -- | - Antisymmetry: if `a <= b` and `b <= a` then `a = b` -- | - Transitivity: if `a <= b` and `b <= c` then `a <= c` + -- | class (Eq a) <= Ord a where compare :: a -> a -> Ordering - 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 ordUnit :: Ord Unit where - compare _ _ = EQ - - 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 - - instance ordOrdering :: Ord Ordering where - compare LT LT = EQ - compare EQ EQ = EQ - compare GT GT = EQ - compare LT _ = LT - compare EQ LT = GT - compare EQ GT = LT - compare GT _ = GT - infixl 4 < - infixl 4 > - infixl 4 <= - infixl 4 >= -- | Test whether one value is _strictly less than_ another. (<) :: forall a. (Ord a) => a -> a -> Boolean @@ -694,27 +637,30 @@ module Prelude LT -> true _ -> false + infixl 4 > + -- | Test whether one value is _strictly greater than_ another. (>) :: forall a. (Ord a) => a -> a -> Boolean (>) a1 a2 = case a1 `compare` a2 of GT -> true _ -> false + infixl 4 <= + -- | Test whether one value is _non-strictly less than_ another. (<=) :: forall a. (Ord a) => a -> a -> Boolean (<=) a1 a2 = case a1 `compare` a2 of GT -> false _ -> true + infixl 4 >= + -- | Test whether one value is _non-strictly greater than_ another. (>=) :: forall a. (Ord a) => a -> a -> Boolean (>=) a1 a2 = case a1 `compare` a2 of LT -> false _ -> true - unsafeCompare :: forall a. a -> a -> Ordering - unsafeCompare = unsafeCompareImpl LT EQ GT - foreign import unsafeCompareImpl """ function unsafeCompareImpl(lt) { @@ -730,148 +676,145 @@ module Prelude } """ :: forall a. Ordering -> Ordering -> Ordering -> a -> a -> Ordering - -- | The `Bounded` type class represents types that are finite partially - -- | ordered sets. - -- | - -- | Instances should satisfy the following law in addition to the `Ord` laws: - -- | - -- | - Ordering: `bottom <= a <= top` - class (Ord a) <= Bounded a where - top :: a - bottom :: a - - instance boundedBoolean :: Bounded Boolean where - top = true - bottom = false - - instance boundedUnit :: Bounded Unit where - top = unit - bottom = unit - - instance boundedOrdering :: Bounded Ordering where - top = GT - bottom = LT - - -- | The `Lattice` type class represents types that are partially ordered - -- | sets with a supremum (`sup` or `||`) and infimum (`inf` or `&&`). - -- | - -- | Instances should satisfy the following laws in addition to the `Ord` - -- | laws: - -- | - -- | - Associativity: - -- | - `a || (b || c) = (a || b) || c` - -- | - `a && (b && c) = (a && b) && c` - -- | - Commutativity: - -- | - `a || b = b || a` - -- | - `a && b = b && a` - -- | - Absorption: - -- | - `a || (a && b) = a` - -- | - `a && (a || b) = a` - -- | - Idempotent: - -- | - `a || a = a` - -- | - `a && a = a` - class (Ord a) <= Lattice a where - sup :: a -> a -> a - inf :: a -> a -> a - - instance latticeBoolean :: Lattice Boolean where - sup = boolOr - inf = boolAnd - - instance latticeUnit :: Lattice Unit where - sup _ _ = unit - inf _ _ = unit + unsafeCompare :: forall a. a -> a -> Ordering + unsafeCompare = unsafeCompareImpl LT EQ GT - infixr 2 || - infixr 3 && + instance ordUnit :: Ord Unit where + compare (Unit {}) (Unit {}) = EQ - -- | The `sup` operator. - (||) :: forall a. (Lattice a) => a -> a -> a - (||) = sup + instance ordBoolean :: Ord Boolean where + compare false false = EQ + compare false true = LT + compare true true = EQ + compare true false = GT - -- | The `inf` operator. - (&&) :: forall a. (Lattice a) => a -> a -> a - (&&) = inf + instance ordNumber :: Ord Number where + compare = unsafeCompare - -- | The `BoundedLattice` type class represents types that are finite - -- | lattices. - -- | - -- | Instances should satisfy the following law in addition to the `Lattice` - -- | and `Bounded` laws: - -- | - -- | - Identity: - -- | - `a || bottom = a` - -- | - `a && top = a` - -- | - Annihiliation: - -- | - `a || top = top` - -- | - `a && bottom = bottom` - class (Bounded a, Lattice a) <= BoundedLattice a + instance ordString :: Ord String where + compare = unsafeCompare - instance boundedLatticeBoolean :: BoundedLattice Boolean + 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 - instance boundedLatticeUnit :: BoundedLattice Unit + infixl 10 .&. + infixl 10 .|. + infixl 10 .^. + + -- | The `Bits` type class identifies types which support bitwise operations. + 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 - -- | The `ComplementedLattice` type class represents types that are lattices - -- | where every member is also uniquely complemented. - -- | - -- | Instances should satisfy the following law in addition to the - -- | `BoundedLattice` laws: - -- | - -- | - Complemented: - -- | - `not a || a == top` - -- | - `not a && a == bottom` - -- | - Double negation: - -- | - `not <<< not == id` - class (BoundedLattice a) <= ComplementedLattice a where - not :: a -> a + foreign import numShr + """ + function numShr(n1) { + return function(n2) { + return n1 >> n2; + }; + } + """ :: Number -> Number -> Number - instance complementedLatticeBoolean :: ComplementedLattice Boolean where - not = boolNot + foreign import numZshr + """ + function numZshr(n1) { + return function(n2) { + return n1 >>> n2; + }; + } + """ :: Number -> Number -> Number - instance complementedLatticeUnit :: ComplementedLattice Unit where - not _ = unit + foreign import numAnd + """ + function numAnd(n1) { + return function(n2) { + return n1 & n2; + }; + } + """ :: Number -> Number -> Number - -- | The `DistributiveLattice` type class represents types that are lattices - -- | where the `&&` and `||` distribute over each other. - -- | - -- | Instances should satisfy the following law in addition to the `Lattice` - -- | laws: - -- | - -- | - Distributivity: `x && (y || z) = (x && y) || (x && z)` - class (Lattice a) <= DistributiveLattice a + foreign import numOr + """ + function numOr(n1) { + return function(n2) { + return n1 | n2; + }; + } + """ :: Number -> Number -> Number - instance distributiveLatticeBoolean :: DistributiveLattice Boolean + foreign import numXor + """ + function numXor(n1) { + return function(n2) { + return n1 ^ n2; + }; + } + """ :: Number -> Number -> Number - instance distributiveLatticeUnit :: DistributiveLattice Unit + foreign import numComplement + """ + function numComplement(n) { + return ~n; + } + """ :: Number -> Number - -- | The `BooleanAlgebra` type class represents types that are Boolean - -- | algebras, also known as Boolean lattices. - -- | - -- | Instances should satisfy the `ComplementedLattice` and - -- | `DistributiveLattice` laws. - class (ComplementedLattice a, DistributiveLattice a) <= BooleanAlgebra a + instance bitsNumber :: Bits Number where + (.&.) = numAnd + (.|.) = numOr + (.^.) = numXor + shl = numShl + shr = numShr + zshr = numZshr + complement = numComplement - instance booleanAlgebraBoolean :: BooleanAlgebra Boolean + infixr 2 || + infixr 3 && - instance booleanAlgebraUnit :: BooleanAlgebra Unit + -- | The `BoolLike` type class identifies types which support Boolean operations. + -- | + -- | `BoolLike` instances are required to satisfy the laws of a _Boolean algebra_. + -- | + class BoolLike b where + (&&) :: b -> b -> b + (||) :: b -> b -> b + not :: b -> b - foreign import boolOr + foreign import boolAnd """ - function boolOr(b1) { + function boolAnd(b1) { return function(b2) { - return b1 || b2; + return b1 && b2; }; } - """ :: Boolean -> Boolean -> Boolean + """ :: Boolean -> Boolean -> Boolean - foreign import boolAnd + foreign import boolOr """ - function boolAnd(b1) { + function boolOr(b1) { return function(b2) { - return b1 && b2; + return b1 || b2; }; } - """ :: Boolean -> Boolean -> Boolean + """ :: Boolean -> Boolean -> Boolean foreign import boolNot """ @@ -880,62 +823,46 @@ module Prelude } """ :: Boolean -> Boolean - -- | The `Show` type class represents those types which can be converted into - -- | a human-readable `String` representation. - -- | - -- | While not required, it is recommended that for any expression `x`, the - -- | string `show x` be executable PureScript code which evaluates to the same - -- | value as the expression `x`. - class Show a where - show :: a -> String - - instance showBoolean :: Show Boolean where - show true = "true" - show false = "false" + instance boolLikeBoolean :: BoolLike Boolean where + (&&) = boolAnd + (||) = boolOr + not = boolNot - instance showNumber :: Show Number where - show = showNumberImpl + infixr 5 <> - instance showString :: Show String where - show = showStringImpl + -- | The `Semigroup` type class identifies an associative operation on a type. + -- | + -- | `Semigroup` instances are required to satisfy the following law: + -- | + -- | - Associativity: `(x <> y) <> z = x <> (y <> z)` + -- | + -- | For example, the `String` type is an instance of `Semigroup`, where `(<>)` is defined to be string concatenation. + class Semigroup a where + (<>) :: a -> a -> a - instance showUnit :: Show Unit where - show _ = "unit" + foreign import concatString + """ + function concatString(s1) { + return function(s2) { + return s1 + s2; + }; + } + """ :: String -> String -> String - instance showArray :: (Show a) => Show [a] where - show = showArrayImpl show + instance semigroupUnit :: Semigroup Unit where + (<>) (Unit {}) (Unit {}) = Unit {} - instance showOrdering :: Show Ordering where - show LT = "LT" - show GT = "GT" - show EQ = "EQ" + instance semigroupString :: Semigroup String where + (<>) = concatString - foreign import showNumberImpl - """ - function showNumberImpl(n) { - return n.toString(); - } - """ :: Number -> String + instance semigroupArr :: (Semigroup s') => Semigroup (s -> s') where + (<>) f g = \x -> f x <> g x - foreign import showStringImpl - """ - function showStringImpl(s) { - return JSON.stringify(s); - } - """ :: String -> String + infixr 5 ++ - 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 + -- | `(++)` is an alias for `(<>)`. + (++) :: forall s. (Semigroup s) => s -> s -> s + (++) = (<>) module Data.Function where diff --git a/psc-make/Main.hs b/psc-make/Main.hs index c5dfdf9..370826c 100644 --- a/psc-make/Main.hs +++ b/psc-make/Main.hs @@ -52,29 +52,27 @@ readInput InputOptions{..} = do content <- forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readFile inFile return (if ioNoPrelude then content else (Left P.RebuildNever, P.prelude) : content) -newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ExceptT P.MultipleErrors IO) a } - deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadReader (P.Options P.Make)) +newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ExceptT String IO) a } + deriving (Functor, Applicative, Monad, MonadIO, MonadError String, MonadReader (P.Options P.Make)) -runMake :: P.Options P.Make -> Make a -> IO (Either P.MultipleErrors a) +runMake :: P.Options P.Make -> Make a -> IO (Either String a) runMake opts = runExceptT . flip runReaderT opts . unMake -makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a -makeIO f io = do - e <- liftIO $ tryIOError io - either (throwError . P.errorMessage . f) return e +makeIO :: IO a -> Make a +makeIO = Make . lift . ExceptT . fmap (either (Left . show) Right) . tryIOError instance P.MonadMake Make where - getTimestamp path = makeIO (const (P.CannotGetFileInfo path)) $ do + getTimestamp path = makeIO $ do exists <- doesFileExist path traverse (const $ getModificationTime path) $ guard exists - readTextFile path = makeIO (const (P.CannotReadFile path))$ do + readTextFile path = makeIO $ do putStrLn $ "Reading " ++ path readFile path - writeTextFile path text = makeIO (const (P.CannotWriteFile path)) $ do + writeTextFile path text = makeIO $ do mkdirp path putStrLn $ "Writing " ++ path writeFile path text - progress = liftIO . putStrLn + progress = makeIO . putStrLn compile :: PSCMakeOptions -> IO () compile (PSCMakeOptions input outputDir opts usePrefix) = do @@ -86,8 +84,8 @@ compile (PSCMakeOptions input outputDir opts usePrefix) = do Right ms -> do e <- runMake opts $ P.make outputDir ms prefix case e of - Left errs -> do - putStrLn (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs) + Left err -> do + putStrLn err exitFailure Right _ -> do exitSuccess diff --git a/psc/Main.hs b/psc/Main.hs index 45653a7..6be836d 100644 --- a/psc/Main.hs +++ b/psc/Main.hs @@ -63,8 +63,8 @@ compile (PSCOptions input opts stdin output externs usePrefix) = do exitFailure Right ms -> do case P.compile (map snd ms) prefix `runReaderT` opts of - Left errs -> do - hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs) + Left err -> do + hPutStrLn stderr err exitFailure Right (js, exts, _) -> do case output of diff --git a/psci/Commands.hs b/psci/Commands.hs new file mode 100644 index 0000000..e7a8025 --- /dev/null +++ b/psci/Commands.hs @@ -0,0 +1,78 @@ +----------------------------------------------------------------------------- +-- +-- Module : Commands +-- Copyright : (c) Phil Freeman 2014 +-- License : MIT +-- +-- Maintainer : Phil Freeman <paf31@cantab.net> +-- Stability : experimental +-- Portability : +-- +-- | +-- Commands for PSCI. +-- +----------------------------------------------------------------------------- + +module Commands where + +import Language.PureScript + +-- | +-- Valid Meta-commands for PSCI +-- +data Command + -- | + -- A purescript expression + -- + = Expression Expr + -- | + -- Show the help command + -- + | Help + -- | + -- Import a module from a loaded file + -- + | Import ImportedModule + -- | + -- Browse a module + -- + | Browse ModuleName + -- | + -- Load a file for use with importing + -- + | LoadFile FilePath + -- | + -- Exit PSCI + -- + | Quit + -- | + -- Reset the state of the REPL + -- + | Reset + -- | + -- Add some declarations to the current evaluation context. + -- + | Decls [Declaration] + -- | + -- Find the type of an expression + -- + | TypeOf Expr + -- | + -- Find the kind of an expression + -- + | KindOf Type + -- | + -- Show command + -- + | Show String + +-- | All of the data that is contained by an ImportDeclaration in the AST. +-- That is: +-- +-- * A module name, the name of the module which is being imported +-- * An ImportDeclarationType which specifies whether there is an explicit +-- import list, a hiding list, or neither. +-- * If the module is imported qualified, its qualified name in the importing +-- module. Otherwise, Nothing. +-- +type ImportedModule = (ModuleName, ImportDeclarationType, Maybe ModuleName) diff --git a/psci/Completion.hs b/psci/Completion.hs deleted file mode 100644 index 0e5c1d3..0000000 --- a/psci/Completion.hs +++ /dev/null @@ -1,232 +0,0 @@ -module Completion where - -import Data.Maybe (mapMaybe) -import Data.List (nub, nubBy, sortBy, isPrefixOf, stripPrefix) -import Data.Char (isUpper) -import Data.Function (on) -import Data.Traversable (traverse) - -import Control.Applicative ((<$>), (<*>)) -import Control.Monad.Trans.Reader (asks, runReaderT, ReaderT) -import Control.Monad.Trans.State.Strict - -import System.Console.Haskeline - -import qualified Language.PureScript as P -import qualified Language.PureScript.Names as N - -import qualified Directive as D -import Types - --- Completions may read the state, but not modify it. -type CompletionM = ReaderT PSCiState IO - --- Lift a `CompletionM` action to a `StateT PSCiState IO` one. -liftCompletionM :: CompletionM a -> StateT PSCiState IO a -liftCompletionM act = StateT (\s -> (\a -> (a, s)) <$> runReaderT act s) - --- Haskeline completions - -data CompletionContext - = CtxDirective String - | CtxFilePath String - | CtxModule - | CtxIdentifier - | CtxType - | CtxFixed String - deriving (Show) - --- | --- Loads module, function, and file completions. --- -completion :: CompletionFunc (StateT PSCiState IO) -completion = liftCompletionM . completion' - -completion' :: CompletionFunc CompletionM -completion' = completeWordWithPrev Nothing " \t\n\r" findCompletions - --- | --- Decide what kind of completion we need based on input. This function expects --- a list of complete words (to the left of the cursor) as the first argument, --- and the current word as the second argument. -completionContext :: [String] -> String -> [CompletionContext] -completionContext [] _ = [CtxDirective "", CtxIdentifier, CtxFixed "import"] -completionContext ws w | headSatisfies (":" `isPrefixOf`) ws = completeDirective ws w -completionContext ws w | headSatisfies (== "import") ws = completeImport ws w -completionContext _ _ = [CtxIdentifier] - -completeDirective :: [String] -> String -> [CompletionContext] -completeDirective ws w = - case ws of - [] -> [CtxDirective w] - [dir] -> case D.directivesFor <$> stripPrefix ":" dir of - -- only offer completions if the directive is unambiguous - Just [dir'] -> directiveArg w dir' - _ -> [] - - -- All directives take exactly one argument. If we haven't yet matched, - -- that means one argument has already been supplied. So don't complete - -- any others. - _ -> [] - -directiveArg :: String -> Directive -> [CompletionContext] -directiveArg _ Browse = [CtxModule] -directiveArg w Load = [CtxFilePath w] -directiveArg _ Quit = [] -directiveArg _ Reset = [] -directiveArg _ Help = [] -directiveArg _ Show = map CtxFixed replQueryStrings -directiveArg _ Type = [CtxIdentifier] -directiveArg _ Kind = [CtxType] - -completeImport :: [String] -> String -> [CompletionContext] -completeImport ws w' = - case (ws, w') of - (["import"], w) | headSatisfies isUpper w -> [CtxModule] - (["import"], _) -> [CtxModule, CtxFixed "qualified"] - (["import", "qualified"], _) -> [CtxModule] - _ -> [] - -headSatisfies :: (a -> Bool) -> [a] -> Bool -headSatisfies p str = - case str of - (c:_) -> p c - _ -> False - --- | Callback for Haskeline's `completeWordWithPrev`. --- Expects: --- * Line contents to the left of the word, reversed --- * Word to be completed -findCompletions :: String -> String -> CompletionM [Completion] -findCompletions prev word = do - let ctx = completionContext (words (reverse prev)) word - completions <- concat <$> traverse getCompletions ctx - return $ sortBy directivesFirst completions - where - getCompletions :: CompletionContext -> CompletionM [Completion] - getCompletions = fmap (mapMaybe (either (prefixedBy word) Just)) . getCompletion - - prefixedBy :: String -> String -> Maybe Completion - prefixedBy w cand = if w `isPrefixOf` cand - then Just (simpleCompletion cand) - else Nothing - -getCompletion :: CompletionContext -> CompletionM [Either String Completion] -getCompletion ctx = - case ctx of - CtxFilePath f -> map Right <$> listFiles f - CtxModule -> map Left <$> getModuleNames - CtxIdentifier -> map Left <$> ((++) <$> getIdentNames <*> getDctorNames) - CtxType -> map Left <$> getTypeNames - CtxFixed str -> return [Left str] - CtxDirective d -> return (map Left (completeDirectives d)) - - where - completeDirectives :: String -> [String] - completeDirectives = map (':' :) . D.directiveStringsFor - - -getLoadedModules :: CompletionM [P.Module] -getLoadedModules = asks (map snd . psciLoadedModules) - -getImportedModules :: CompletionM [ImportedModule] -getImportedModules = asks psciImportedModules - -getModuleNames :: CompletionM [String] -getModuleNames = moduleNames <$> getLoadedModules - -mapLoadedModulesAndQualify :: (Show a) => (P.Module -> [(a, P.Declaration)]) -> CompletionM [String] -mapLoadedModulesAndQualify f = do - ms <- getLoadedModules - let argPairs = do m <- ms - fm <- f m - return (m, fm) - concat <$> traverse (uncurry getAllQualifications) argPairs - -getIdentNames :: CompletionM [String] -getIdentNames = mapLoadedModulesAndQualify identNames - -getDctorNames :: CompletionM [String] -getDctorNames = mapLoadedModulesAndQualify dctorNames - -getTypeNames :: CompletionM [String] -getTypeNames = mapLoadedModulesAndQualify typeDecls - --- | Given a module and a declaration in that module, return all possible ways --- it could have been referenced given the current PSCiState - including fully --- qualified, qualified using an alias, and unqualified. -getAllQualifications :: (Show a) => P.Module -> (a, P.Declaration) -> CompletionM [String] -getAllQualifications m (declName, decl) = do - imports <- getAllImportsOf m - let fullyQualified = qualifyWith (Just (P.getModuleName m)) - let otherQuals = nub (concatMap qualificationsUsing imports) - return $ fullyQualified : otherQuals - where - qualifyWith mMod = show (P.Qualified mMod declName) - referencedBy refs = P.isExported (Just refs) decl - - qualificationsUsing (_, importType, asQ') = - let q = qualifyWith asQ' - in case importType of - P.Implicit -> [q] - P.Explicit refs -> if referencedBy refs - then [q] - else [] - P.Hiding refs -> if referencedBy refs - then [] - else [q] - - --- | Returns all the ImportedModule values referring to imports of a particular --- module. -getAllImportsOf :: P.Module -> CompletionM [ImportedModule] -getAllImportsOf = asks . allImportsOf - -nubOnFst :: Eq a => [(a, b)] -> [(a, b)] -nubOnFst = nubBy ((==) `on` fst) - -typeDecls :: P.Module -> [(N.ProperName, P.Declaration)] -typeDecls = mapMaybe getTypeName . filter P.isDataDecl . P.exportedDeclarations - where - getTypeName :: P.Declaration -> Maybe (N.ProperName, P.Declaration) - getTypeName d@(P.TypeSynonymDeclaration name _ _) = Just (name, d) - getTypeName d@(P.DataDeclaration _ name _ _) = Just (name, d) - getTypeName (P.PositionedDeclaration _ _ d) = getTypeName d - getTypeName _ = Nothing - -identNames :: P.Module -> [(N.Ident, P.Declaration)] -identNames = nubOnFst . mapMaybe getDeclName . P.exportedDeclarations - where - getDeclName :: P.Declaration -> Maybe (P.Ident, P.Declaration) - getDeclName d@(P.ValueDeclaration ident _ _ _) = Just (ident, d) - getDeclName d@(P.ExternDeclaration _ ident _ _) = Just (ident, d) - getDeclName (P.PositionedDeclaration _ _ d) = getDeclName d - getDeclName _ = Nothing - -dctorNames :: P.Module -> [(N.ProperName, P.Declaration)] -dctorNames m = nubOnFst $ concatMap dctors dnames - where - getDataDeclName :: P.Declaration -> Maybe (N.ProperName, P.Declaration) - getDataDeclName d@(P.DataDeclaration _ name _ _) = Just (name, d) - getDataDeclName (P.PositionedDeclaration _ _ d) = getDataDeclName d - getDataDeclName _ = Nothing - - dnames :: [(N.ProperName, P.Declaration)] - dnames = (mapMaybe getDataDeclName onlyDataDecls) - - onlyDataDecls :: [P.Declaration] - onlyDataDecls = (filter P.isDataDecl (P.exportedDeclarations m)) - - dctors :: (N.ProperName, P.Declaration) -> [(N.ProperName, P.Declaration)] - dctors (name, decl) = map (\n -> (n, decl)) (map fst (P.exportedDctors m name)) - -moduleNames :: [P.Module] -> [String] -moduleNames ms = nub [show moduleName | P.Module _ moduleName _ _ <- ms] - -directivesFirst :: Completion -> Completion -> Ordering -directivesFirst (Completion _ d1 _) (Completion _ d2 _) = go d1 d2 - where - go (':' : xs) (':' : ys) = compare xs ys - go (':' : _) _ = LT - go _ (':' : _) = GT - go xs ys = compare xs ys diff --git a/psci/Directive.hs b/psci/Directive.hs index 366fc66..c7bebd2 100644 --- a/psci/Directive.hs +++ b/psci/Directive.hs @@ -15,85 +15,46 @@ module Directive where -import Data.Maybe (fromJust, listToMaybe) -import Data.List (isPrefixOf) -import Data.Tuple (swap) - -import Types - --- | --- List of all avaliable directives. --- -directives :: [Directive] -directives = map fst directiveStrings +import Data.List (nub, isPrefixOf) + +data Directive + = Help + | Quit + | Reset + | Browse + | Load + | Type + | Kind + | Show + deriving Eq -- | --- A mapping of directives to the different strings that can be used to invoke --- them. +-- Maps given directive to relating command strings. -- -directiveStrings :: [(Directive, [String])] -directiveStrings = - [ (Help , ["?", "help"]) - , (Quit , ["quit"]) - , (Reset , ["reset"]) - , (Browse , ["browse"]) - , (Load , ["load", "module"]) - , (Type , ["type"]) - , (Kind , ["kind"]) - , (Show , ["show"]) - ] +commands :: Directive -> [String] +commands Help = ["?", "help"] +commands Quit = ["quit"] +commands Reset = ["reset"] +commands Browse = ["browse"] +commands Load = ["load", "module"] +commands Type = ["type"] +commands Kind = ["kind"] +commands Show = ["show"] -- | --- Like directiveStrings, but the other way around. +-- Tries to parse given string into a directive. -- -directiveStrings' :: [(String, Directive)] -directiveStrings' = concatMap go directiveStrings - where - go (dir, strs) = map (\s -> (s, dir)) strs - --- | --- List of all directive strings. --- -strings :: [String] -strings = concatMap snd directiveStrings - --- | --- Returns all possible string representations of a directive. --- -stringsFor :: Directive -> [String] -stringsFor d = fromJust (lookup d directiveStrings) - --- | --- Returns the default string representation of a directive. --- -stringFor :: Directive -> String -stringFor = head . stringsFor - --- | --- Returns the list of directives which could be expanded from the string --- argument, together with the string alias that matched. --- -directivesFor' :: String -> [(Directive, String)] -directivesFor' str = go directiveStrings' - where - go = map swap . filter ((str `isPrefixOf`) . fst) - -directivesFor :: String -> [Directive] -directivesFor = map fst . directivesFor' - -directiveStringsFor :: String -> [String] -directiveStringsFor = map snd . directivesFor' - parseDirective :: String -> Maybe Directive -parseDirective = listToMaybe . directivesFor +parseDirective cmd = + case filter (matches . snd) mapping of + [directive] -> Just $ fst directive + _ -> Nothing + where + mapping :: [(Directive, [String])] + mapping = zip directives (map commands directives) --- | --- True if the given directive takes an argument, false otherwise. -hasArgument :: Directive -> Bool -hasArgument Help = False -hasArgument Quit = False -hasArgument Reset = False -hasArgument _ = True + matches :: [String] -> Bool + matches = any (cmd `isPrefixOf`) -- | -- The help menu. @@ -102,12 +63,17 @@ help :: [(Directive, String, String)] help = [ (Help, "", "Show this help menu") , (Quit, "", "Quit PSCi") - , (Reset, "", "Discard all imported modules and declared bindings") - , (Browse, "<module>", "See all functions in <module>") + , (Reset, "", "Reset") + , (Browse, "<module>", "Browse <module>") , (Load, "<file>", "Load <file> for importing") , (Type, "<expr>", "Show the type of <expr>") , (Kind, "<type>", "Show the kind of <type>") - , (Show, "import", "Show all imported modules") - , (Show, "loaded", "Show all loaded modules") + , (Show, "import", "Show imported modules") + , (Show, "loaded", "Show loaded modules") ] +-- | +-- List of all avaliable directives. +-- +directives :: [Directive] +directives = nub . map (\(dir, _, _) -> dir) $ help diff --git a/psci/PSCi.hs b/psci/Main.hs index 1f611a8..5969d70 100644 --- a/psci/PSCi.hs +++ b/psci/Main.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- --- Module : PSCi +-- Module : Main -- Copyright : (c) Phil Freeman 2013 -- License : MIT -- @@ -19,18 +19,18 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} -module PSCi where +module Main where import Data.Foldable (traverse_) -import Data.List (intercalate, nub, sort) +import Data.List (intercalate, isPrefixOf, nub, sortBy, sort) +import Data.Maybe (mapMaybe) import Data.Traversable (traverse) import Data.Version (showVersion) +import Data.Char (isSpace) import qualified Data.Map as M import Control.Applicative import Control.Monad -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Error.Class (throwError) import Control.Monad.Except (ExceptT(..), MonadError, runExceptT) import Control.Monad.Reader (MonadReader, ReaderT, runReaderT) import Control.Monad.Trans.Class @@ -50,21 +50,70 @@ import System.Process (readProcessWithExitCode) import qualified Text.Parsec as Par (ParseError) import qualified Language.PureScript as P +import qualified Language.PureScript.AST as D import qualified Language.PureScript.Names as N import qualified Paths_purescript as Paths +import qualified Commands as C import qualified Directive as D -import Parser (parseCommand) -import Completion (completion) -import Types +import Parser +data PSCiOptions = PSCiOptions + { psciMultiLineMode :: Bool + , psciInputFile :: [FilePath] + , psciInputNodeFlags :: [String] + } + +-- | +-- The PSCI state. +-- Holds a list of imported modules, loaded files, and partial let bindings. +-- The let bindings are partial, +-- because it makes more sense to apply the binding to the final evaluated expression. +-- +data PSCiState = PSCiState + { psciImportedFilenames :: [FilePath] + , psciImportedModules :: [C.ImportedModule] + , psciLoadedModules :: [(Either P.RebuildPolicy FilePath, P.Module)] + , psciLetBindings :: [P.Declaration] + , psciNodeFlags :: [String] + } + +psciImportedModuleNames :: PSCiState -> [P.ModuleName] +psciImportedModuleNames (PSCiState{psciImportedModules = is}) = + map (\(mn, _, _) -> mn) is + +-- State helpers + +-- | +-- Updates the state to have more imported modules. +-- +updateImportedFiles :: FilePath -> PSCiState -> PSCiState +updateImportedFiles filename st = st { psciImportedFilenames = filename : psciImportedFilenames st } + +-- | +-- Updates the state to have more imported modules. +-- +updateImportedModules :: C.ImportedModule -> PSCiState -> PSCiState +updateImportedModules im st = st { psciImportedModules = im : psciImportedModules st } + +-- | +-- Updates the state to have more loaded files. +-- +updateModules :: [(Either P.RebuildPolicy FilePath, P.Module)] -> PSCiState -> PSCiState +updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modules } + +-- | +-- Updates the state to have more let bindings. +-- +updateLets :: [P.Declaration] -> PSCiState -> PSCiState +updateLets ds st = st { psciLetBindings = psciLetBindings st ++ ds } -- File helpers -- | -- Load the necessary modules. -- -defaultImports :: [ImportedModule] -defaultImports = [(P.ModuleName [P.ProperName "Prelude"], P.Implicit, Nothing)] +defaultImports :: [C.ImportedModule] +defaultImports = [(P.ModuleName [P.ProperName "Prelude"], D.Implicit, Nothing)] -- | -- Locates the node executable. @@ -126,24 +175,17 @@ expandTilde p = return p -- helpMessage :: String helpMessage = "The following commands are available:\n\n " ++ - intercalate "\n " (map line D.help) ++ - "\n\n" ++ extraHelp + intercalate "\n " (map line D.help) where - line :: (Directive, String, String) -> String - line (dir, arg, desc) = - let cmd = ':' : D.stringFor dir - in intercalate " " - [ cmd - , replicate (11 - length cmd) ' ' - , arg - , replicate (11 - length arg) ' ' - , desc - ] - - extraHelp = - "Further information is available on the PureScript wiki:\n" ++ - " --> https://github.com/purescript/purescript/wiki/psci" - + line :: (D.Directive, String, String) -> String + line (dir, arg, desc) = intercalate " " + [ cmd + , replicate (11 - length cmd) ' ' + , arg + , replicate (11 - length arg) ' ' + , desc + ] + where cmd = ":" ++ head (D.commands dir) -- | -- The welcome prologue. @@ -166,6 +208,129 @@ prologueMessage = intercalate "\n" quitMessage :: String quitMessage = "See ya!" +-- Haskeline completions + +data CompletionContext = Command String | FilePath String | Module | Identifier + | Type | Fixed [String] | Multiple [CompletionContext] + deriving (Show) + +-- | +-- Decide what kind of completion we need based on input. +completionContext :: String -> String -> Maybe CompletionContext +completionContext cmd@"" _ = Just $ Multiple [Command cmd, Identifier] +completionContext (':' : cmd) word = + case D.parseDirective dstr of + Just directive | dstr `elem` D.commands directive -> context directive + _ -> Just $ Command cmd + where + dstr :: String + dstr = takeWhile (not . isSpace) cmd + + context :: D.Directive -> Maybe CompletionContext + context D.Browse = Just Module + context D.Load = Just $ FilePath word + context D.Quit = Nothing + context D.Reset = Nothing + context D.Help = Nothing + context D.Show = Just $ Fixed ["import", "loaded"] + context D.Type = Just Identifier + context D.Kind = Just Type +completionContext _ _ = Just Identifier + +-- | +-- Loads module, function, and file completions. +-- +completion :: CompletionFunc (StateT PSCiState IO) +completion = completeWordWithPrev Nothing " \t\n\r" findCompletions + where + findCompletions :: String -> String -> StateT PSCiState IO [Completion] + findCompletions prev word = do + let ctx = completionContext ((dropWhile isSpace (reverse prev)) ++ word) word + completions <- case ctx of + Nothing -> return [] + (Just c) -> (mapMaybe $ either (\cand -> if word `isPrefixOf` cand + then Just $ simpleCompletion cand + else Nothing) Just) + <$> getCompletion c + return $ sortBy sorter completions + + getCompletion :: CompletionContext -> StateT PSCiState IO [Either String Completion] + getCompletion (FilePath f) = (map Right) <$> listFiles f + getCompletion Module = (map Left) <$> getModuleNames + getCompletion Identifier = (map Left) <$> ((++) <$> getIdentNames <*> getDctorNames) + getCompletion Type = (map Left) <$> getTypeNames + getCompletion (Fixed list) = return $ (map Left) list + getCompletion (Multiple contexts) = concat <$> mapM getCompletion contexts + getCompletion (Command cmd) = return . map (Left . (":" ++)) . nub $ matching + where + matching :: [String] + matching = filter (isPrefixOf cmd) . concatMap (D.commands) $ D.directives + + getLoadedModules :: StateT PSCiState IO [P.Module] + getLoadedModules = map snd . psciLoadedModules <$> get + + getModuleNames :: StateT PSCiState IO [String] + getModuleNames = moduleNames <$> getLoadedModules + + mapLoadedModulesAndQualify :: (Show a) => (P.Module -> [a]) -> StateT PSCiState IO [String] + mapLoadedModulesAndQualify f = do + ms <- getLoadedModules + q <- sequence [qualifyIfNeeded m (f m) | m <- ms] + return $ concat q + + getIdentNames :: StateT PSCiState IO [String] + getIdentNames = mapLoadedModulesAndQualify identNames + + getDctorNames :: StateT PSCiState IO [String] + getDctorNames = mapLoadedModulesAndQualify dctorNames + + getTypeNames :: StateT PSCiState IO [String] + getTypeNames = mapLoadedModulesAndQualify typeDecls + + qualifyIfNeeded :: (Show a) => P.Module -> [a] -> StateT PSCiState IO [String] + qualifyIfNeeded m decls = do + let name = P.getModuleName m + imported <- psciImportedModuleNames <$> get + let qualified = map (P.Qualified $ Just name) decls + if name `elem` imported then + return $ map show $ qualified ++ (map (P.Qualified Nothing) decls) + else + return $ map show qualified + + typeDecls :: P.Module -> [N.ProperName] + typeDecls m = mapMaybe getTypeName $ filter P.isDataDecl (P.exportedDeclarations m) + where getTypeName :: P.Declaration -> Maybe N.ProperName + getTypeName (P.TypeSynonymDeclaration name _ _) = Just name + getTypeName (P.DataDeclaration _ name _ _) = Just name + getTypeName (P.PositionedDeclaration _ _ d) = getTypeName d + getTypeName _ = Nothing + + identNames :: P.Module -> [N.Ident] + identNames (P.Module _ _ ds exports) = nub [ ident | ident <- mapMaybe (getDeclName exports) (D.flattenDecls ds) ] + where getDeclName :: Maybe [P.DeclarationRef] -> P.Declaration -> Maybe P.Ident + getDeclName exts decl@(P.ValueDeclaration ident _ _ _) | P.isExported exts decl = Just ident + getDeclName exts decl@(P.ExternDeclaration _ ident _ _) | P.isExported exts decl = Just ident + getDeclName exts (P.PositionedDeclaration _ _ d) = getDeclName exts d + getDeclName _ _ = Nothing + + dctorNames :: P.Module -> [N.ProperName] + dctorNames m = nub $ concat $ map (P.exportedDctors m) dnames + where getDataDeclName :: P.Declaration -> Maybe N.ProperName + getDataDeclName (P.DataDeclaration _ name _ _) = Just name + getDataDeclName (P.PositionedDeclaration _ _ d) = getDataDeclName d + getDataDeclName _ = Nothing + + dnames :: [N.ProperName] + dnames = (mapMaybe getDataDeclName onlyDataDecls) + + onlyDataDecls :: [P.Declaration] + onlyDataDecls = (filter P.isDataDecl (P.exportedDeclarations m)) + + moduleNames :: [P.Module] -> [String] + moduleNames ms = nub [show moduleName | P.Module _ moduleName _ _ <- ms] + + sorter :: Completion -> Completion -> Ordering + sorter (Completion _ d1 _) (Completion _ d2 _) = if ":" `isPrefixOf` d1 then LT else compare d1 d2 -- Compilation @@ -182,26 +347,24 @@ newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Fu psciIO :: IO a -> PSCI a psciIO io = PSCI . lift $ lift io -newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ExceptT P.MultipleErrors IO) a } - deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadReader (P.Options P.Make)) +newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ExceptT String IO) a } + deriving (Functor, Applicative, Monad, MonadError String, MonadReader (P.Options P.Make)) -runMake :: Make a -> IO (Either P.MultipleErrors a) +runMake :: Make a -> IO (Either String a) runMake = runExceptT . flip runReaderT options . unMake -makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a -makeIO f io = do - e <- liftIO $ tryIOError io - either (throwError . P.errorMessage . f) return e +makeIO :: IO a -> Make a +makeIO = Make . lift . ExceptT . fmap (either (Left . show) Right) . tryIOError instance P.MonadMake Make where - getTimestamp path = makeIO (const (P.CannotGetFileInfo path)) $ do + getTimestamp path = makeIO $ do exists <- doesFileExist path traverse (const $ getModificationTime path) $ guard exists - readTextFile path = makeIO (const (P.CannotReadFile path)) $ readFile path - writeTextFile path text = makeIO (const (P.CannotWriteFile path)) $ do + readTextFile path = makeIO $ readFile path + writeTextFile path text = makeIO $ do mkdirp path writeFile path text - progress s = unless (s == "Compiling $PSCI") $ liftIO . putStrLn $ s + progress s = unless (s == "Compiling $PSCI") $ makeIO . putStrLn $ s mkdirp :: FilePath -> IO () mkdirp = createDirectoryIfMissing True . takeDirectory @@ -244,7 +407,7 @@ createTemporaryModuleForImports PSCiState{psciImportedModules = imports} = in P.Module [] moduleName (importDecl `map` imports) Nothing -importDecl :: ImportedModule -> P.Declaration +importDecl :: C.ImportedModule -> P.Declaration importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ modulesDir :: FilePath @@ -263,7 +426,7 @@ handleDeclaration val = do let nodeArgs = psciNodeFlags st ++ [indexFile] e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) [] case e of - Left errs -> printErrors errs + Left err -> PSCI $ outputStrLn err Right _ -> do psciIO $ writeFile indexFile "require('$PSCI').main();" process <- psciIO findNodeProcess @@ -284,7 +447,7 @@ handleDecls ds = do let m = createTemporaryModule False st' (P.ObjectLiteral []) e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st' ++ [(Left P.RebuildAlways, m)]) [] case e of - Left err -> printErrors err + Left err -> PSCI $ outputStrLn err Right _ -> PSCI $ lift (put st') -- | @@ -296,7 +459,7 @@ handleShowLoadedModules = do psciIO $ readModules loadedModules >>= putStrLn return () where readModules = return . unlines . sort . nub . map toModuleName - toModuleName = N.runModuleName . (\ (P.Module _ mdName _ _) -> mdName) . snd + toModuleName = N.runModuleName . (\ (D.Module _ mdName _ _) -> mdName) . snd -- | -- Show the imported modules in psci. @@ -313,17 +476,17 @@ handleShowImportedModules = do Just mn' -> "qualified " ++ N.runModuleName mn ++ " as " ++ N.runModuleName mn' Nothing -> N.runModuleName mn ++ " " ++ showDeclType declType - showDeclType P.Implicit = "" - showDeclType (P.Explicit refs) = refsList refs - showDeclType (P.Hiding refs) = "hiding " ++ refsList refs + showDeclType D.Implicit = "" + showDeclType (D.Explicit refs) = refsList refs + showDeclType (D.Hiding refs) = "hiding " ++ refsList refs refsList refs = "(" ++ commaList (map showRef refs) ++ ")" showRef :: P.DeclarationRef -> String - showRef (P.TypeRef pn dctors) = show pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")" - showRef (P.ValueRef ident) = show ident - showRef (P.TypeClassRef pn) = show pn - showRef (P.TypeInstanceRef ident) = show ident - showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref + showRef (D.TypeRef pn dctors) = show pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")" + showRef (D.ValueRef ident) = show ident + showRef (D.TypeClassRef pn) = show pn + showRef (D.TypeInstanceRef ident) = show ident + showRef (D.PositionedDeclarationRef _ _ ref) = showRef ref commaList :: [String] -> String commaList = intercalate ", " @@ -331,13 +494,13 @@ handleShowImportedModules = do -- | -- Imports a module, preserving the initial state on failure. -- -handleImport :: ImportedModule -> PSCI () +handleImport :: C.ImportedModule -> PSCI () handleImport im = do st <- updateImportedModules im <$> PSCI (lift get) let m = createTemporaryModuleForImports st e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) [] case e of - Left errs -> printErrors errs + Left err -> PSCI $ outputStrLn err Right _ -> do PSCI $ lift $ put st return () @@ -351,7 +514,7 @@ handleTypeOf val = do let m = createTemporaryModule False st val e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) [] case e of - Left errs -> printErrors errs + Left err -> PSCI $ outputStrLn err Right env' -> case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty @@ -385,16 +548,12 @@ handleBrowse moduleName = do let loadedModules = psciLoadedModules st env <- psciIO . runMake $ P.make modulesDir loadedModules [] case env of - Left errs -> printErrors errs + 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' --- | Pretty-print errors -printErrors :: P.MultipleErrors -> PSCI () -printErrors = PSCI . outputStrLn . P.prettyPrintMultipleErrors False - -- | -- Takes a value and prints its kind -- @@ -405,7 +564,7 @@ handleKindOf typ = do mName = P.ModuleName [P.ProperName "$PSCI"] e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) [] case e of - Left errs -> printErrors errs + Left err -> PSCI $ outputStrLn err Right env' -> case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of Just (_, typ') -> do @@ -419,9 +578,9 @@ handleKindOf typ = do -- Commands -- | --- Parses the input and returns either a Metacommand, or an error as a string. +-- Parses the input and returns either a Metacommand or an expression. -- -getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command)) +getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe C.Command)) getCommand singleLineMode = do firstLine <- getInputLine "> " case firstLine of @@ -434,14 +593,14 @@ getCommand singleLineMode = do go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " " -- | --- Performs an action for each meta-command given, and also for expressions. +-- Performs an action for each meta-command given, and also for expressions.. -- -handleCommand :: Command -> PSCI () -handleCommand (Expression val) = handleDeclaration val -handleCommand ShowHelp = PSCI $ outputStrLn helpMessage -handleCommand (Import im) = handleImport im -handleCommand (Decls l) = handleDecls l -handleCommand (LoadFile filePath) = do +handleCommand :: C.Command -> PSCI () +handleCommand (C.Expression val) = handleDeclaration val +handleCommand C.Help = PSCI $ outputStrLn helpMessage +handleCommand (C.Import im) = handleImport im +handleCommand (C.Decls l) = handleDecls l +handleCommand (C.LoadFile filePath) = do absPath <- psciIO $ expandTilde filePath exists <- psciIO $ doesFileExist absPath if exists then do @@ -452,7 +611,7 @@ handleCommand (LoadFile filePath) = do Right mods -> PSCI . lift $ modify (updateModules (map ((,) (Right absPath)) mods)) else PSCI . outputStrLn $ "Couldn't locate: " ++ filePath -handleCommand ResetState = do +handleCommand C.Reset = do files <- psciImportedFilenames <$> PSCI (lift get) PSCI . lift . modify $ \st -> st { psciImportedFilenames = files @@ -460,14 +619,14 @@ handleCommand ResetState = do , psciLetBindings = [] } loadAllImportedModules -handleCommand (TypeOf val) = handleTypeOf val -handleCommand (KindOf typ) = handleKindOf typ -handleCommand (BrowseModule moduleName) = handleBrowse moduleName -handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules -handleCommand (ShowInfo QueryImport) = handleShowImportedModules -handleCommand QuitPSCi = error "`handleCommand QuitPSCi` was called. This is a bug." - -loadUserConfig :: IO (Maybe [Command]) +handleCommand (C.TypeOf val) = handleTypeOf val +handleCommand (C.KindOf typ) = handleKindOf typ +handleCommand (C.Browse moduleName) = handleBrowse moduleName +handleCommand (C.Show "loaded") = handleShowLoadedModules +handleCommand (C.Show "import") = handleShowImportedModules +handleCommand _ = PSCI $ outputStrLn "Unknown command" + +loadUserConfig :: IO (Maybe [C.Command]) loadUserConfig = do configFile <- (</> ".psci") <$> getCurrentDirectory exists <- doesFileExist configFile @@ -503,7 +662,7 @@ loop PSCiOptions{..} = do case c of Left err -> outputStrLn err >> go Right Nothing -> go - Right (Just QuitPSCi) -> outputStrLn quitMessage + Right (Just C.Quit) -> outputStrLn quitMessage Right (Just c') -> runPSCI (loadAllImportedModules >> handleCommand c') >> go multiLineMode :: Parser Bool @@ -531,8 +690,8 @@ psciOptions = PSCiOptions <$> multiLineMode <*> many inputFile <*> nodeFlagsFlag -runPSCi :: IO () -runPSCi = execParser opts >>= loop +main :: IO () +main = execParser opts >>= loop where opts = info (version <*> helper <*> psciOptions) infoModList infoModList = fullDesc <> headerInfo <> footerInfo diff --git a/psci/Parser.hs b/psci/Parser.hs index 05eda11..d28cc7b 100644 --- a/psci/Parser.hs +++ b/psci/Parser.hs @@ -19,23 +19,22 @@ module Parser import Prelude hiding (lex) +import qualified Commands as C +import qualified Directive as D + import Data.Char (isSpace) -import Data.List (intercalate) import Control.Applicative hiding (many) import Text.Parsec hiding ((<|>)) import qualified Language.PureScript as P -import Language.PureScript.Parser.Common (mark, same) - -import qualified Directive as D -import Types +import qualified Language.PureScript.Parser.Common as C (mark, same) -- | -- Parses PSCI metacommands or expressions input from the user. -- -parseCommand :: String -> Either String Command +parseCommand :: String -> Either String C.Command parseCommand cmdString = case cmdString of (':' : cmd) -> parseDirective cmd @@ -46,7 +45,7 @@ parseRest p s = either (Left . show) Right $ do ts <- P.lex "" s P.runTokenParser "" (p <* eof) ts -psciCommand :: P.TokenParser Command +psciCommand :: P.TokenParser C.Command psciCommand = choice (map try parsers) where parsers = @@ -65,31 +64,25 @@ trimStart = dropWhile isSpace trimEnd :: String -> String trimEnd = reverse . trimStart . reverse -parseDirective :: String -> Either String Command +parseDirective :: String -> Either String C.Command parseDirective cmd = - case D.directivesFor' dstr of - [(d, _)] -> commandFor d - [] -> Left "Unrecognized directive. Type :? for help." - ds -> Left ("Ambiguous directive. Possible matches: " ++ - intercalate ", " (map snd ds) ++ ". Type :? for help.") - where - (dstr, arg) = break isSpace cmd - - commandFor d = case d of - Help -> return ShowHelp - Quit -> return QuitPSCi - Reset -> return ResetState - Browse -> BrowseModule <$> parseRest P.moduleName arg - Load -> return $ LoadFile (trim arg) - Show -> ShowInfo <$> parseReplQuery' (trim arg) - Type -> TypeOf <$> parseRest P.parseValue arg - Kind -> KindOf <$> parseRest P.parseType arg + case D.parseDirective dstr of + Just D.Help -> return C.Help + Just D.Quit -> return C.Quit + Just D.Reset -> return C.Reset + Just D.Browse -> C.Browse <$> parseRest P.moduleName arg + Just D.Load -> return $ C.LoadFile (trim arg) + Just D.Show -> return $ C.Show (trim arg) + Just D.Type -> C.TypeOf <$> parseRest P.parseValue arg + Just D.Kind -> C.KindOf <$> parseRest P.parseType arg + Nothing -> Left $ "Unrecognized command. Type :? for help." + where (dstr, arg) = break isSpace cmd -- | -- Parses expressions entered at the PSCI repl. -- -psciExpression :: P.TokenParser Command -psciExpression = Expression <$> P.parseValue +psciExpression :: P.TokenParser C.Command +psciExpression = C.Expression <$> P.parseValue -- | -- PSCI version of @let@. @@ -97,21 +90,21 @@ psciExpression = Expression <$> P.parseValue -- However, since we don't support the @Eff@ monad, -- we actually want the normal @let@. -- -psciLet :: P.TokenParser Command -psciLet = Decls <$> (P.reserved "let" *> P.indented *> manyDecls) +psciLet :: P.TokenParser C.Command +psciLet = C.Decls <$> (P.reserved "let" *> P.indented *> manyDecls) where manyDecls :: P.TokenParser [P.Declaration] - manyDecls = mark (many1 (same *> P.parseLocalDeclaration)) + manyDecls = C.mark (many1 (C.same *> P.parseLocalDeclaration)) -- | Imports must be handled separately from other declarations, so that -- :show import works, for example. -psciImport :: P.TokenParser Command -psciImport = Import <$> P.parseImportDeclaration' +psciImport :: P.TokenParser C.Command +psciImport = C.Import <$> P.parseImportDeclaration' -- | Any other declaration that we don't need a 'special case' parser for -- (like let or import declarations). -psciOtherDeclaration :: P.TokenParser Command -psciOtherDeclaration = Decls . (:[]) <$> do +psciOtherDeclaration :: P.TokenParser C.Command +psciOtherDeclaration = C.Decls . (:[]) <$> do decl <- discardPositionInfo <$> P.parseDeclaration if acceptable decl then return decl @@ -130,10 +123,3 @@ acceptable (P.ExternInstanceDeclaration _ _ _ _) = True acceptable (P.TypeClassDeclaration _ _ _ _) = True acceptable (P.TypeInstanceDeclaration _ _ _ _ _) = True acceptable _ = False - -parseReplQuery' :: String -> Either String ReplQuery -parseReplQuery' str = - case parseReplQuery str of - Nothing -> Left ("Don't know how to show " ++ str ++ ". Try one of: " ++ - intercalate ", " replQueryStrings ++ ".") - Just query -> Right query diff --git a/psci/Types.hs b/psci/Types.hs deleted file mode 100644 index bc683c2..0000000 --- a/psci/Types.hs +++ /dev/null @@ -1,167 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Types --- Copyright : (c) Phil Freeman 2014 --- License : MIT --- --- Maintainer : Phil Freeman <paf31@cantab.net> --- Stability : experimental --- Portability : --- --- | --- Type declarations and associated basic functions for PSCI. --- ------------------------------------------------------------------------------ - -module Types where - -import qualified Language.PureScript as P - -data PSCiOptions = PSCiOptions - { psciMultiLineMode :: Bool - , psciInputFile :: [FilePath] - , psciInputNodeFlags :: [String] - } - --- | --- The PSCI state. --- Holds a list of imported modules, loaded files, and partial let bindings. --- The let bindings are partial, --- because it makes more sense to apply the binding to the final evaluated expression. --- -data PSCiState = PSCiState - { psciImportedFilenames :: [FilePath] - , psciImportedModules :: [ImportedModule] - , psciLoadedModules :: [(Either P.RebuildPolicy FilePath, P.Module)] - , psciLetBindings :: [P.Declaration] - , psciNodeFlags :: [String] - } - --- | All of the data that is contained by an ImportDeclaration in the AST. --- That is: --- --- * A module name, the name of the module which is being imported --- * An ImportDeclarationType which specifies whether there is an explicit --- import list, a hiding list, or neither. --- * If the module is imported qualified, its qualified name in the importing --- module. Otherwise, Nothing. --- -type ImportedModule = (P.ModuleName, P.ImportDeclarationType, Maybe P.ModuleName) - -psciImportedModuleNames :: PSCiState -> [P.ModuleName] -psciImportedModuleNames (PSCiState{psciImportedModules = is}) = - map (\(mn, _, _) -> mn) is - -allImportsOf :: P.Module -> PSCiState -> [ImportedModule] -allImportsOf m (PSCiState{psciImportedModules = is}) = - filter isImportOfThis is - where - name = P.getModuleName m - isImportOfThis (name', _, _) = name == name' - --- State helpers - --- | --- Updates the state to have more imported modules. --- -updateImportedFiles :: FilePath -> PSCiState -> PSCiState -updateImportedFiles filename st = st { psciImportedFilenames = filename : psciImportedFilenames st } - --- | --- Updates the state to have more imported modules. --- -updateImportedModules :: ImportedModule -> PSCiState -> PSCiState -updateImportedModules im st = st { psciImportedModules = im : psciImportedModules st } - --- | --- Updates the state to have more loaded files. --- -updateModules :: [(Either P.RebuildPolicy FilePath, P.Module)] -> PSCiState -> PSCiState -updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modules } - --- | --- Updates the state to have more let bindings. --- -updateLets :: [P.Declaration] -> PSCiState -> PSCiState -updateLets ds st = st { psciLetBindings = psciLetBindings st ++ ds } - --- | --- Valid Meta-commands for PSCI --- -data Command - -- | - -- A purescript expression - -- - = Expression P.Expr - -- | - -- Show the help (ie, list of directives) - -- - | ShowHelp - -- | - -- Import a module from a loaded file - -- - | Import ImportedModule - -- | - -- Browse a module - -- - | BrowseModule P.ModuleName - -- | - -- Load a file for use with importing - -- - | LoadFile FilePath - -- | - -- Exit PSCI - -- - | QuitPSCi - -- | - -- Reset the state of the REPL - -- - | ResetState - -- | - -- Add some declarations to the current evaluation context. - -- - | Decls [P.Declaration] - -- | - -- Find the type of an expression - -- - | TypeOf P.Expr - -- | - -- Find the kind of an expression - -- - | KindOf P.Type - -- | - -- Shows information about the current state of the REPL - -- - | ShowInfo ReplQuery - -data ReplQuery - = QueryLoaded - | QueryImport - deriving (Eq, Show) - --- | A list of all ReplQuery values. -replQueries :: [ReplQuery] -replQueries = [QueryLoaded, QueryImport] - -replQueryStrings :: [String] -replQueryStrings = map showReplQuery replQueries - -showReplQuery :: ReplQuery -> String -showReplQuery QueryLoaded = "loaded" -showReplQuery QueryImport = "import" - -parseReplQuery :: String -> Maybe ReplQuery -parseReplQuery "loaded" = Just QueryLoaded -parseReplQuery "import" = Just QueryImport -parseReplQuery _ = Nothing - -data Directive - = Help - | Quit - | Reset - | Browse - | Load - | Type - | Kind - | Show - deriving (Eq, Show) diff --git a/psci/main/Main.hs b/psci/main/Main.hs deleted file mode 100644 index e430648..0000000 --- a/psci/main/Main.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main where - -import PSCi - -main :: IO () -main = runPSCi diff --git a/psci/tests/Main.hs b/psci/tests/Main.hs deleted file mode 100644 index a703ca2..0000000 --- a/psci/tests/Main.hs +++ /dev/null @@ -1,137 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - -module Main where - -import Control.Monad.Trans.State.Strict (runStateT) -import Control.Monad (when) - -import System.Exit (exitFailure) -import System.Console.Haskeline - -import Test.HUnit - -import qualified Language.PureScript as P - -import PSCi -import Completion -import Types - -main :: IO () -main = do - Counts{..} <- runTestTT allTests - when (errors + failures > 0) exitFailure - -allTests :: Test -allTests = completionTests - -completionTests :: Test -completionTests = - TestLabel "completionTests" - (TestList (map (TestCase . assertCompletedOk) completionTestData)) - --- If the cursor is at the right end of the line, with the 1st element of the --- pair as the text in the line, then pressing tab should offer all the --- elements of the list (which is the 2nd element) as completions. -completionTestData :: [(String, [String])] -completionTestData = - -- basic directives - [ (":h", [":help"]) - , (":re", [":reset"]) - , (":q", [":quit"]) - , (":mo", [":module"]) - , (":b", [":browse"]) - - -- :browse should complete modules - , (":b Prel", [":b Prelude", ":b Prelude.Unsafe"]) - , (":b Prelude.", [":b Prelude.Unsafe"]) - - -- :load, :module should complete file paths - , (":l psci/tests/data/", [":l psci/tests/data/Sample.purs"]) - , (":module psci/tests/data/", [":module psci/tests/data/Sample.purs"]) - - -- :quit, :help, :reset should not complete - , (":help ", []) - , (":quit ", []) - , (":reset ", []) - - -- :show should complete to "loaded" and "import" - , (":show ", [":show import", ":show loaded"]) - , (":show a", []) - - -- :type should complete values and data constructors in scope - , (":type Prelude.Unsafe.un", [":type Prelude.Unsafe.unsafeIndex"]) - , (":type un", [":type unit"]) - , (":type E", [":type EQ"]) - - -- :kind should complete types in scope - , (":kind C", [":kind Control.Monad.Eff.Pure"]) - , (":kind O", [":kind Ordering"]) - - -- Only one argument for directives should be completed - , (":show import ", []) - , (":type EQ ", []) - , (":kind Ordering ", []) - - -- import should complete module names - , ("import Control.Monad.S", ["import Control.Monad.ST"]) - , ("import qualified Control.Monad.S", ["import qualified Control.Monad.ST"]) - , ("import Control.Monad.", map ("import Control.Monad." ++) - ["Eff", "Eff.Unsafe", "ST"]) - - -- a few other import tests - , ("impor", ["import"]) - , ("import q", ["import qualified"]) - , ("import ", map ("import " ++) allModuleNames ++ ["import qualified"]) - , ("import Prelude.Unsafe ", []) - - -- String and number literals should not be completed - , ("\"hi", []) - , ("34", []) - - -- Identifiers and data constructors should be completed - , ("un", ["unit"]) - , ("Debug.Trace.", map ("Debug.Trace." ++) ["print", "trace"]) - , ("G", ["GT"]) - , ("Prelude.L", ["Prelude.LT"]) - - -- if a module is imported qualified, values should complete under the - -- qualified name, as well as the original name. - , ("ST.new", ["ST.newSTRef"]) - , ("Control.Monad.ST.new", ["Control.Monad.ST.newSTRef"]) - ] - where - allModuleNames = [ "Control.Monad.Eff" - , "Control.Monad.Eff.Unsafe" - , "Control.Monad.ST" - , "Data.Function" - , "Debug.Trace" - , "Prelude" - , "Prelude.Unsafe" - ] - -assertCompletedOk :: (String, [String]) -> Assertion -assertCompletedOk (line, expecteds) = do - (unusedR, completions) <- runCM (completion' (reverse line, "")) - let unused = reverse unusedR - let actuals = map ((unused ++) . replacement) completions - expecteds @=? actuals - -runCM :: CompletionM a -> IO a -runCM act = do - psciState <- getPSCiState - fmap fst (runStateT (liftCompletionM act) psciState) - -getPSCiState :: IO PSCiState -getPSCiState = do - modulesOrFirstError <- loadAllModules [] - case modulesOrFirstError of - Left err -> - print err >> exitFailure - Right modules -> - let imports = controlMonadSTasST : defaultImports - in return (PSCiState [] imports modules [] []) - -controlMonadSTasST :: ImportedModule -controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST")) - where - s = P.moduleNameFromString diff --git a/purescript.cabal b/purescript.cabal index 09c44d4..3de7978 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.6.9.4 +version: 0.6.9.5 cabal-version: >=1.8 build-type: Simple license: MIT @@ -148,12 +148,10 @@ executable psci main-is: Main.hs buildable: True - hs-source-dirs: psci psci/main - other-modules: Types + hs-source-dirs: psci + other-modules: Commands Parser Directive - Completion - PSCi ghc-options: -Wall -O2 executable psc-docs @@ -184,14 +182,3 @@ test-suite tests main-is: Main.hs buildable: True hs-source-dirs: tests - -test-suite psci-tests - build-depends: base >=4 && <5, containers -any, directory -any, filepath -any, - mtl -any, optparse-applicative >= 0.10.0, parsec -any, - haskeline >= 0.7.0.0, purescript -any, transformers -any, - process -any, HUnit -any - type: exitcode-stdio-1.0 - main-is: Main.hs - buildable: True - hs-source-dirs: psci psci/tests - ghc-options: -Wall diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs index 609f5fb..d0d293f 100644 --- a/src/Language/PureScript.hs +++ b/src/Language/PureScript.hs @@ -89,20 +89,20 @@ import qualified Paths_purescript as Paths -- -- * Pretty-print the generated Javascript -- -compile :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadReader (Options Compile) m) +compile :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m) => [Module] -> [String] -> m (String, String, Environment) compile = compile' initEnvironment -compile' :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadReader (Options Compile) m) +compile' :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m) => Environment -> [Module] -> [String] -> m (String, String, Environment) compile' env ms prefix = do noPrelude <- asks optionsNoPrelude additional <- asks optionsAdditional mainModuleIdent <- asks (fmap moduleNameFromString . optionsMain) (sorted, _) <- sortModules $ map importPrim $ if noPrelude then ms else map importPrelude ms - (desugared, nextVar) <- runSupplyT 0 $ desugar sorted + (desugared, nextVar) <- interpretMultipleErrors True $ runSupplyT 0 $ desugar sorted (elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent - regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated + regrouped <- interpretMultipleErrors True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated let corefn = map (CoreFn.moduleToCoreFn env') regrouped let entryPoints = moduleNameFromString `map` entryPointModules additional let elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn @@ -115,21 +115,21 @@ compile' env ms prefix = do let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js'] return (pjs, exts, env') -generateMain :: (MonadError MultipleErrors m, MonadReader (Options Compile) m) => Environment -> [JS] -> m [JS] +generateMain :: (MonadError String m, MonadReader (Options Compile) m) => Environment -> [JS] -> m [JS] generateMain env js = do main <- asks optionsMain additional <- asks optionsAdditional case moduleNameFromString <$> main of Just mmi -> do when ((mmi, Ident C.main) `M.notMember` names env) $ - throwError . errorMessage $ NameIsUndefined (Ident C.main) + throwError $ show mmi ++ "." ++ C.main ++ " is undefined" return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (browserNamespace additional)))) []] _ -> return js -- | -- A type class which collects the IO actions we need to be able to run in "make" mode -- -class (MonadReader (P.Options P.Make) m, MonadError MultipleErrors m) => MonadMake m where +class (MonadReader (P.Options P.Make) m, MonadError String m) => MonadMake m where -- | -- Get a file timestamp -- @@ -196,7 +196,7 @@ make outputDir ms prefix = do marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted - (desugared, nextVar) <- runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked) + (desugared, nextVar) <- interpretMultipleErrors True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked) evalSupplyT nextVar $ go initEnvironment desugared @@ -216,7 +216,7 @@ make outputDir ms prefix = do (Module _ _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m - regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated + regrouped <- interpretMultipleErrors True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated let mod' = Module coms moduleName' regrouped exps let corefn = CoreFn.moduleToCoreFn env' mod' @@ -240,10 +240,10 @@ make outputDir ms prefix = do rebuildIfNecessary graph toRebuild (Module _ moduleName' _ _ : ms') = do let externsFile = outputDir </> runModuleName moduleName' </> "externs.purs" externs <- readTextFile externsFile - externsModules <- fmap (map snd) . either (throwError . errorMessage . ErrorParsingExterns) return $ P.parseModulesFromFiles id [(externsFile, externs)] + externsModules <- fmap (map snd) . either (throwError . show) return $ P.parseModulesFromFiles id [(externsFile, externs)] case externsModules of [m'@(Module _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms' - _ -> throwError . errorMessage . InvalidExternsFile $ externsFile + _ -> throwError $ "Externs file " ++ externsFile ++ " was invalid" reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName] reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ] diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 065ef0b..f857fa0 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -78,12 +78,12 @@ isDctorExported ident (Just exps) ctor = test `any` exps -- | -- Return the exported data constructors for a given type. -- -exportedDctors :: Module -> ProperName -> [(ProperName, [Type])] +exportedDctors :: Module -> ProperName -> [ProperName] exportedDctors (Module _ _ decls exps) ident = - filter (isDctorExported ident exps . fst) dctors + filter (isDctorExported ident exps) dctors where dctors = concatMap getDctors (flattenDecls decls) - getDctors (DataDeclaration _ _ _ ctors) = ctors + getDctors (DataDeclaration _ _ _ ctors) = map fst ctors getDctors (PositionedDeclaration _ _ d) = getDctors d getDctors _ = [] diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs index 454fbdb..97c3dc6 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -30,12 +30,10 @@ data SourcePos = SourcePos -- Column number -- , sourcePosColumn :: Int - } deriving (Eq, Show, D.Data, D.Typeable) + } deriving (Eq, D.Data, D.Typeable) -displaySourcePos :: SourcePos -> String -displaySourcePos sp = - "line " ++ show (sourcePosLine sp) ++ - ", column " ++ show (sourcePosColumn sp) +instance Show SourcePos where + show sp = "line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp) data SourceSpan = SourceSpan { -- | @@ -49,10 +47,7 @@ data SourceSpan = SourceSpan -- End of the span -- , spanEnd :: SourcePos - } deriving (Eq, Show, D.Data, D.Typeable) + } deriving (Eq, D.Data, D.Typeable) -displaySourceSpan :: SourceSpan -> String -displaySourceSpan sp = - spanName sp ++ " " ++ - displaySourcePos (spanStart sp) ++ " - " ++ - displaySourcePos (spanEnd sp) +instance Show SourceSpan where + show sp = spanName sp ++ " " ++ show (spanStart sp) ++ " - " ++ show (spanEnd sp) diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs index ad27785..caf7017 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -84,28 +84,10 @@ inlineValues :: JS -> JS inlineValues = everywhereOnJS convert where convert :: JS -> JS - convert (JSApp fn [dict]) | isDict semiringNumber dict && isFn fnZero fn = JSNumericLiteral (Left 0) - | isDict semiringNumber dict && isFn fnOne fn = JSNumericLiteral (Left 1) - | isDict semiringInt dict && isFn fnZero fn = JSNumericLiteral (Left 0) - | isDict semiringInt dict && isFn fnOne fn = JSNumericLiteral (Left 1) - | isDict boundedBoolean dict && isFn fnBottom fn = JSBooleanLiteral False - | isDict boundedBoolean dict && isFn fnTop fn = JSBooleanLiteral True - convert (JSApp fn [value]) | isFn fromNumber fn = JSBinary BitwiseOr value (JSNumericLiteral (Left 0)) - convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) - | isDict semiringInt dict && isFn fnAdd fn = JSBinary BitwiseOr (JSBinary Add x y) (JSNumericLiteral (Left 0)) - | isDict semiringInt dict && isFn fnMultiply fn = JSBinary BitwiseOr (JSBinary Multiply x y) (JSNumericLiteral (Left 0)) - | isDict moduloSemiringInt dict && isFn fnDivide fn = JSBinary BitwiseOr (JSBinary Divide x y) (JSNumericLiteral (Left 0)) - | isDict ringInt dict && isFn fnSubtract fn = JSBinary BitwiseOr (JSBinary Subtract x y) (JSNumericLiteral (Left 0)) + convert (JSApp fn [dict]) | isPreludeDict C.semiringNumber dict && isPreludeFn C.zero fn = JSNumericLiteral (Left 0) + convert (JSApp fn [dict]) | isPreludeDict C.semiringNumber dict && isPreludeFn C.one fn = JSNumericLiteral (Left 1) + convert (JSApp (JSApp fn [x]) [y]) | isPreludeFn (C.%) fn = JSBinary Modulus x y convert other = other - fnZero = (C.prelude, C.zero) - fnOne = (C.prelude, C.one) - fnBottom = (C.prelude, C.bottom) - fnTop = (C.prelude, C.top) - fromNumber = (C.dataInt, C.fromNumber) - fnAdd = (C.prelude, (C.+)) - fnDivide = (C.prelude, (C./)) - fnMultiply = (C.prelude, (C.*)) - fnSubtract = (C.prelude, (C.-)) inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS inlineOperator (m, op) f = everywhereOnJS convert @@ -119,83 +101,58 @@ inlineOperator (m, op) f = everywhereOnJS convert inlineCommonOperators :: JS -> JS inlineCommonOperators = applyAll $ - [ binary semiringNumber (C.+) Add - , binary semiringNumber (C.*) Multiply - - , binary ringNumber (C.-) Subtract - , unary ringNumber C.negate Negate - , binary ringInt (C.-) Subtract - , unary ringInt C.negate Negate - - , binary moduloSemiringNumber (C./) Divide - , binary moduloSemiringInt C.mod Modulus - - , binary eqNumber (C.==) EqualTo - , binary eqNumber (C./=) NotEqualTo - , binary eqInt (C.==) EqualTo - , binary eqInt (C./=) NotEqualTo - , binary eqString (C.==) EqualTo - , binary eqString (C./=) NotEqualTo - , binary eqBoolean (C.==) EqualTo - , binary eqBoolean (C./=) NotEqualTo - - , binary ordNumber (C.<) LessThan - , binary ordNumber (C.>) GreaterThan - , binary ordNumber (C.<=) LessThanOrEqualTo - , binary ordNumber (C.>=) GreaterThanOrEqualTo - , binary ordInt (C.<) LessThan - , binary ordInt (C.>) GreaterThan - , binary ordInt (C.<=) LessThanOrEqualTo - , binary ordInt (C.>=) GreaterThanOrEqualTo - - , binary semigroupString (C.<>) Add - , binary semigroupString (C.++) Add - - , binary latticeBoolean (C.&&) And - , binary latticeBoolean (C.||) Or - , binaryFunction latticeBoolean C.inf And - , binaryFunction latticeBoolean C.sup Or - , unary complementedLatticeBoolean C.not Not - - , binary' C.dataIntBits (C..|.) BitwiseOr - , binary' C.dataIntBits (C..&.) BitwiseAnd - , binary' C.dataIntBits (C..^.) BitwiseXor - , binary' C.dataIntBits C.shl ShiftLeft - , binary' C.dataIntBits C.shr ShiftRight - , binary' C.dataIntBits C.zshr ZeroFillShiftRight - , unary' C.dataIntBits C.complement BitwiseNot + [ binary C.semiringNumber (C.+) Add + , binary C.semiringNumber (C.*) Multiply + , binary C.ringNumber (C.-) Subtract + , unary C.ringNumber C.negate Negate + , binary C.moduloSemiringNumber (C./) Divide + + , binary C.ordNumber (C.<) LessThan + , binary C.ordNumber (C.>) GreaterThan + , binary C.ordNumber (C.<=) LessThanOrEqualTo + , binary C.ordNumber (C.>=) GreaterThanOrEqualTo + + , binary C.eqNumber (C.==) EqualTo + , binary C.eqNumber (C./=) NotEqualTo + , binary C.eqString (C.==) EqualTo + , binary C.eqString (C./=) NotEqualTo + , binary C.eqBoolean (C.==) EqualTo + , binary C.eqBoolean (C./=) NotEqualTo + + , binary C.semigroupString (C.<>) Add + , binary C.semigroupString (C.++) Add + + , binaryFunction C.bitsNumber C.shl ShiftLeft + , binaryFunction C.bitsNumber C.shr ShiftRight + , binaryFunction C.bitsNumber C.zshr ZeroFillShiftRight + , binary C.bitsNumber (C..&.) BitwiseAnd + , binary C.bitsNumber (C..|.) BitwiseOr + , binary C.bitsNumber (C..^.) BitwiseXor + , unary C.bitsNumber C.complement BitwiseNot + + , binary C.boolLikeBoolean (C.&&) And + , binary C.boolLikeBoolean (C.||) Or + , unary C.boolLikeBoolean C.not Not ] ++ [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] where - binary :: (String, String) -> String -> BinaryOperator -> JS -> JS - binary dict opString op = everywhereOnJS convert + binary :: String -> String -> BinaryOperator -> JS -> JS + binary dictName opString op = everywhereOnJS convert where convert :: JS -> JS - convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isDict dict dict' && isPreludeFn opString fn = JSBinary op x y + convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isPreludeDict dictName dict && isPreludeFn opString fn = JSBinary op x y convert other = other - binary' :: String -> String -> BinaryOperator -> JS -> JS - binary' moduleName opString op = everywhereOnJS convert + binaryFunction :: String -> String -> BinaryOperator -> JS -> JS + binaryFunction dictName fnName op = everywhereOnJS convert where convert :: JS -> JS - convert (JSApp (JSApp fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary op x y + convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isPreludeFn fnName fn && isPreludeDict dictName dict = JSBinary op x y convert other = other - binaryFunction :: (String, String) -> String -> BinaryOperator -> JS -> JS - binaryFunction dict fnName op = everywhereOnJS convert + unary :: String -> String -> UnaryOperator -> JS -> JS + unary dictName fnName op = everywhereOnJS convert where convert :: JS -> JS - convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isPreludeFn fnName fn && isDict dict dict' = JSBinary op x y - convert other = other - unary :: (String, String) -> String -> UnaryOperator -> JS -> JS - unary dict fnName op = everywhereOnJS convert - where - convert :: JS -> JS - convert (JSApp (JSApp fn [dict']) [x]) | isPreludeFn fnName fn && isDict dict dict' = JSUnary op x - convert other = other - unary' :: String -> String -> UnaryOperator -> JS -> JS - unary' moduleName fnName op = everywhereOnJS convert - where - convert :: JS -> JS - convert (JSApp fn [x]) | isFn (moduleName, fnName) fn = JSUnary op x + convert (JSApp (JSApp fn [dict]) [x]) | isPreludeFn fnName fn && isPreludeDict dictName dict = JSUnary op x convert other = other mkFn :: Int -> JS -> JS mkFn 0 = everywhereOnJS convert @@ -233,62 +190,12 @@ inlineCommonOperators = applyAll $ go m acc (JSApp lhs [arg]) = go (m - 1) (arg : acc) lhs go _ _ _ = Nothing -isDict :: (String, String) -> JS -> Bool -isDict (moduleName, dictName) (JSAccessor x (JSVar y)) = x == dictName && y == moduleName -isDict _ _ = False - -isFn :: (String, String) -> JS -> Bool -isFn (moduleName, fnName) (JSAccessor x (JSVar y)) = x == fnName && y == moduleName -isFn (moduleName, fnName) (JSIndexer (JSStringLiteral x) (JSVar y)) = x == fnName && y == moduleName -isFn _ _ = False +isPreludeDict :: String -> JS -> Bool +isPreludeDict dictName (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == dictName +isPreludeDict _ _ = False isPreludeFn :: String -> JS -> Bool -isPreludeFn fnName = isFn (C.prelude, fnName) - -semiringNumber :: (String, String) -semiringNumber = (C.prelude, C.semiringNumber) - -semiringInt :: (String, String) -semiringInt = (C.dataInt, C.semiringInt) - -ringNumber :: (String, String) -ringNumber = (C.prelude, C.ringNumber) - -ringInt :: (String, String) -ringInt = (C.dataInt, C.ringInt) - -moduloSemiringNumber :: (String, String) -moduloSemiringNumber = (C.prelude, C.moduloSemiringNumber) - -moduloSemiringInt :: (String, String) -moduloSemiringInt = (C.dataInt, C.moduloSemiringInt) - -eqNumber :: (String, String) -eqNumber = (C.prelude, C.eqNumber) - -eqInt :: (String, String) -eqInt = (C.dataInt, C.eqInt) - -eqString :: (String, String) -eqString = (C.prelude, C.eqNumber) - -eqBoolean :: (String, String) -eqBoolean = (C.prelude, C.eqNumber) - -ordNumber :: (String, String) -ordNumber = (C.prelude, C.ordNumber) - -ordInt :: (String, String) -ordInt = (C.dataInt, C.ordInt) - -semigroupString :: (String, String) -semigroupString = (C.prelude, C.semigroupString) - -boundedBoolean :: (String, String) -boundedBoolean = (C.prelude, C.boundedBoolean) - -latticeBoolean :: (String, String) -latticeBoolean = (C.prelude, C.latticeBoolean) - -complementedLatticeBoolean :: (String, String) -complementedLatticeBoolean = (C.prelude, C.complementedLatticeBoolean) +isPreludeFn fnName (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName' == fnName +isPreludeFn fnName (JSIndexer (JSStringLiteral fnName') (JSVar prelude)) = prelude == C.prelude && fnName' == fnName +isPreludeFn fnName (JSAccessor longForm (JSAccessor prelude (JSVar _))) = prelude == C.prelude && longForm == identToJs (Op fnName) +isPreludeFn _ _ = False diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs index eadc51f..4fc86fe 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs @@ -15,8 +15,6 @@ module Language.PureScript.CodeGen.JS.Optimizer.TCO (tco) where -import Data.Monoid - import Language.PureScript.Options import Language.PureScript.CodeGen.JS.AST @@ -32,13 +30,10 @@ tco' = everywhereOnJS convert where tcoLabel :: String tcoLabel = "tco" - tcoVar :: String -> String tcoVar arg = "__tco_" ++ arg - copyVar :: String -> String copyVar arg = "__copy_" ++ arg - convert :: JS -> JS convert js@(JSVariableIntroduction name (Just fn@JSFunction {})) = let @@ -51,7 +46,6 @@ tco' = everywhereOnJS convert JSVariableIntroduction name (Just (replace (toLoop name allArgs body'))) | otherwise -> js convert js = js - collectAllFunctionArgs :: [[String]] -> (JS -> JS) -> JS -> ([[String]], JS, JS -> JS) collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) = collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body @@ -62,35 +56,25 @@ tco' = everywhereOnJS convert collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) = (args : allArgs, body, f . JSReturn . JSFunction ident (map copyVar args)) collectAllFunctionArgs allArgs f body = (allArgs, body, f) - isTailCall :: String -> JS -> Bool isTailCall ident js = let numSelfCalls = everythingOnJS (+) countSelfCalls js numSelfCallsInTailPosition = everythingOnJS (+) countSelfCallsInTailPosition js numSelfCallsUnderFunctions = everythingOnJS (+) countSelfCallsUnderFunctions js - numSelfCallWithFnArgs = everythingOnJS (+) countSelfCallsWithFnArgs js in numSelfCalls > 0 && numSelfCalls == numSelfCallsInTailPosition && numSelfCallsUnderFunctions == 0 - && numSelfCallWithFnArgs == 0 where countSelfCalls :: JS -> Int countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1 countSelfCalls _ = 0 - countSelfCallsInTailPosition :: JS -> Int countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1 countSelfCallsInTailPosition _ = 0 - - countSelfCallsUnderFunctions :: JS -> Int countSelfCallsUnderFunctions (JSFunction _ _ js') = everythingOnJS (+) countSelfCalls js' countSelfCallsUnderFunctions _ = 0 - - countSelfCallsWithFnArgs :: JS -> Int - countSelfCallsWithFnArgs ret = if isSelfCallWithFnArgs ident ret [] then 1 else 0 - toLoop :: String -> [String] -> JS -> JS toLoop ident allArgs js = JSBlock $ map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++ @@ -110,19 +94,10 @@ tco' = everywhereOnJS convert collectSelfCallArgs :: [[JS]] -> JS -> [[JS]] collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn collectSelfCallArgs allArgumentValues _ = allArgumentValues - isSelfCall :: String -> JS -> Bool - isSelfCall ident (JSApp (JSVar ident') _) = ident == ident' - isSelfCall ident (JSApp fn _) = isSelfCall ident fn + isSelfCall ident (JSApp (JSVar ident') args) | ident == ident' && not (any isFunction args) = True + isSelfCall ident (JSApp fn args) | not (any isFunction args) = isSelfCall ident fn isSelfCall _ _ = False - - isSelfCallWithFnArgs :: String -> JS -> [JS] -> Bool - isSelfCallWithFnArgs ident (JSVar ident') args | ident == ident' && any hasFunction args = True - isSelfCallWithFnArgs ident (JSApp fn args) acc = isSelfCallWithFnArgs ident fn (args ++ acc) - isSelfCallWithFnArgs _ _ _ = False - - hasFunction :: JS -> Bool - hasFunction = getAny . everythingOnJS mappend (Any . isFunction) - where - isFunction (JSFunction _ _ _) = True - isFunction _ = False + isFunction :: JS -> Bool + isFunction (JSFunction _ _ _) = True + isFunction _ = False diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index 6978e7b..51ba984 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -15,7 +15,7 @@ module Language.PureScript.Constants where --- Operators +-- Prelude Operators ($) :: String ($) = "$" @@ -65,6 +65,15 @@ module Language.PureScript.Constants where (/=) :: String (/=) = "/=" +(.&.) :: String +(.&.) = ".&." + +(.|.) :: String +(.|.) = ".|." + +(.^.) :: String +(.^.) = ".^." + (&&) :: String (&&) = "&&" @@ -74,32 +83,11 @@ module Language.PureScript.Constants where unsafeIndex :: String unsafeIndex = "unsafeIndex" -(.|.) :: String -(.|.) = ".|." - -(.&.) :: String -(.&.) = ".&." - -(.^.) :: String -(.^.) = ".^." - --- Functions +-- Prelude Operator Functions negate :: String negate = "negate" -not :: String -not = "not" - -sup :: String -sup = "sup" - -inf :: String -inf = "inf" - -mod :: String -mod = "mod" - shl :: String shl = "shl" @@ -112,8 +100,8 @@ zshr = "zshr" complement :: String complement = "complement" -fromNumber :: String -fromNumber = "fromNumber" +not :: String +not = "not" -- Prelude Values @@ -123,12 +111,6 @@ zero = "zero" one :: String one = "one" -bottom :: String -bottom = "bottom" - -top :: String -top = "top" - return :: String return = "return" @@ -190,47 +172,32 @@ bindEffDictionary = "bindEff" semiringNumber :: String semiringNumber = "semiringNumber" -semiringInt :: String -semiringInt = "semiringInt" - ringNumber :: String ringNumber = "ringNumber" -ringInt :: String -ringInt = "ringInt" - moduloSemiringNumber :: String moduloSemiringNumber = "moduloSemiringNumber" -moduloSemiringInt :: String -moduloSemiringInt = "moduloSemiringInt" +numNumber :: String +numNumber = "numNumber" ordNumber :: String ordNumber = "ordNumber" -ordInt :: String -ordInt = "ordInt" - eqNumber :: String eqNumber = "eqNumber" -eqInt :: String -eqInt = "eqInt" - eqString :: String eqString = "eqString" eqBoolean :: String eqBoolean = "eqBoolean" -boundedBoolean :: String -boundedBoolean = "boundedBoolean" - -latticeBoolean :: String -latticeBoolean = "latticeBoolean" +bitsNumber :: String +bitsNumber = "bitsNumber" -complementedLatticeBoolean :: String -complementedLatticeBoolean = "complementedLatticeBoolean" +boolLikeBoolean :: String +boolLikeBoolean = "boolLikeBoolean" semigroupString :: String semigroupString = "semigroupString" @@ -270,9 +237,3 @@ st = "Control_Monad_ST" dataFunction :: String dataFunction = "Data_Function" - -dataInt :: String -dataInt = "Data_Int" - -dataIntBits :: String -dataIntBits = "Data_Int_Bits" diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 617e49b..07d8b19 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -36,19 +36,11 @@ import Language.PureScript.TypeClassDictionaries import qualified Text.PrettyPrint.Boxes as Box -import qualified Text.Parsec as P - -- | -- A type of error messages -- data ErrorMessage - = ErrorParsingExterns P.ParseError - | ErrorParsingPrelude P.ParseError - | InvalidExternsFile FilePath - | CannotGetFileInfo FilePath - | CannotReadFile FilePath - | CannotWriteFile FilePath - | InfiniteType Type + = InfiniteType Type | InfiniteKind Kind | CannotReorderOperators | MultipleFixities Ident @@ -78,7 +70,6 @@ data ErrorMessage | InvalidDoLet | CycleInDeclaration Ident | CycleInTypeSynonym (Maybe ProperName) - | CycleInModules [ModuleName] | NameIsUndefined Ident | NameNotInScope Ident | UndefinedTypeVariable ProperName @@ -135,12 +126,6 @@ instance UnificationError Kind ErrorMessage where -- Get the error code for a particular error type -- errorCode :: ErrorMessage -> String -errorCode (ErrorParsingExterns _) = "ErrorParsingExterns" -errorCode (ErrorParsingPrelude _) = "ErrorParsingPrelude" -errorCode (InvalidExternsFile _) = "InvalidExternsFile" -errorCode (CannotGetFileInfo _) = "CannotGetFileInfo" -errorCode (CannotReadFile _) = "CannotReadFile" -errorCode (CannotWriteFile _) = "CannotWriteFile" errorCode (InfiniteType _) = "InfiniteType" errorCode (InfiniteKind _) = "InfiniteKind" errorCode CannotReorderOperators = "CannotReorderOperators" @@ -171,7 +156,6 @@ errorCode InvalidDoBind = "InvalidDoBind" errorCode InvalidDoLet = "InvalidDoLet" errorCode (CycleInDeclaration _) = "CycleInDeclaration" errorCode (CycleInTypeSynonym _) = "CycleInTypeSynonym" -errorCode (CycleInModules _) = "CycleInModules" errorCode (NameIsUndefined _) = "NameIsUndefined" errorCode (NameNotInScope _) = "NameNotInScope" errorCode (UndefinedTypeVariable _) = "UndefinedTypeVariable" @@ -193,13 +177,13 @@ errorCode (IncorrectConstructorArity _) = "IncorrectConstructorArity" errorCode SubsumptionCheckFailed = "SubsumptionCheckFailed" errorCode (ExprDoesNotHaveType _ _) = "ExprDoesNotHaveType" errorCode (PropertyIsMissing _ _) = "PropertyIsMissing" +errorCode (ErrorUnifyingTypes _ _ _) = "ErrorUnifyingTypes" errorCode (CannotApplyFunction _ _) = "CannotApplyFunction" errorCode TypeSynonymInstance = "TypeSynonymInstance" errorCode InvalidNewtype = "InvalidNewtype" errorCode (InvalidInstanceHead _) = "InvalidInstanceHead" errorCode (TransitiveExportError _ _) = "TransitiveExportError" errorCode (NotYetDefined _ e) = errorCode e -errorCode (ErrorUnifyingTypes _ _ e) = errorCode e errorCode (ErrorInExpression _ e) = errorCode e errorCode (ErrorInModule _ e) = errorCode e errorCode (ErrorInInstance _ _ e) = errorCode e @@ -261,24 +245,6 @@ prettyPrintSingleError full e = prettyPrintErrorMessage (if full then e else sim wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e go :: ErrorMessage -> Box.Box - go (CannotGetFileInfo path) = paras [ line "Unable to read file info: " - , indent . line $ path - ] - go (CannotReadFile path) = paras [ line "Unable to read file: " - , indent . line $ path - ] - go (CannotWriteFile path) = paras [ line "Unable to write file: " - , indent . line $ path - ] - go (ErrorParsingExterns err) = paras [ line "Error parsing externs files: " - , indent . line . show $ err - ] - go (ErrorParsingPrelude err) = paras [ line "Error parsing prelude: " - , indent . line . show $ err - ] - go (InvalidExternsFile path) = paras [ line "Externs file is invalid: " - , indent . line $ path - ] go InvalidDoBind = line "Bind statement cannot be the last statement in a do block" go InvalidDoLet = line "Let statement cannot be the last statement in a do block" go CannotReorderOperators = line "Unable to reorder operators" @@ -312,7 +278,6 @@ prettyPrintSingleError full e = prettyPrintErrorMessage (if full then e else sim go (DuplicateClassExport nm) = line $ "Duplicate export declaration for type class " ++ show nm go (DuplicateValueExport nm) = line $ "Duplicate export declaration for value " ++ show nm go (CycleInDeclaration nm) = line $ "Cycle in declaration of " ++ show nm - go (CycleInModules mns) = line $ "Cycle in module dependencies: " ++ intercalate ", " (map show mns) go (NotYetDefined names err) = paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map show names) ++ ":" , indent $ go err ] @@ -439,7 +404,7 @@ prettyPrintSingleError full e = prettyPrintErrorMessage (if full then e else sim go (ErrorInForeignImport nm err) = paras [ line $ "Error in foreign import " ++ show nm ++ ":" , go err ] - go (PositionedError srcSpan err) = paras [ line $ "Error at " ++ displaySourceSpan srcSpan ++ ":" + go (PositionedError pos err) = paras [ line $ "Error at " ++ show pos ++ ":" , indent $ go err ] @@ -525,8 +490,8 @@ renderBox = unlines . map trimEnd . lines . Box.render -- | -- Interpret multiple errors in a monad supporting errors -- -interpretMultipleErrors :: (MonadError MultipleErrors m) => Either MultipleErrors a -> m a -interpretMultipleErrors = either throwError return +interpretMultipleErrors :: (MonadError String m) => Bool -> Either MultipleErrors a -> m a +interpretMultipleErrors printFullStack = either (throwError . prettyPrintMultipleErrors printFullStack) return -- | -- Rethrow an error with a more detailed error message in the case of failure diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index 177ae6c..1af1ab4 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -28,7 +28,6 @@ import Data.Maybe (mapMaybe) import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Types -import Language.PureScript.Errors -- | -- A list of modules with their dependencies @@ -40,7 +39,7 @@ type ModuleGraph = [(ModuleName, [ModuleName])] -- -- Reports an error if the module graph contains a cycle. -- -sortModules :: (MonadError MultipleErrors m) => [Module] -> m ([Module], ModuleGraph) +sortModules :: (MonadError String m) => [Module] -> m ([Module], ModuleGraph) sortModules ms = do let verts = map (\m@(Module _ _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms ms' <- mapM toModule $ stronglyConnComp verts @@ -71,7 +70,7 @@ usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues ( -- | -- Convert a strongly connected component of the module graph to a module -- -toModule :: (MonadError MultipleErrors m) => SCC Module -> m Module +toModule :: (MonadError String m) => SCC Module -> m Module toModule (AcyclicSCC m) = return m toModule (CyclicSCC [m]) = return m -toModule (CyclicSCC ms) = throwError . errorMessage $ CycleInModules (map getModuleName ms) +toModule (CyclicSCC ms) = throwError $ "Cycle in module dependencies: " ++ show (map getModuleName ms) diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index d4f8a5b..3135be1 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -126,7 +126,9 @@ parseNameAndType :: TokenParser t -> TokenParser (String, t) parseNameAndType p = (,) <$> (indented *> (lname <|> stringLiteral) <* indented <* doubleColon) <*> p parseRowEnding :: TokenParser Type -parseRowEnding = P.option REmpty $ indented *> pipe *> indented *> parseType +parseRowEnding = P.option REmpty $ indented *> pipe *> indented *> P.choice (map P.try + [ parseTypeWildcard + , TypeVar <$> identifier ]) parseRow :: TokenParser Type parseRow = (curry rowFromList <$> commaSep (parseNameAndType parsePolyType) <*> parseRowEnding) P.<?> "row" diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index 8c5efb3..b5e311b 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -157,6 +157,7 @@ getProperName _ = error "Expected DataDeclaration" -- toBindingGroup :: (Functor m, MonadError MultipleErrors m) => ModuleName -> SCC Declaration -> m Declaration toBindingGroup _ (AcyclicSCC d) = return d +toBindingGroup _ (CyclicSCC [d]) = return d toBindingGroup moduleName (CyclicSCC ds') = -- Once we have a mutually-recursive group of declarations, we need to sort -- them further by their immediate dependencies (those outside function diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index 829bb04..ce5c0bc 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -25,7 +25,7 @@ import Data.Maybe (catMaybes) import Data.List (nub, groupBy) import Control.Applicative -import Control.Monad ((<=<), forM, replicateM, join, unless) +import Control.Monad ((<=<), forM, join, unless, replicateM) import Control.Monad.Except (throwError) import Control.Monad.Error.Class (MonadError) import Control.Monad.Supply.Class @@ -130,20 +130,12 @@ makeCaseDeclaration ident alternatives = do value = foldr (Abs . Left) (Case vars binders) args return $ ValueDeclaration ident Value [] (Right value) where - -- We will construct a table of potential names. - -- VarBinders will become Just (Just _) which is a potential name. - -- NullBinder will become Just Nothing, which indicates that we may - -- have to generate a name. - -- Everything else becomes Nothing, which indicates that we definitely - --have to generate a name. findName :: Binder -> Maybe (Maybe Ident) findName NullBinder = Just Nothing findName (VarBinder name) = Just (Just name) findName (PositionedBinder _ _ binder) = findName binder findName _ = Nothing - -- We still have to make sure the generated names are unique, or else - -- we will end up constructing an invalid function. allUnique :: (Eq a) => [a] -> Bool allUnique xs = length xs == length (nub xs) @@ -153,15 +145,11 @@ makeCaseDeclaration ident alternatives = do name <- freshName return (Ident name) - -- Combine two lists of potential names from two case alternatives - -- by zipping correspoding columns. resolveNames :: [Maybe (Maybe Ident)] -> [Maybe (Maybe Ident)] -> [Maybe (Maybe Ident)] resolveNames = zipWith resolveName - -- Resolve a pair of names. VarBinder beats NullBinder, and everything - -- else results in Nothing. resolveName :: Maybe (Maybe Ident) -> Maybe (Maybe Ident) -> Maybe (Maybe Ident) diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index 966fa1d..9667655 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -44,8 +44,11 @@ desugarDo d = let (f, _, _) = everywhereOnValuesM return replace return in f d where + prelude :: ModuleName + prelude = ModuleName [ProperName C.prelude] + bind :: Expr - bind = Var (Qualified Nothing (Op (C.>>=))) + bind = Var (Qualified (Just prelude) (Op (C.>>=))) replace :: Expr -> m Expr replace (Do els) = go els diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index be5e2d7..75b9b42 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -116,7 +116,7 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt checkOverlaps :: [DictionaryValue] -> Check Expr checkOverlaps dicts = case [ (d1, d2) | d1 <- dicts, d2 <- dicts, d1 `overlapping` d2 ] of - ds@(_ : _) -> throwError . errorMessage $ OverlappingInstances className tys $ nub (map fst ds) + ds@(_ : _) -> throwError . errorMessage $ OverlappingInstances className tys (map fst ds) _ -> case chooseSimplestDictionaries dicts of [] -> throwError . errorMessage $ NoInstanceFound className tys d : _ -> return $ dictionaryValueToValue d diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 03b80f2..84aab4a 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -23,6 +23,7 @@ import qualified Data.Map as M import Control.Applicative import Control.Monad.Except +import Control.Monad.Reader.Class import Control.Monad.State import Control.Monad.Unify @@ -30,6 +31,7 @@ import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Kinds import Language.PureScript.Names +import Language.PureScript.Options import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types @@ -96,19 +98,12 @@ bindLocalTypeVariables moduleName bindings = -- | -- Update the visibility of all names to Defined -- -makeBindingGroupVisible :: (Functor m, MonadState CheckState m) => m () -makeBindingGroupVisible = modifyEnv $ \e -> e { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names e) } - --- | Update the visibility of all names to Defined in the scope of the provided action -withBindingGroupVisible :: (Functor m, MonadState CheckState m) => m a -> m a -withBindingGroupVisible action = preservingNames $ makeBindingGroupVisible >> action - --- | Perform an action while preserving the names from the @Environment@. -preservingNames :: (Functor m, MonadState CheckState m) => m a -> m a -preservingNames action = do - orig <- gets (names . checkEnv) +makeBindingGroupVisible :: (Functor m, MonadState CheckState m) => m a -> m a +makeBindingGroupVisible action = do + orig <- get + modify $ \st -> st { checkEnv = (checkEnv st) { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names . checkEnv $ st) } } a <- action - modifyEnv $ \e -> e { names = orig } + modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } } return a -- | @@ -200,16 +195,18 @@ modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) }) -- | -- Run a computation in the Check monad, starting with an empty @Environment@ -- -runCheck :: (MonadError MultipleErrors m) => Check a -> m (a, Environment) +runCheck :: (MonadReader (Options mode) m, MonadError String m) => Check a -> m (a, Environment) 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' :: (MonadError MultipleErrors m) => Environment -> Check a -> m (a, Environment) -runCheck' env c = interpretMultipleErrors $ do - (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c - return (a, checkEnv s) +runCheck' :: (MonadReader (Options mode) m, MonadError String m) => Environment -> Check a -> m (a, Environment) +runCheck' env c = do + verbose <- asks optionsVerboseErrors + interpretMultipleErrors verbose $ do + (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c + return (a, checkEnv s) -- | -- Make an assertion, failing with an error message diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 9f5da02..b83d80f 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -247,7 +247,7 @@ infer' (Accessor prop val) = do infer' (Abs (Left arg) ret) = do ty <- fresh Just moduleName <- checkCurrentModule <$> get - withBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do + makeBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do body@(TypedValue _ _ bodyTy) <- infer' ret return $ TypedValue True (Abs (Left arg) body) $ function ty bodyTy infer' (Abs (Right _) _) = error "Binder was not desugared" @@ -298,7 +298,7 @@ infer' (PositionedValue pos _ val) = rethrowWithPosition pos $ infer' val infer' _ = error "Invalid argument to infer" inferLetBinding :: [Declaration] -> [Declaration] -> Expr -> (Expr -> UnifyT Type Check Expr) -> UnifyT Type Check ([Declaration], Expr) -inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret) +inferLetBinding seen [] ret j = (,) seen <$> makeBindingGroupVisible (j ret) inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue checkType val ty))) : rest) ret j = do Just moduleName <- checkCurrentModule <$> get (kind, args) <- liftCheck $ kindOfWithScopedVars ty @@ -320,9 +320,7 @@ inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict let ds' = [(ident, LocalVariable, val') | (ident, (val', _)) <- ds1' ++ ds2'] - bindNames dict $ do - makeBindingGroupVisible - inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j + makeBindingGroupVisible $ bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = rethrowWithPosition pos $ do (d' : ds', val') <- inferLetBinding seen (d : ds) ret j return (PositionedDeclaration pos com d' : ds', val') @@ -444,7 +442,7 @@ check' val t@(ConstrainedType constraints ty) = do dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do n <- liftCheck freshDictionaryName return $ Ident $ "__dict_" ++ className ++ "_" ++ show n - val' <- withBindingGroupVisible $ withTypeClassDictionaries (zipWith (\name (className, instanceTy) -> + val' <- makeBindingGroupVisible $ withTypeClassDictionaries (zipWith (\name (className, instanceTy) -> TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular False) (map (Qualified Nothing) dictNames) constraints) $ check val ty return $ TypedValue True (foldr (Abs . Left) val' dictNames) t @@ -470,7 +468,7 @@ check' (ArrayLiteral vals) t@(TypeApp a ty) = do check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do t =?= tyFunction Just moduleName <- checkCurrentModule <$> get - ret' <- withBindingGroupVisible $ bindLocalVariables moduleName [(arg, argTy, Defined)] $ check ret retTy + ret' <- makeBindingGroupVisible $ bindLocalVariables moduleName [(arg, argTy, Defined)] $ check ret retTy return $ TypedValue True (Abs (Left arg) ret') ty check' (Abs (Right _) _) _ = error "Binder was not desugared" check' (App f arg) ret = do diff --git a/tests/Main.hs b/tests/Main.hs index 5c998ee..e7ac794 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -35,21 +35,21 @@ readInput inputFiles = forM inputFiles $ \inputFile -> do text <- readFile inputFile return (inputFile, text) -loadPrelude :: Either P.MultipleErrors (String, String, P.Environment) +loadPrelude :: Either String (String, String, P.Environment) loadPrelude = case P.parseModulesFromFiles id [("", P.prelude)] of - Left parseError -> Left . P.errorMessage . P.ErrorParsingPrelude $ parseError + Left parseError -> Left (show parseError) Right ms -> runReaderT (P.compile (map snd ms) []) $ P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] } -compile :: P.Options P.Compile -> [FilePath] -> IO (Either P.MultipleErrors (String, String, P.Environment)) +compile :: P.Options P.Compile -> [FilePath] -> IO (Either String (String, String, P.Environment)) compile opts inputFiles = do modules <- P.parseModulesFromFiles id <$> readInput inputFiles case modules of Left parseError -> - return . Left . P.errorMessage . P.ErrorParsingPrelude $ parseError + return (Left $ show parseError) Right ms -> return $ runReaderT (P.compile (map snd ms) []) opts -assert :: FilePath -> P.Options P.Compile -> FilePath -> (Either P.MultipleErrors (String, String, P.Environment) -> IO (Maybe String)) -> IO () +assert :: FilePath -> P.Options P.Compile -> 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 @@ -64,7 +64,7 @@ assertCompiles preludeJs preludeExterns inputFile = do { P.optionsMain = Just "Main" , P.optionsAdditional = P.CompileOptions "Tests" ["Main"] ["Main"] } - assert preludeExterns options inputFile $ either (return . Just . P.prettyPrintMultipleErrors False) $ \(js, _, _) -> do + assert preludeExterns options inputFile $ either (return . Just) $ \(js, _, _) -> do process <- findNodeProcess result <- traverse (\node -> readProcessWithExitCode node [] (preludeJs ++ js)) process case result of @@ -77,7 +77,7 @@ assertDoesNotCompile preludeExterns inputFile = do putStrLn $ "Assert " ++ inputFile ++ " does not compile" assert preludeExterns (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }) inputFile $ \e -> case e of - Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> return Nothing + Left err -> putStrLn err >> return Nothing Right _ -> return $ Just "Should not have compiled" findNodeProcess :: IO (Maybe String) @@ -88,7 +88,7 @@ main :: IO () main = do putStrLn "Compiling Prelude" case loadPrelude of - Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure + Left err -> putStrLn err >> exitFailure Right (preludeJs, exts, _) -> do tmp <- getTemporaryDirectory let preludeExterns = tmp ++ pathSeparator : "prelude.externs" @@ -105,3 +105,4 @@ main = do forM_ failingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $ assertDoesNotCompile preludeExterns (failing ++ pathSeparator : inputFile) exitSuccess + |