diff options
43 files changed, 1934 insertions, 1066 deletions
diff --git a/examples/failing/365.purs b/examples/failing/365.purs new file mode 100644 index 0000000..9a97030 --- /dev/null +++ b/examples/failing/365.purs @@ -0,0 +1,11 @@ +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 new file mode 100644 index 0000000..29cad3f --- /dev/null +++ b/examples/failing/RowConstructors1.purs @@ -0,0 +1,6 @@ +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 new file mode 100644 index 0000000..36ff33b --- /dev/null +++ b/examples/failing/RowConstructors2.purs @@ -0,0 +1,6 @@ +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 new file mode 100644 index 0000000..ce321ef --- /dev/null +++ b/examples/failing/RowConstructors3.purs @@ -0,0 +1,6 @@ +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 new file mode 100644 index 0000000..c34eaae --- /dev/null +++ b/examples/failing/TypeSynonyms5.purs @@ -0,0 +1,3 @@ +module Main where + +type T = T diff --git a/examples/passing/CaseStatement.purs b/examples/passing/CaseStatement.purs new file mode 100644 index 0000000..17669c1 --- /dev/null +++ b/examples/passing/CaseStatement.purs @@ -0,0 +1,19 @@ +module Main where + +data A = A | B | C + +f a _ A = a +f _ a B = a +f _ _ C = "Done" + +g a _ A = a +g _ b B = b +g _ _ C = C + +data M a = N | J a + +h f N a = a +h f a N = a +h f (J a) (J b) = J (f a b) + +main = Debug.Trace.trace $ f "Done" "Failed" A diff --git a/examples/passing/Collatz.purs b/examples/passing/Collatz.purs index f61a950..5398249 100644 --- a/examples/passing/Collatz.purs +++ b/examples/passing/Collatz.purs @@ -1,9 +1,20 @@ 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 b883a4e..af68c40 100644 --- a/examples/passing/Guards.purs +++ b/examples/passing/Guards.purs @@ -1,29 +1,39 @@ module Main where - import Prelude +foreign import jsMod + """ + function jsMod(x) { + return function (y) { + return x % y; + }; + } + """ :: Number -> Number -> Number - collatz = \x -> case x of - y | y % 2 == 0 -> y / 2 - y -> y * 3 + 1 +infixl 7 % +(%) = jsMod - -- Guards have access to current scope - collatz2 = \x y -> case x of - z | y > 0 -> z / 2 - z -> z * 3 + 1 +collatz = \x -> case x of + y | y % 2 == 0 -> y / 2 + y -> y * 3 + 1 - min :: forall a. (Ord a) => a -> a -> a - min n m | n < m = n - | otherwise = m +-- Guards have access to current scope +collatz2 = \x y -> case x of + z | y > 0 -> z / 2 + z -> z * 3 + 1 - max :: forall a. (Ord a) => a -> a -> a - max n m = case unit of - _ | m < n -> n - | otherwise -> m +min :: forall a. (Ord a) => a -> a -> a +min n m | n < m = n + | otherwise = m - testIndentation :: Number -> Number -> Number - testIndentation x y | x > 0 - = x + y - | otherwise - = y - x +max :: forall a. (Ord a) => a -> a -> a +max n m = case unit of + _ | m < n -> n + | otherwise -> m - main = Debug.Trace.trace $ min "Done" "ZZZZ" +testIndentation :: Number -> Number -> Number +testIndentation x y | x > 0 + = x + y + | otherwise + = y - x + +main = Debug.Trace.trace $ min "Done" "ZZZZ" diff --git a/examples/passing/Let2.purs b/examples/passing/Let2.purs new file mode 100644 index 0000000..e4ef059 --- /dev/null +++ b/examples/passing/Let2.purs @@ -0,0 +1,15 @@ +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 9ee7a5d..5536772 100644 --- a/examples/passing/OperatorAssociativity.purs +++ b/examples/passing/OperatorAssociativity.purs @@ -35,21 +35,13 @@ 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 new file mode 100644 index 0000000..ae3104e --- /dev/null +++ b/examples/passing/OperatorInlining.purs @@ -0,0 +1,46 @@ +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 d38f7ed..a222fe1 100644 --- a/examples/passing/Operators.purs +++ b/examples/passing/Operators.purs @@ -61,9 +61,6 @@ 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) @@ -94,7 +91,6 @@ 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 new file mode 100644 index 0000000..8d2480c --- /dev/null +++ b/examples/passing/RebindableSyntax.purs @@ -0,0 +1,37 @@ +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 new file mode 100644 index 0000000..b09e0d8 --- /dev/null +++ b/examples/passing/RowConstructors.purs @@ -0,0 +1,40 @@ +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 2c938d0..a0ade1b 100644 --- a/examples/passing/TopLevelCase.purs +++ b/examples/passing/TopLevelCase.purs @@ -1,18 +1,28 @@ module Main where - import Prelude +foreign import jsMod + """ + function jsMod(x) { + return function (y) { + return x % y; + }; + } + """ :: Number -> Number -> Number - 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 +infixl 7 % +(%) = jsMod - guardsTest (x:xs) | x > 0 = guardsTest xs - guardsTest xs = xs +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 - data A = A +guardsTest (x:xs) | x > 0 = guardsTest xs +guardsTest xs = xs - parseTest A 0 = 0 +data A = A - main = Debug.Trace.trace "Done" +parseTest A 0 = 0 + +main = Debug.Trace.trace "Done" diff --git a/prelude/prelude.purs b/prelude/prelude.purs index 1531461..be4d07a 100644 --- a/prelude/prelude.purs +++ b/prelude/prelude.purs @@ -1,156 +1,120 @@ module Prelude - ( otherwise + ( Unit(..), unit + , ($), (#) , 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 - , DivisionRing + , Ring, (-), negate , Num + , DivisionRing , Eq, (==), (/=) - , Ord, Ordering(..), compare, (<), (>), (<=), (>=) - , Bits, (.&.), (.|.), (.^.), shl, shr, zshr, complement - , BoolLike, (&&), (||) - , not - , Semigroup, (<>), (++) - , Unit(..), unit + , Ordering(..), Ord, compare, (<), (>), (<=), (>=) + , Bounded, top, bottom + , Lattice, sup, inf, (||), (&&) + , BoundedLattice + , ComplementedLattice, not + , DistributiveLattice + , BooleanAlgebra + , Show, show ) where - -- | An alias for `true`, which can be useful in guard clauses: + -- | The `Unit` type has a single inhabitant, called `unit`. It represents + -- | values with no computational content. -- | - -- | ```purescript - -- | max x y | x >= y = x - -- | | otherwise = y - -- | ``` - -- | - otherwise :: Boolean - otherwise = true + -- | `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 {} - -- | Flips the order of the arguments to a function of two arguments. + -- | `unit` is the sole inhabitant of the `Unit` type. + unit :: Unit + unit = Unit {} + + infixr 0 $ + infixl 0 # + + -- | Applies a function to its argument. -- | -- | ```purescript - -- | flip const 1 2 = const 2 1 = 2 + -- | length $ groupBy productCategory $ filter isInStock $ products -- | ``` -- | - flip :: forall a b c. (a -> b -> c) -> b -> a -> c - flip f b a = f a b - - -- | Returns its first argument and ignores its second. + -- | is equivalent to: -- | -- | ```purescript - -- | const 1 "hello" = 1 + -- | length (groupBy productCategory (filter isInStock products)) -- | ``` -- | - const :: forall a b. a -> b -> a - const a _ = a + -- | `($)` 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 - -- | This function returns its first argument, and can be used to assert type equalities. - -- | This can be useful when types are otherwise ambiguous. + -- | Applies an argument to a function. -- | -- | ```purescript - -- | main = print $ [] `asTypeOf` [0] + -- | products # filter isInStock # groupBy productCategory # length -- | ``` -- | - -- | 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 - - 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 + -- | is equivalent to: -- | -- | ```purescript - -- | length $ groupBy productCategory $ filter isInStock products + -- | length (groupBy productCategory (filter isInStock products)) -- | ``` -- | - -- | is equivalent to + -- | `(#)` 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 + + -- | Flips the order of the arguments to a function of two arguments. -- | -- | ```purescript - -- | length (groupBy productCategory (filter isInStock (products))) + -- | flip const 1 2 = const 2 1 = 2 -- | ``` - -- | - -- | `($)` 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 + flip :: forall a b c. (a -> b -> c) -> b -> a -> c + flip f b a = f a b - -- | Applies a function to its argument + -- | Returns its first argument and ignores its second. -- | -- | ```purescript - -- | products # groupBy productCategory # filter isInStock # length + -- | const 1 "hello" = 1 -- | ``` - -- | - -- | is equivalent to + 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. -- | -- | ```purescript - -- | length (groupBy productCategory (filter isInStock (products))) + -- | main = print $ [] `asTypeOf` [0] -- | ``` -- | - -- | `(#)` 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 : + -- | 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 infix alias for `cons`. + -- | An alias for `true`, which can be useful in guard clauses: -- | - -- | Note, the running time of this function is `O(n)`. - (:) :: forall a. a -> [a] -> [a] - (:) = cons + -- | ```purescript + -- | max x y | x >= y = x + -- | | otherwise = y + -- | ``` + otherwise :: Boolean + otherwise = true -- | Attaches an element to the front of an array, creating a new array. -- | @@ -168,72 +132,70 @@ module Prelude } """ :: forall a. a -> [a] -> [a] - -- | 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 - - foreign import showStringImpl - """ - function showStringImpl(s) { - return JSON.stringify(s); - } - """ :: String -> String + infixr 6 : - instance showUnit :: Show Unit where - show (Unit {}) = "Unit {}" + -- | An infix alias for `cons`. + -- | + -- | Note, the running time of this function is `O(n)`. + (:) :: forall a. a -> [a] -> [a] + (:) = cons - instance showString :: Show String where - show = showStringImpl + infixr 9 >>> + infixr 9 <<< - instance showBoolean :: Show Boolean where - show true = "true" - show false = "false" + -- | 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 - foreign import showNumberImpl - """ - function showNumberImpl(n) { - return n.toString(); - } - """ :: Number -> String + instance semigroupoidArr :: Semigroupoid (->) where + (<<<) f g x = f (g x) - instance showNumber :: Show Number where - show = showNumberImpl + -- | 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 - 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 + -- | `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 - instance showArray :: (Show a) => Show [a] where - show = showArrayImpl show + instance categoryArr :: Category (->) where + id x = x 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. -- | - -- | `Functor` instances should satisfy the following laws: + -- | Instances must 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 @@ -242,10 +204,12 @@ 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 @@ -257,48 +221,69 @@ 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`. -- | - -- | `Apply` instances should satisfy the following law: + -- | Instances must satisfy the following law in addition to the `Functor` + -- | laws: -- | - -- | - 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 - -- | 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`. + 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`. -- | - -- | 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. -- | - -- | `Applicative` instances should satisfy the following laws: + -- | Instances must satisfy the following laws in addition to the `Apply` + -- | 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 - -- | `liftA1` provides a default implementation of `(<$>)` for any [`Applicative`](#applicative) functor, - -- | without using `(<$>)` as provided by the [`Functor`](#functor)-[`Applicative`](#applicative) superclass relationship. + 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` 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 @@ -309,8 +294,9 @@ 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: -- | @@ -321,15 +307,13 @@ module Prelude -- | -- | where the function argument of `f` is given the name `y`. -- | - -- | `Bind` instances should satisfy the following law: + -- | Instances must satisfy the following law in addition to the `Apply` + -- | laws: -- | -- | - Associativity: `(x >>= f) >>= g = x >>= (\k => f k >>= g)` -- | - -- | 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: + -- | Associativity tells us that we can regroup operations which use `do` + -- | notation so that we can unambiguously write, for example: -- | -- | ```purescript -- | do x <- m1 @@ -339,29 +323,29 @@ module Prelude class (Apply m) <= Bind m where (>>=) :: forall a b. m a -> (a -> m b) -> m b - -- | 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. + 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. -- | - -- | `Monad` instances should satisfy the following laws: + -- | Instances must satisfy the following laws in addition to the + -- | `Applicative` and `Bind` 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 - -- | `return` is an alias for `pure`. - return :: forall m a. (Monad m) => a -> m a - return = pure + instance monadArr :: Monad ((->) r) - -- | `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 @@ -372,10 +356,12 @@ 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 @@ -387,69 +373,153 @@ module Prelude a' <- a return (f' a') - instance functorArr :: Functor ((->) r) where - (<$>) = (<<<) + infixr 5 <> + infixr 5 ++ - instance applyArr :: Apply ((->) r) where - (<*>) f g x = f x (g x) + -- | 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 - instance applicativeArr :: Applicative ((->) r) where - pure = const + -- | `(++)` is an alias for `(<>)`. + (++) :: forall s. (Semigroup s) => s -> s -> s + (++) = (<>) - instance bindArr :: Bind ((->) r) where - (>>=) m f x = f (m x) x + instance semigroupString :: Semigroup String where + (<>) = concatString - instance monadArr :: Monad ((->) r) + instance semigroupUnit :: Semigroup Unit where + (<>) _ _ = unit - infixl 7 * - infixl 7 / - infixl 7 % + instance semigroupArr :: (Semigroup s') => Semigroup (s -> s') where + (<>) f g = \x -> f x <> g x + + instance semigroupOrdering :: Semigroup Ordering where + (<>) LT _ = LT + (<>) GT _ = GT + (<>) EQ y = y + + foreign import concatString + """ + function concatString(s1) { + return function(s2) { + return s1 + s2; + }; + } + """ :: String -> String -> String - infixl 6 - infixl 6 + + infixl 7 * - -- | 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` - -- | + -- | 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` class Semiring a where (+) :: a -> a -> a zero :: a (*) :: a -> a -> a one :: a - -- | Addition, multiplication, modulo operation and division, satisfying: - -- | - -- | - ```a / b * b + (a `mod` b) = a``` - -- | - class (Semiring a) <= ModuloSemiring a where - (/) :: a -> a -> a - mod :: a -> a -> a + instance semiringNumber :: Semiring Number where + (+) = numAdd + zero = 0 + (*) = numMul + one = 1 - -- | Addition, multiplication, and subtraction. - -- | - -- | Has the same laws as `Semiring` but additionally satisfying: + 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. -- | - -- | - `a` is an abelian group under addition + -- | 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 - -- | Ring where every nonzero element has a multiplicative inverse so that: + infixl 7 / + + -- | The `ModuloSemiring` class is for types that support addition, + -- | multiplication, division, and modulo (division remainder) operations. -- | - -- | - ```a `mod` b = zero``` + -- | Instances must satisfy the following law in addition to the `Semiring` + -- | laws: -- | + -- | - 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. + -- | + -- | Instances must satisfy the following law in addition to the `Ring` and + -- | `ModuloSemiring` laws: + -- | + -- | - Multiplicative inverse: `(one / x) * x = one` + -- | + -- | As a consequence of this ```a `mod` b = zero``` as no divide operation + -- | will have a remainder. class (Ring a, ModuloSemiring a) <= DivisionRing a - -- | A commutative field + instance divisionRingNumber :: DivisionRing Number + + instance divisionRingUnit :: DivisionRing Unit + + -- | The `Num` class is for types that are commutative fields. + -- | + -- | Instances must satisfy the following law in addition to the + -- | `DivisionRing` laws: + -- | + -- | - Commutative multiplication: `a * b = b * a` class (DivisionRing a) <= Num a + instance numNumber :: Num Number + + instance numUnit :: Num Unit + foreign import numAdd """ function numAdd(n1) { @@ -459,15 +529,6 @@ 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) { @@ -486,44 +547,15 @@ module Prelude } """ :: Number -> Number -> Number - foreign import numMod + foreign import numSub """ - function numMod(n1) { + function numSub(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 /= @@ -541,6 +573,33 @@ 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) { @@ -559,22 +618,6 @@ 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) { @@ -590,34 +633,14 @@ module Prelude } """ :: forall a. (a -> a -> Boolean) -> [a] -> [a] -> Boolean - instance eqArray :: (Eq a) => Eq [a] where - (==) xs ys = eqArrayImpl (==) xs ys - (/=) xs ys = not (xs == ys) - - -- | The `Ordering` data type represents the three possible outcomes of comparing two values: + -- | 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_: @@ -625,11 +648,45 @@ 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 @@ -637,30 +694,27 @@ 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) { @@ -676,145 +730,148 @@ module Prelude } """ :: forall a. Ordering -> Ordering -> Ordering -> a -> a -> Ordering - unsafeCompare :: forall a. a -> a -> Ordering - unsafeCompare = unsafeCompareImpl LT EQ GT + -- | 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 - instance ordUnit :: Ord Unit where - compare (Unit {}) (Unit {}) = EQ + infixr 2 || + infixr 3 && - instance ordBoolean :: Ord Boolean where - compare false false = EQ - compare false true = LT - compare true true = EQ - compare true false = GT + -- | The `sup` operator. + (||) :: forall a. (Lattice a) => a -> a -> a + (||) = sup - instance ordNumber :: Ord Number where - compare = unsafeCompare + -- | The `inf` operator. + (&&) :: forall a. (Lattice a) => a -> a -> a + (&&) = inf - instance ordString :: Ord String 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 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 boundedLatticeBoolean :: BoundedLattice Boolean - 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 + instance boundedLatticeUnit :: BoundedLattice Unit - foreign import numShr - """ - function numShr(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 numZshr - """ - function numZshr(n1) { - return function(n2) { - return n1 >>> n2; - }; - } - """ :: Number -> Number -> Number + instance complementedLatticeBoolean :: ComplementedLattice Boolean where + not = boolNot - foreign import numAnd - """ - function numAnd(n1) { - return function(n2) { - return n1 & n2; - }; - } - """ :: Number -> Number -> Number + instance complementedLatticeUnit :: ComplementedLattice Unit where + not _ = unit - foreign import numOr - """ - function numOr(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 numXor - """ - function numXor(n1) { - return function(n2) { - return n1 ^ n2; - }; - } - """ :: Number -> Number -> Number + instance distributiveLatticeBoolean :: DistributiveLattice Boolean - foreign import numComplement - """ - function numComplement(n) { - return ~n; - } - """ :: Number -> Number + instance distributiveLatticeUnit :: DistributiveLattice Unit - instance bitsNumber :: Bits Number where - (.&.) = numAnd - (.|.) = numOr - (.^.) = numXor - shl = numShl - shr = numShr - zshr = numZshr - complement = numComplement + -- | 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 - infixr 2 || - infixr 3 && + instance booleanAlgebraBoolean :: BooleanAlgebra Boolean - -- | 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 + instance booleanAlgebraUnit :: BooleanAlgebra Unit - 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 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 boolNot """ @@ -823,46 +880,62 @@ module Prelude } """ :: Boolean -> Boolean - instance boolLikeBoolean :: BoolLike Boolean where - (&&) = boolAnd - (||) = boolOr - not = boolNot + -- | 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 - infixr 5 <> + instance showBoolean :: Show Boolean where + show true = "true" + show false = "false" - -- | 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 showNumber :: Show Number where + show = showNumberImpl - foreign import concatString - """ - function concatString(s1) { - return function(s2) { - return s1 + s2; - }; - } - """ :: String -> String -> String + instance showString :: Show String where + show = showStringImpl - instance semigroupUnit :: Semigroup Unit where - (<>) (Unit {}) (Unit {}) = Unit {} + instance showUnit :: Show Unit where + show _ = "unit" - instance semigroupString :: Semigroup String where - (<>) = concatString + instance showArray :: (Show a) => Show [a] where + show = showArrayImpl show - instance semigroupArr :: (Semigroup s') => Semigroup (s -> s') where - (<>) f g = \x -> f x <> g x + instance showOrdering :: Show Ordering where + show LT = "LT" + show GT = "GT" + show EQ = "EQ" - infixr 5 ++ + foreign import showNumberImpl + """ + function showNumberImpl(n) { + return n.toString(); + } + """ :: Number -> String - -- | `(++)` is an alias for `(<>)`. - (++) :: forall s. (Semigroup s) => s -> s -> s - (++) = (<>) + foreign import showStringImpl + """ + function showStringImpl(s) { + return JSON.stringify(s); + } + """ :: String -> String + + 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 module Data.Function where diff --git a/psc-make/Main.hs b/psc-make/Main.hs index 547f627..c5dfdf9 100644 --- a/psc-make/Main.hs +++ b/psc-make/Main.hs @@ -52,27 +52,29 @@ 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 String IO) a } - deriving (Functor, Applicative, Monad, MonadIO, MonadError String, MonadReader (P.Options P.Make)) +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)) -runMake :: P.Options P.Make -> Make a -> IO (Either String a) +runMake :: P.Options P.Make -> Make a -> IO (Either P.MultipleErrors a) runMake opts = runExceptT . flip runReaderT opts . unMake -makeIO :: IO a -> Make a -makeIO = Make . lift . ExceptT . fmap (either (Left . show) Right) . tryIOError +makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a +makeIO f io = do + e <- liftIO $ tryIOError io + either (throwError . P.errorMessage . f) return e instance P.MonadMake Make where - getTimestamp path = makeIO $ do + getTimestamp path = makeIO (const (P.CannotGetFileInfo path)) $ do exists <- doesFileExist path traverse (const $ getModificationTime path) $ guard exists - readTextFile path = makeIO $ do + readTextFile path = makeIO (const (P.CannotReadFile path))$ do putStrLn $ "Reading " ++ path readFile path - writeTextFile path text = makeIO $ do + writeTextFile path text = makeIO (const (P.CannotWriteFile path)) $ do mkdirp path putStrLn $ "Writing " ++ path writeFile path text - progress = makeIO . putStrLn + progress = liftIO . putStrLn compile :: PSCMakeOptions -> IO () compile (PSCMakeOptions input outputDir opts usePrefix) = do @@ -84,8 +86,8 @@ compile (PSCMakeOptions input outputDir opts usePrefix) = do Right ms -> do e <- runMake opts $ P.make outputDir ms prefix case e of - Left err -> do - putStrLn err + Left errs -> do + putStrLn (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs) exitFailure Right _ -> do exitSuccess @@ -155,8 +157,8 @@ options = P.Options <$> noPrelude <*> noMagicDo <*> pure Nothing <*> noOpts - <*> (not <$> comments) <*> verboseErrors + <*> (not <$> comments) <*> pure P.MakeOptions pscMakeOptions :: Parser PSCMakeOptions diff --git a/psc/Main.hs b/psc/Main.hs index 6be836d..45653a7 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 err -> do - hPutStrLn stderr err + Left errs -> do + hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs) exitFailure Right (js, exts, _) -> do case output of diff --git a/psci/Commands.hs b/psci/Commands.hs deleted file mode 100644 index e7a8025..0000000 --- a/psci/Commands.hs +++ /dev/null @@ -1,78 +0,0 @@ ------------------------------------------------------------------------------ --- --- 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 new file mode 100644 index 0000000..0e5c1d3 --- /dev/null +++ b/psci/Completion.hs @@ -0,0 +1,232 @@ +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 c7bebd2..366fc66 100644 --- a/psci/Directive.hs +++ b/psci/Directive.hs @@ -15,46 +15,85 @@ module Directive where -import Data.List (nub, isPrefixOf) - -data Directive - = Help - | Quit - | Reset - | Browse - | Load - | Type - | Kind - | Show - deriving Eq +import Data.Maybe (fromJust, listToMaybe) +import Data.List (isPrefixOf) +import Data.Tuple (swap) + +import Types -- | --- Maps given directive to relating command strings. +-- List of all avaliable directives. -- -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"] +directives :: [Directive] +directives = map fst directiveStrings -- | --- Tries to parse given string into a directive. +-- A mapping of directives to the different strings that can be used to invoke +-- them. -- -parseDirective :: String -> Maybe Directive -parseDirective cmd = - case filter (matches . snd) mapping of - [directive] -> Just $ fst directive - _ -> Nothing +directiveStrings :: [(Directive, [String])] +directiveStrings = + [ (Help , ["?", "help"]) + , (Quit , ["quit"]) + , (Reset , ["reset"]) + , (Browse , ["browse"]) + , (Load , ["load", "module"]) + , (Type , ["type"]) + , (Kind , ["kind"]) + , (Show , ["show"]) + ] + +-- | +-- Like directiveStrings, but the other way around. +-- +directiveStrings' :: [(String, Directive)] +directiveStrings' = concatMap go directiveStrings where - mapping :: [(Directive, [String])] - mapping = zip directives (map commands directives) + go (dir, strs) = map (\s -> (s, dir)) strs - matches :: [String] -> Bool - matches = any (cmd `isPrefixOf`) +-- | +-- 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 + +-- | +-- True if the given directive takes an argument, false otherwise. +hasArgument :: Directive -> Bool +hasArgument Help = False +hasArgument Quit = False +hasArgument Reset = False +hasArgument _ = True -- | -- The help menu. @@ -63,17 +102,12 @@ help :: [(Directive, String, String)] help = [ (Help, "", "Show this help menu") , (Quit, "", "Quit PSCi") - , (Reset, "", "Reset") - , (Browse, "<module>", "Browse <module>") + , (Reset, "", "Discard all imported modules and declared bindings") + , (Browse, "<module>", "See all functions in <module>") , (Load, "<file>", "Load <file> for importing") , (Type, "<expr>", "Show the type of <expr>") , (Kind, "<type>", "Show the kind of <type>") - , (Show, "import", "Show imported modules") - , (Show, "loaded", "Show loaded modules") + , (Show, "import", "Show all imported modules") + , (Show, "loaded", "Show all loaded modules") ] --- | --- List of all avaliable directives. --- -directives :: [Directive] -directives = nub . map (\(dir, _, _) -> dir) $ help diff --git a/psci/Main.hs b/psci/PSCi.hs index 5969d70..1f611a8 100644 --- a/psci/Main.hs +++ b/psci/PSCi.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- --- Module : Main +-- Module : PSCi -- Copyright : (c) Phil Freeman 2013 -- License : MIT -- @@ -19,18 +19,18 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} -module Main where +module PSCi where import Data.Foldable (traverse_) -import Data.List (intercalate, isPrefixOf, nub, sortBy, sort) -import Data.Maybe (mapMaybe) +import Data.List (intercalate, nub, sort) 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,70 +50,21 @@ 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 +import Parser (parseCommand) +import Completion (completion) +import Types -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 :: [C.ImportedModule] -defaultImports = [(P.ModuleName [P.ProperName "Prelude"], D.Implicit, Nothing)] +defaultImports :: [ImportedModule] +defaultImports = [(P.ModuleName [P.ProperName "Prelude"], P.Implicit, Nothing)] -- | -- Locates the node executable. @@ -175,17 +126,24 @@ expandTilde p = return p -- helpMessage :: String helpMessage = "The following commands are available:\n\n " ++ - intercalate "\n " (map line D.help) + intercalate "\n " (map line D.help) ++ + "\n\n" ++ extraHelp where - 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) + 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" + -- | -- The welcome prologue. @@ -208,129 +166,6 @@ 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 @@ -347,24 +182,26 @@ 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 String IO) a } - deriving (Functor, Applicative, Monad, MonadError String, MonadReader (P.Options P.Make)) +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)) -runMake :: Make a -> IO (Either String a) +runMake :: Make a -> IO (Either P.MultipleErrors a) runMake = runExceptT . flip runReaderT options . unMake -makeIO :: IO a -> Make a -makeIO = Make . lift . ExceptT . fmap (either (Left . show) Right) . tryIOError +makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a +makeIO f io = do + e <- liftIO $ tryIOError io + either (throwError . P.errorMessage . f) return e instance P.MonadMake Make where - getTimestamp path = makeIO $ do + getTimestamp path = makeIO (const (P.CannotGetFileInfo path)) $ do exists <- doesFileExist path traverse (const $ getModificationTime path) $ guard exists - readTextFile path = makeIO $ readFile path - writeTextFile path text = makeIO $ do + readTextFile path = makeIO (const (P.CannotReadFile path)) $ readFile path + writeTextFile path text = makeIO (const (P.CannotWriteFile path)) $ do mkdirp path writeFile path text - progress s = unless (s == "Compiling $PSCI") $ makeIO . putStrLn $ s + progress s = unless (s == "Compiling $PSCI") $ liftIO . putStrLn $ s mkdirp :: FilePath -> IO () mkdirp = createDirectoryIfMissing True . takeDirectory @@ -407,7 +244,7 @@ createTemporaryModuleForImports PSCiState{psciImportedModules = imports} = in P.Module [] moduleName (importDecl `map` imports) Nothing -importDecl :: C.ImportedModule -> P.Declaration +importDecl :: ImportedModule -> P.Declaration importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ modulesDir :: FilePath @@ -426,7 +263,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 err -> PSCI $ outputStrLn err + Left errs -> printErrors errs Right _ -> do psciIO $ writeFile indexFile "require('$PSCI').main();" process <- psciIO findNodeProcess @@ -447,7 +284,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 -> PSCI $ outputStrLn err + Left err -> printErrors err Right _ -> PSCI $ lift (put st') -- | @@ -459,7 +296,7 @@ handleShowLoadedModules = do psciIO $ readModules loadedModules >>= putStrLn return () where readModules = return . unlines . sort . nub . map toModuleName - toModuleName = N.runModuleName . (\ (D.Module _ mdName _ _) -> mdName) . snd + toModuleName = N.runModuleName . (\ (P.Module _ mdName _ _) -> mdName) . snd -- | -- Show the imported modules in psci. @@ -476,17 +313,17 @@ handleShowImportedModules = do Just mn' -> "qualified " ++ N.runModuleName mn ++ " as " ++ N.runModuleName mn' Nothing -> N.runModuleName mn ++ " " ++ showDeclType declType - showDeclType D.Implicit = "" - showDeclType (D.Explicit refs) = refsList refs - showDeclType (D.Hiding refs) = "hiding " ++ refsList refs + showDeclType P.Implicit = "" + showDeclType (P.Explicit refs) = refsList refs + showDeclType (P.Hiding refs) = "hiding " ++ refsList refs refsList refs = "(" ++ commaList (map showRef refs) ++ ")" showRef :: P.DeclarationRef -> String - 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 + 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 commaList :: [String] -> String commaList = intercalate ", " @@ -494,13 +331,13 @@ handleShowImportedModules = do -- | -- Imports a module, preserving the initial state on failure. -- -handleImport :: C.ImportedModule -> PSCI () +handleImport :: 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 err -> PSCI $ outputStrLn err + Left errs -> printErrors errs Right _ -> do PSCI $ lift $ put st return () @@ -514,7 +351,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 err -> PSCI $ outputStrLn err + Left errs -> printErrors errs Right env' -> case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty @@ -548,12 +385,16 @@ handleBrowse moduleName = do let loadedModules = psciLoadedModules st env <- psciIO . runMake $ P.make modulesDir loadedModules [] case env of - Left err -> PSCI $ outputStrLn err + Left errs -> printErrors errs 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 -- @@ -564,7 +405,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 err -> PSCI $ outputStrLn err + Left errs -> printErrors errs Right env' -> case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of Just (_, typ') -> do @@ -578,9 +419,9 @@ handleKindOf typ = do -- Commands -- | --- Parses the input and returns either a Metacommand or an expression. +-- Parses the input and returns either a Metacommand, or an error as a string. -- -getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe C.Command)) +getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command)) getCommand singleLineMode = do firstLine <- getInputLine "> " case firstLine of @@ -593,14 +434,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 :: 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 +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 absPath <- psciIO $ expandTilde filePath exists <- psciIO $ doesFileExist absPath if exists then do @@ -611,7 +452,7 @@ handleCommand (C.LoadFile filePath) = do Right mods -> PSCI . lift $ modify (updateModules (map ((,) (Right absPath)) mods)) else PSCI . outputStrLn $ "Couldn't locate: " ++ filePath -handleCommand C.Reset = do +handleCommand ResetState = do files <- psciImportedFilenames <$> PSCI (lift get) PSCI . lift . modify $ \st -> st { psciImportedFilenames = files @@ -619,14 +460,14 @@ handleCommand C.Reset = do , psciLetBindings = [] } loadAllImportedModules -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]) +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]) loadUserConfig = do configFile <- (</> ".psci") <$> getCurrentDirectory exists <- doesFileExist configFile @@ -662,7 +503,7 @@ loop PSCiOptions{..} = do case c of Left err -> outputStrLn err >> go Right Nothing -> go - Right (Just C.Quit) -> outputStrLn quitMessage + Right (Just QuitPSCi) -> outputStrLn quitMessage Right (Just c') -> runPSCI (loadAllImportedModules >> handleCommand c') >> go multiLineMode :: Parser Bool @@ -690,8 +531,8 @@ psciOptions = PSCiOptions <$> multiLineMode <*> many inputFile <*> nodeFlagsFlag -main :: IO () -main = execParser opts >>= loop +runPSCi :: IO () +runPSCi = 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 d28cc7b..05eda11 100644 --- a/psci/Parser.hs +++ b/psci/Parser.hs @@ -19,22 +19,23 @@ 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 qualified Language.PureScript.Parser.Common as C (mark, same) +import Language.PureScript.Parser.Common (mark, same) + +import qualified Directive as D +import Types -- | -- Parses PSCI metacommands or expressions input from the user. -- -parseCommand :: String -> Either String C.Command +parseCommand :: String -> Either String Command parseCommand cmdString = case cmdString of (':' : cmd) -> parseDirective cmd @@ -45,7 +46,7 @@ parseRest p s = either (Left . show) Right $ do ts <- P.lex "" s P.runTokenParser "" (p <* eof) ts -psciCommand :: P.TokenParser C.Command +psciCommand :: P.TokenParser Command psciCommand = choice (map try parsers) where parsers = @@ -64,25 +65,31 @@ trimStart = dropWhile isSpace trimEnd :: String -> String trimEnd = reverse . trimStart . reverse -parseDirective :: String -> Either String C.Command +parseDirective :: String -> Either String Command parseDirective cmd = - 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 + 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 -- | -- Parses expressions entered at the PSCI repl. -- -psciExpression :: P.TokenParser C.Command -psciExpression = C.Expression <$> P.parseValue +psciExpression :: P.TokenParser Command +psciExpression = Expression <$> P.parseValue -- | -- PSCI version of @let@. @@ -90,21 +97,21 @@ psciExpression = C.Expression <$> P.parseValue -- However, since we don't support the @Eff@ monad, -- we actually want the normal @let@. -- -psciLet :: P.TokenParser C.Command -psciLet = C.Decls <$> (P.reserved "let" *> P.indented *> manyDecls) +psciLet :: P.TokenParser Command +psciLet = Decls <$> (P.reserved "let" *> P.indented *> manyDecls) where manyDecls :: P.TokenParser [P.Declaration] - manyDecls = C.mark (many1 (C.same *> P.parseLocalDeclaration)) + manyDecls = mark (many1 (same *> P.parseLocalDeclaration)) -- | Imports must be handled separately from other declarations, so that -- :show import works, for example. -psciImport :: P.TokenParser C.Command -psciImport = C.Import <$> P.parseImportDeclaration' +psciImport :: P.TokenParser Command +psciImport = Import <$> P.parseImportDeclaration' -- | Any other declaration that we don't need a 'special case' parser for -- (like let or import declarations). -psciOtherDeclaration :: P.TokenParser C.Command -psciOtherDeclaration = C.Decls . (:[]) <$> do +psciOtherDeclaration :: P.TokenParser Command +psciOtherDeclaration = Decls . (:[]) <$> do decl <- discardPositionInfo <$> P.parseDeclaration if acceptable decl then return decl @@ -123,3 +130,10 @@ 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 new file mode 100644 index 0000000..bc683c2 --- /dev/null +++ b/psci/Types.hs @@ -0,0 +1,167 @@ +----------------------------------------------------------------------------- +-- +-- 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 new file mode 100644 index 0000000..e430648 --- /dev/null +++ b/psci/main/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import PSCi + +main :: IO () +main = runPSCi diff --git a/psci/tests/Main.hs b/psci/tests/Main.hs new file mode 100644 index 0000000..a703ca2 --- /dev/null +++ b/psci/tests/Main.hs @@ -0,0 +1,137 @@ +{-# 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 588bcef..09c44d4 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.6.9.3 +version: 0.6.9.4 cabal-version: >=1.8 build-type: Simple license: MIT @@ -148,10 +148,12 @@ executable psci main-is: Main.hs buildable: True - hs-source-dirs: psci - other-modules: Commands + hs-source-dirs: psci psci/main + other-modules: Types Parser Directive + Completion + PSCi ghc-options: -Wall -O2 executable psc-docs @@ -182,3 +184,14 @@ 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 d0d293f..609f5fb 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 String m, MonadReader (Options Compile) m) +compile :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadReader (Options Compile) m) => [Module] -> [String] -> m (String, String, Environment) compile = compile' initEnvironment -compile' :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m) +compile' :: (Functor m, Applicative m, MonadError MultipleErrors 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) <- interpretMultipleErrors True $ runSupplyT 0 $ desugar sorted + (desugared, nextVar) <- runSupplyT 0 $ desugar sorted (elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent - regrouped <- interpretMultipleErrors True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated + regrouped <- 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 String m, MonadReader (Options Compile) m) => Environment -> [JS] -> m [JS] +generateMain :: (MonadError MultipleErrors 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 $ show mmi ++ "." ++ C.main ++ " is undefined" + throwError . errorMessage $ NameIsUndefined (Ident C.main) 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 String m) => MonadMake m where +class (MonadReader (P.Options P.Make) m, MonadError MultipleErrors 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) <- interpretMultipleErrors True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked) + (desugared, nextVar) <- 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 <- interpretMultipleErrors True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated + regrouped <- 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 . show) return $ P.parseModulesFromFiles id [(externsFile, externs)] + externsModules <- fmap (map snd) . either (throwError . errorMessage . ErrorParsingExterns) return $ P.parseModulesFromFiles id [(externsFile, externs)] case externsModules of [m'@(Module _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms' - _ -> throwError $ "Externs file " ++ externsFile ++ " was invalid" + _ -> throwError . errorMessage . InvalidExternsFile $ externsFile 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 f857fa0..065ef0b 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] +exportedDctors :: Module -> ProperName -> [(ProperName, [Type])] exportedDctors (Module _ _ decls exps) ident = - filter (isDctorExported ident exps) dctors + filter (isDctorExported ident exps . fst) dctors where dctors = concatMap getDctors (flattenDecls decls) - getDctors (DataDeclaration _ _ _ ctors) = map fst ctors + getDctors (DataDeclaration _ _ _ ctors) = ctors getDctors (PositionedDeclaration _ _ d) = getDctors d getDctors _ = [] diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs index 97c3dc6..454fbdb 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -30,10 +30,12 @@ data SourcePos = SourcePos -- Column number -- , sourcePosColumn :: Int - } deriving (Eq, D.Data, D.Typeable) + } deriving (Eq, Show, D.Data, D.Typeable) -instance Show SourcePos where - show sp = "line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp) +displaySourcePos :: SourcePos -> String +displaySourcePos sp = + "line " ++ show (sourcePosLine sp) ++ + ", column " ++ show (sourcePosColumn sp) data SourceSpan = SourceSpan { -- | @@ -47,7 +49,10 @@ data SourceSpan = SourceSpan -- End of the span -- , spanEnd :: SourcePos - } deriving (Eq, D.Data, D.Typeable) + } deriving (Eq, Show, D.Data, D.Typeable) -instance Show SourceSpan where - show sp = spanName sp ++ " " ++ show (spanStart sp) ++ " - " ++ show (spanEnd sp) +displaySourceSpan :: SourceSpan -> String +displaySourceSpan sp = + spanName sp ++ " " ++ + displaySourcePos (spanStart sp) ++ " - " ++ + displaySourcePos (spanEnd sp) diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs index caf7017..ad27785 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -84,10 +84,28 @@ inlineValues :: JS -> JS inlineValues = everywhereOnJS convert where convert :: JS -> JS - 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 (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 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 @@ -101,58 +119,83 @@ inlineOperator (m, op) f = everywhereOnJS convert inlineCommonOperators :: JS -> JS inlineCommonOperators = applyAll $ - [ 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 + [ 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 ] ++ [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] where - binary :: String -> String -> BinaryOperator -> JS -> JS - binary dictName opString op = everywhereOnJS convert + binary :: (String, String) -> String -> BinaryOperator -> JS -> JS + binary dict opString op = everywhereOnJS convert where convert :: JS -> JS - convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isPreludeDict dictName dict && isPreludeFn opString fn = JSBinary op x y + convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isDict dict dict' && isPreludeFn opString fn = JSBinary op x y convert other = other - binaryFunction :: String -> String -> BinaryOperator -> JS -> JS - binaryFunction dictName fnName op = everywhereOnJS convert + binary' :: String -> String -> BinaryOperator -> JS -> JS + binary' moduleName opString op = everywhereOnJS convert where convert :: JS -> JS - convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isPreludeFn fnName fn && isPreludeDict dictName dict = JSBinary op x y + convert (JSApp (JSApp fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary op x y convert other = other - unary :: String -> String -> UnaryOperator -> JS -> JS - unary dictName fnName op = everywhereOnJS convert + binaryFunction :: (String, String) -> String -> BinaryOperator -> JS -> JS + binaryFunction dict fnName op = everywhereOnJS convert where convert :: JS -> JS - convert (JSApp (JSApp fn [dict]) [x]) | isPreludeFn fnName fn && isPreludeDict dictName dict = JSUnary op x + 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 other = other mkFn :: Int -> JS -> JS mkFn 0 = everywhereOnJS convert @@ -190,12 +233,62 @@ inlineCommonOperators = applyAll $ go m acc (JSApp lhs [arg]) = go (m - 1) (arg : acc) lhs go _ _ _ = Nothing -isPreludeDict :: String -> JS -> Bool -isPreludeDict dictName (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == dictName -isPreludeDict _ _ = False +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 isPreludeFn :: String -> JS -> Bool -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 +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) diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs index 4fc86fe..eadc51f 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs @@ -15,6 +15,8 @@ module Language.PureScript.CodeGen.JS.Optimizer.TCO (tco) where +import Data.Monoid + import Language.PureScript.Options import Language.PureScript.CodeGen.JS.AST @@ -30,10 +32,13 @@ 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 @@ -46,6 +51,7 @@ 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 @@ -56,25 +62,35 @@ 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 ++ @@ -94,10 +110,19 @@ 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') args) | ident == ident' && not (any isFunction args) = True - isSelfCall ident (JSApp fn args) | not (any isFunction args) = isSelfCall ident fn + isSelfCall ident (JSApp (JSVar ident') _) = ident == ident' + isSelfCall ident (JSApp fn _) = isSelfCall ident fn isSelfCall _ _ = False - isFunction :: JS -> Bool - isFunction (JSFunction _ _ _) = True - isFunction _ = 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 diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index 51ba984..6978e7b 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -15,7 +15,7 @@ module Language.PureScript.Constants where --- Prelude Operators +-- Operators ($) :: String ($) = "$" @@ -65,15 +65,6 @@ module Language.PureScript.Constants where (/=) :: String (/=) = "/=" -(.&.) :: String -(.&.) = ".&." - -(.|.) :: String -(.|.) = ".|." - -(.^.) :: String -(.^.) = ".^." - (&&) :: String (&&) = "&&" @@ -83,11 +74,32 @@ module Language.PureScript.Constants where unsafeIndex :: String unsafeIndex = "unsafeIndex" --- Prelude Operator Functions +(.|.) :: String +(.|.) = ".|." + +(.&.) :: String +(.&.) = ".&." + +(.^.) :: String +(.^.) = ".^." + +-- 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" @@ -100,8 +112,8 @@ zshr = "zshr" complement :: String complement = "complement" -not :: String -not = "not" +fromNumber :: String +fromNumber = "fromNumber" -- Prelude Values @@ -111,6 +123,12 @@ zero = "zero" one :: String one = "one" +bottom :: String +bottom = "bottom" + +top :: String +top = "top" + return :: String return = "return" @@ -172,32 +190,47 @@ bindEffDictionary = "bindEff" semiringNumber :: String semiringNumber = "semiringNumber" +semiringInt :: String +semiringInt = "semiringInt" + ringNumber :: String ringNumber = "ringNumber" +ringInt :: String +ringInt = "ringInt" + moduloSemiringNumber :: String moduloSemiringNumber = "moduloSemiringNumber" -numNumber :: String -numNumber = "numNumber" +moduloSemiringInt :: String +moduloSemiringInt = "moduloSemiringInt" ordNumber :: String ordNumber = "ordNumber" +ordInt :: String +ordInt = "ordInt" + eqNumber :: String eqNumber = "eqNumber" +eqInt :: String +eqInt = "eqInt" + eqString :: String eqString = "eqString" eqBoolean :: String eqBoolean = "eqBoolean" -bitsNumber :: String -bitsNumber = "bitsNumber" +boundedBoolean :: String +boundedBoolean = "boundedBoolean" + +latticeBoolean :: String +latticeBoolean = "latticeBoolean" -boolLikeBoolean :: String -boolLikeBoolean = "boolLikeBoolean" +complementedLatticeBoolean :: String +complementedLatticeBoolean = "complementedLatticeBoolean" semigroupString :: String semigroupString = "semigroupString" @@ -237,3 +270,9 @@ 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 07d8b19..617e49b 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -36,11 +36,19 @@ import Language.PureScript.TypeClassDictionaries import qualified Text.PrettyPrint.Boxes as Box +import qualified Text.Parsec as P + -- | -- A type of error messages -- data ErrorMessage - = InfiniteType Type + = ErrorParsingExterns P.ParseError + | ErrorParsingPrelude P.ParseError + | InvalidExternsFile FilePath + | CannotGetFileInfo FilePath + | CannotReadFile FilePath + | CannotWriteFile FilePath + | InfiniteType Type | InfiniteKind Kind | CannotReorderOperators | MultipleFixities Ident @@ -70,6 +78,7 @@ data ErrorMessage | InvalidDoLet | CycleInDeclaration Ident | CycleInTypeSynonym (Maybe ProperName) + | CycleInModules [ModuleName] | NameIsUndefined Ident | NameNotInScope Ident | UndefinedTypeVariable ProperName @@ -126,6 +135,12 @@ 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" @@ -156,6 +171,7 @@ errorCode InvalidDoBind = "InvalidDoBind" errorCode InvalidDoLet = "InvalidDoLet" errorCode (CycleInDeclaration _) = "CycleInDeclaration" errorCode (CycleInTypeSynonym _) = "CycleInTypeSynonym" +errorCode (CycleInModules _) = "CycleInModules" errorCode (NameIsUndefined _) = "NameIsUndefined" errorCode (NameNotInScope _) = "NameNotInScope" errorCode (UndefinedTypeVariable _) = "UndefinedTypeVariable" @@ -177,13 +193,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 @@ -245,6 +261,24 @@ 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" @@ -278,6 +312,7 @@ 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 ] @@ -404,7 +439,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 pos err) = paras [ line $ "Error at " ++ show pos ++ ":" + go (PositionedError srcSpan err) = paras [ line $ "Error at " ++ displaySourceSpan srcSpan ++ ":" , indent $ go err ] @@ -490,8 +525,8 @@ renderBox = unlines . map trimEnd . lines . Box.render -- | -- Interpret multiple errors in a monad supporting errors -- -interpretMultipleErrors :: (MonadError String m) => Bool -> Either MultipleErrors a -> m a -interpretMultipleErrors printFullStack = either (throwError . prettyPrintMultipleErrors printFullStack) return +interpretMultipleErrors :: (MonadError MultipleErrors m) => Either MultipleErrors a -> m a +interpretMultipleErrors = either throwError 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 1af1ab4..177ae6c 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -28,6 +28,7 @@ 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 @@ -39,7 +40,7 @@ type ModuleGraph = [(ModuleName, [ModuleName])] -- -- Reports an error if the module graph contains a cycle. -- -sortModules :: (MonadError String m) => [Module] -> m ([Module], ModuleGraph) +sortModules :: (MonadError MultipleErrors 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 @@ -70,7 +71,7 @@ usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues ( -- | -- Convert a strongly connected component of the module graph to a module -- -toModule :: (MonadError String m) => SCC Module -> m Module +toModule :: (MonadError MultipleErrors m) => SCC Module -> m Module toModule (AcyclicSCC m) = return m toModule (CyclicSCC [m]) = return m -toModule (CyclicSCC ms) = throwError $ "Cycle in module dependencies: " ++ show (map getModuleName ms) +toModule (CyclicSCC ms) = throwError . errorMessage $ CycleInModules (map getModuleName ms) diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index 3135be1..d4f8a5b 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -126,9 +126,7 @@ parseNameAndType :: TokenParser t -> TokenParser (String, t) parseNameAndType p = (,) <$> (indented *> (lname <|> stringLiteral) <* indented <* doubleColon) <*> p parseRowEnding :: TokenParser Type -parseRowEnding = P.option REmpty $ indented *> pipe *> indented *> P.choice (map P.try - [ parseTypeWildcard - , TypeVar <$> identifier ]) +parseRowEnding = P.option REmpty $ indented *> pipe *> indented *> parseType 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 b5e311b..8c5efb3 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -157,7 +157,6 @@ 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 3f48f88..829bb04 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -21,10 +21,11 @@ module Language.PureScript.Sugar.CaseDeclarations ( desugarCasesModule ) where +import Data.Maybe (catMaybes) import Data.List (nub, groupBy) import Control.Applicative -import Control.Monad ((<=<), forM, join, unless, replicateM) +import Control.Monad ((<=<), forM, replicateM, join, unless) import Control.Monad.Except (throwError) import Control.Monad.Error.Class (MonadError) import Control.Monad.Supply.Class @@ -120,31 +121,53 @@ toTuple _ = error "Not a value declaration" makeCaseDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration makeCaseDeclaration ident alternatives = do let namedArgs = map findName . fst <$> alternatives - args <- mapM argName $ foldl1 resolveNames namedArgs - let - vars = map (Var . Qualified Nothing) args - binders = [ CaseAlternative bs result | (bs, result) <- alternatives ] - value = foldr (Abs . Left) (Case vars binders) args + argNames = map join $ foldl1 resolveNames namedArgs + args <- if allUnique (catMaybes argNames) + then mapM argName argNames + else replicateM (length argNames) (Ident <$> freshName) + let vars = map (Var . Qualified Nothing) args + binders = [ CaseAlternative bs result | (bs, result) <- alternatives ] + value = foldr (Abs . Left) (Case vars binders) args return $ ValueDeclaration ident Value [] (Right value) where - findName :: Binder -> Maybe Ident - findName (VarBinder name) = Just name + -- 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) + argName :: (MonadSupply m) => Maybe Ident -> m Ident argName (Just name) = return name - argName Nothing = do + argName _ = do name <- freshName return (Ident name) - resolveNames :: [Maybe Ident] -> [Maybe Ident] -> [Maybe Ident] + -- 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 - resolveName :: Maybe Ident -> Maybe Ident -> Maybe Ident - resolveName (Just a) (Just b) - | a == b = Just a + -- Resolve a pair of names. VarBinder beats NullBinder, and everything + -- else results in Nothing. + resolveName :: Maybe (Maybe Ident) -> + Maybe (Maybe Ident) -> + Maybe (Maybe Ident) + resolveName (Just (Just a)) (Just (Just b)) + | a == b = Just (Just a) | otherwise = Nothing - resolveName Nothing Nothing = Nothing - resolveName (Just a) Nothing = Just a - resolveName Nothing (Just b) = Just b + resolveName (Just Nothing) a = a + resolveName a (Just Nothing) = a + resolveName _ _ = Nothing diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index 9667655..966fa1d 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -44,11 +44,8 @@ desugarDo d = let (f, _, _) = everywhereOnValuesM return replace return in f d where - prelude :: ModuleName - prelude = ModuleName [ProperName C.prelude] - bind :: Expr - bind = Var (Qualified (Just prelude) (Op (C.>>=))) + bind = Var (Qualified Nothing (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 75b9b42..be5e2d7 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 (map fst ds) + ds@(_ : _) -> throwError . errorMessage $ OverlappingInstances className tys $ nub (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 84aab4a..03b80f2 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -23,7 +23,6 @@ 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 @@ -31,7 +30,6 @@ 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 @@ -98,12 +96,19 @@ bindLocalTypeVariables moduleName bindings = -- | -- Update the visibility of all names to Defined -- -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) } } +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) a <- action - modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } } + modifyEnv $ \e -> e { names = orig } return a -- | @@ -195,18 +200,16 @@ modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) }) -- | -- Run a computation in the Check monad, starting with an empty @Environment@ -- -runCheck :: (MonadReader (Options mode) m, MonadError String m) => Check a -> m (a, Environment) +runCheck :: (MonadError MultipleErrors 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' :: (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) +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) -- | -- 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 b83d80f..9f5da02 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 - makeBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do + withBindingGroupVisible $ 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 <$> makeBindingGroupVisible (j ret) +inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (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,7 +320,9 @@ 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'] - makeBindingGroupVisible $ bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j + bindNames dict $ do + makeBindingGroupVisible + 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') @@ -442,7 +444,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' <- makeBindingGroupVisible $ withTypeClassDictionaries (zipWith (\name (className, instanceTy) -> + val' <- withBindingGroupVisible $ 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 @@ -468,7 +470,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' <- makeBindingGroupVisible $ bindLocalVariables moduleName [(arg, argTy, Defined)] $ check ret retTy + ret' <- withBindingGroupVisible $ 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 e7ac794..5c998ee 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 String (String, String, P.Environment) +loadPrelude :: Either P.MultipleErrors (String, String, P.Environment) loadPrelude = case P.parseModulesFromFiles id [("", P.prelude)] of - Left parseError -> Left (show parseError) + Left parseError -> Left . P.errorMessage . P.ErrorParsingPrelude $ parseError Right ms -> runReaderT (P.compile (map snd ms) []) $ P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] } -compile :: P.Options P.Compile -> [FilePath] -> IO (Either String (String, String, P.Environment)) +compile :: P.Options P.Compile -> [FilePath] -> IO (Either P.MultipleErrors (String, String, P.Environment)) compile opts inputFiles = do modules <- P.parseModulesFromFiles id <$> readInput inputFiles case modules of Left parseError -> - return (Left $ show parseError) + return . Left . P.errorMessage . P.ErrorParsingPrelude $ parseError Right ms -> return $ runReaderT (P.compile (map snd ms) []) opts -assert :: FilePath -> P.Options P.Compile -> FilePath -> (Either String (String, String, P.Environment) -> IO (Maybe String)) -> IO () +assert :: FilePath -> P.Options P.Compile -> FilePath -> (Either P.MultipleErrors (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) $ \(js, _, _) -> do + assert preludeExterns options inputFile $ either (return . Just . P.prettyPrintMultipleErrors False) $ \(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 err -> putStrLn err >> return Nothing + Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> 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 err -> putStrLn err >> exitFailure + Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure Right (preludeJs, exts, _) -> do tmp <- getTemporaryDirectory let preludeExterns = tmp ++ pathSeparator : "prelude.externs" @@ -105,4 +105,3 @@ main = do forM_ failingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $ assertDoesNotCompile preludeExterns (failing ++ pathSeparator : inputFile) exitSuccess - |