diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -31,6 +31,7 @@ - [@jacereda](https://github.com/jacereda) (Jorge Acereda) My existing contributions and all future contributions until further notice are Copyright Jorge Acereda, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@japesinator](https://github.com/japesinator) (JP Smith) My existing contributions and all future contributions until further notice are Copyright JP Smith, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@joneshf](https://github.com/joneshf) (Hardy Jones) - My existing contributions and all future contributions until further notice are Copyright Hardy Jones, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. +- [@kika](https://github.com/kika) (Kirill Pertsev) - My existing contributions and all future contributions until further notice are Copyright Kirill Pertsev, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@kRITZCREEK](https://github.com/kRITZCREEK) (Christoph Hegemann) - My existing contributions and all future contributions until further notice are Copyright Christoph Hegemann, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@L8D](https://github.com/L8D) (Tenor Biel) My existing contributions and all future contributions until further notice are Copyright Tenor Biel, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@leighman](http://github.com/leighman) (Jack Leigh) My existing contributions and all future contributions until further notice are Copyright Jack Leigh, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). @@ -70,6 +71,7 @@ - [@zudov](https://github.com/zudov) (Konstantin Zudov) My existing contributions and all future contributions until further notice are Copyright Konstantin Zudov, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@LiamGoodacre](https://github.com/LiamGoodacre) (Liam Goodacre) My existing contributions and all future contributions until further notice are Copyright Liam Goodacre, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@bsermons](https://github.com/bsermons) (Brian Sermons) My existing contributions and all future contributions until further notice are Copyright Brian Sermons, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@bmjames](https://github.com/bmjames) (Ben James) My existing contributions and all future contributions until further notice are Copyright Ben James, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). ### Companies diff --git a/examples/docs/src/Clash.purs b/examples/docs/src/Clash.purs --- a/examples/docs/src/Clash.purs +++ b/examples/docs/src/Clash.purs @@ -2,31 +2,3 @@ import Clash1 as Clash1 import Clash2 as Clash2 - -module Clash1 (module Clash1a) where - -import Clash1a - -module Clash1a where - -value :: Int -value = 0 - -type Type = Int - -class TypeClass a where - typeClassMember :: a - -module Clash2 (module Clash2a) where - -import Clash2a - -module Clash2a where - -value :: String -value = "hello" - -type Type = String - -class TypeClass a b where - typeClassMember :: a -> b diff --git a/examples/docs/src/Clash1.purs b/examples/docs/src/Clash1.purs new file mode 100644 --- /dev/null +++ b/examples/docs/src/Clash1.purs @@ -0,0 +1,3 @@ +module Clash1 (module Clash1a) where + +import Clash1a diff --git a/examples/docs/src/Clash1a.purs b/examples/docs/src/Clash1a.purs new file mode 100644 --- /dev/null +++ b/examples/docs/src/Clash1a.purs @@ -0,0 +1,9 @@ +module Clash1a where + +value :: Int +value = 0 + +type Type = Int + +class TypeClass a where + typeClassMember :: a diff --git a/examples/docs/src/Clash2.purs b/examples/docs/src/Clash2.purs new file mode 100644 --- /dev/null +++ b/examples/docs/src/Clash2.purs @@ -0,0 +1,3 @@ +module Clash2 (module Clash2a) where + +import Clash2a diff --git a/examples/docs/src/Clash2a.purs b/examples/docs/src/Clash2a.purs new file mode 100644 --- /dev/null +++ b/examples/docs/src/Clash2a.purs @@ -0,0 +1,9 @@ +module Clash2a where + +value :: String +value = "hello" + +type Type = String + +class TypeClass a b where + typeClassMember :: a -> b diff --git a/examples/docs/src/ImportedTwice.purs b/examples/docs/src/ImportedTwice.purs --- a/examples/docs/src/ImportedTwice.purs +++ b/examples/docs/src/ImportedTwice.purs @@ -4,24 +4,10 @@ -- re-exports it from Control.Monad.Trans). module ImportedTwice - ( module A - , module B + ( module ImportedTwiceA + , module ImportedTwiceB ) where -import A -import B - -module A - ( module B ) - where - -import B - -bar :: Int -bar = 1 - -module B where - -foo :: Int -foo = 0 +import ImportedTwiceA +import ImportedTwiceB diff --git a/examples/docs/src/ImportedTwiceA.purs b/examples/docs/src/ImportedTwiceA.purs new file mode 100644 --- /dev/null +++ b/examples/docs/src/ImportedTwiceA.purs @@ -0,0 +1,8 @@ +module ImportedTwiceA + ( module ImportedTwiceB ) + where + +import ImportedTwiceB + +bar :: Int +bar = 1 diff --git a/examples/docs/src/ImportedTwiceB.purs b/examples/docs/src/ImportedTwiceB.purs new file mode 100644 --- /dev/null +++ b/examples/docs/src/ImportedTwiceB.purs @@ -0,0 +1,4 @@ +module ImportedTwiceB where + +foo :: Int +foo = 0 diff --git a/examples/docs/src/MultiVirtual.purs b/examples/docs/src/MultiVirtual.purs --- a/examples/docs/src/MultiVirtual.purs +++ b/examples/docs/src/MultiVirtual.purs @@ -4,24 +4,3 @@ import MultiVirtual1 as X import MultiVirtual2 as X - - -module MultiVirtual1 where - -foo :: Int -foo = 1 - -module MultiVirtual2 - ( module MultiVirtual2 - , module MultiVirtual3 - ) where - -import MultiVirtual3 - -bar :: Int -bar = 2 - -module MultiVirtual3 where - -baz :: Int -baz = 3 diff --git a/examples/docs/src/MultiVirtual1.purs b/examples/docs/src/MultiVirtual1.purs new file mode 100644 --- /dev/null +++ b/examples/docs/src/MultiVirtual1.purs @@ -0,0 +1,4 @@ +module MultiVirtual1 where + +foo :: Int +foo = 1 diff --git a/examples/docs/src/MultiVirtual2.purs b/examples/docs/src/MultiVirtual2.purs new file mode 100644 --- /dev/null +++ b/examples/docs/src/MultiVirtual2.purs @@ -0,0 +1,9 @@ +module MultiVirtual2 + ( module MultiVirtual2 + , module MultiVirtual3 + ) where + +import MultiVirtual3 + +bar :: Int +bar = 2 diff --git a/examples/docs/src/MultiVirtual3.purs b/examples/docs/src/MultiVirtual3.purs new file mode 100644 --- /dev/null +++ b/examples/docs/src/MultiVirtual3.purs @@ -0,0 +1,4 @@ +module MultiVirtual3 where + +baz :: Int +baz = 3 diff --git a/examples/docs/src/NewOperators.purs b/examples/docs/src/NewOperators.purs --- a/examples/docs/src/NewOperators.purs +++ b/examples/docs/src/NewOperators.purs @@ -3,10 +3,3 @@ where import NewOperators2 - -module NewOperators2 where - -infixl 8 _compose as >>> - -_compose :: forall a b c. (b -> c) -> (a -> b) -> (a -> c) -_compose f g x = f (g x) diff --git a/examples/docs/src/NewOperators2.purs b/examples/docs/src/NewOperators2.purs new file mode 100644 --- /dev/null +++ b/examples/docs/src/NewOperators2.purs @@ -0,0 +1,6 @@ +module NewOperators2 where + +infixl 8 _compose as >>> + +_compose :: forall a b c. (b -> c) -> (a -> b) -> (a -> c) +_compose f g x = f (g x) diff --git a/examples/docs/src/OldOperators.purs b/examples/docs/src/OldOperators.purs deleted file mode 100644 --- a/examples/docs/src/OldOperators.purs +++ /dev/null @@ -1,10 +0,0 @@ - --- Remove this after 0.9. -module OldOperators (module OldOperators2) where - -import OldOperators2 - -module OldOperators2 where - -(>>) :: forall a. a -> a -> a -(>>) a b = b diff --git a/examples/docs/src/TypeClassWithoutMembers.purs b/examples/docs/src/TypeClassWithoutMembers.purs --- a/examples/docs/src/TypeClassWithoutMembers.purs +++ b/examples/docs/src/TypeClassWithoutMembers.purs @@ -1,11 +1,5 @@ module TypeClassWithoutMembers - ( module Intermediate ) - where - -import Intermediate - -module Intermediate - ( module SomeTypeClass ) + ( module TypeClassWithoutMembersIntermediate ) where -import SomeTypeClass (SomeClass) +import TypeClassWithoutMembersIntermediate diff --git a/examples/docs/src/TypeClassWithoutMembersIntermediate.purs b/examples/docs/src/TypeClassWithoutMembersIntermediate.purs new file mode 100644 --- /dev/null +++ b/examples/docs/src/TypeClassWithoutMembersIntermediate.purs @@ -0,0 +1,5 @@ +module TypeClassWithoutMembersIntermediate + ( module SomeTypeClass ) + where + +import SomeTypeClass (class SomeClass) diff --git a/examples/failing/1733.purs b/examples/failing/1733.purs --- a/examples/failing/1733.purs +++ b/examples/failing/1733.purs @@ -1,13 +1,6 @@ --- @shouldFailWith UnknownValue - +-- @shouldFailWith UnknownName module Main where import Thingy as Thing main = Thing.doesntExist "hi" - -module Thingy where - -foo :: Int -foo = 1 - diff --git a/examples/failing/1733/Thingy.purs b/examples/failing/1733/Thingy.purs new file mode 100644 --- /dev/null +++ b/examples/failing/1733/Thingy.purs @@ -0,0 +1,4 @@ +module Thingy where + +foo :: Int +foo = 1 diff --git a/examples/failing/1825.purs b/examples/failing/1825.purs --- a/examples/failing/1825.purs +++ b/examples/failing/1825.purs @@ -1,9 +1,9 @@ --- @shouldFailWith UnknownValue +-- @shouldFailWith UnknownName module Main where data W = X | Y | Z -bad X a = a -bad Y _ = a -bad Z a = a +bad X a = a +bad Y _ = a +bad Z a = a diff --git a/examples/failing/1881.purs b/examples/failing/1881.purs new file mode 100644 --- /dev/null +++ b/examples/failing/1881.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith ErrorParsingModule +module Main where + +foo = +bar :: Int +bar = 3 diff --git a/examples/failing/2128-class.purs b/examples/failing/2128-class.purs new file mode 100644 --- /dev/null +++ b/examples/failing/2128-class.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith ErrorParsingModule +module Main where + +class Foo a where + foo :: a -> !!! diff --git a/examples/failing/2128-instance.purs b/examples/failing/2128-instance.purs new file mode 100644 --- /dev/null +++ b/examples/failing/2128-instance.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith ErrorParsingModule +module Main where + +class Foo a where + foo :: a + +instance fooInt :: Foo Int where + foo = !!! diff --git a/examples/failing/ArgLengthMismatch.purs b/examples/failing/ArgLengthMismatch.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ArgLengthMismatch.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith ArgListLengthsDiffer +module ArgLengthMismatch where + +import Prelude + +f x y = true +f = false diff --git a/examples/failing/Arrays.purs b/examples/failing/Arrays.purs --- a/examples/failing/Arrays.purs +++ b/examples/failing/Arrays.purs @@ -1,8 +1,6 @@ -- @shouldFailWith TypesDoNotUnify module Main where -import Prelude - -foreign import (!!) :: forall a. Array a -> Int -> a +foreign import ix :: forall a. Array a -> Int -> a -test = \arr -> arr !! (0 !! 0) +test = \arr -> arr `ix` (0 `ix` 0) diff --git a/examples/failing/ConflictingExports.purs b/examples/failing/ConflictingExports.purs --- a/examples/failing/ConflictingExports.purs +++ b/examples/failing/ConflictingExports.purs @@ -1,14 +1,4 @@ -- @shouldFailWith ScopeConflict -module A where - - thing :: Int - thing = 1 - -module B where - - thing :: Int - thing = 2 - -- Fails here because re-exporting forces any scope conflicts to be resolved module Main (module A, module B) where diff --git a/examples/failing/ConflictingExports/A.purs b/examples/failing/ConflictingExports/A.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ConflictingExports/A.purs @@ -0,0 +1,4 @@ +module A where + +thing :: Int +thing = 1 diff --git a/examples/failing/ConflictingExports/B.purs b/examples/failing/ConflictingExports/B.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ConflictingExports/B.purs @@ -0,0 +1,4 @@ +module B where + +thing :: Int +thing = 2 diff --git a/examples/failing/ConflictingImports.purs b/examples/failing/ConflictingImports.purs --- a/examples/failing/ConflictingImports.purs +++ b/examples/failing/ConflictingImports.purs @@ -1,19 +1,9 @@ -- @shouldFailWith ScopeConflict -module A where - - thing :: Int - thing = 1 - -module B where - - thing :: Int - thing = 2 - module Main where - import A - import B +import A +import B - -- Error due to referencing `thing` which is in scope as A.thing and B.thing - what :: Int - what = thing +-- Error due to referencing `thing` which is in scope as A.thing and B.thing +what :: Int +what = thing diff --git a/examples/failing/ConflictingImports/A.purs b/examples/failing/ConflictingImports/A.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ConflictingImports/A.purs @@ -0,0 +1,4 @@ +module A where + +thing :: Int +thing = 1 diff --git a/examples/failing/ConflictingImports/B.purs b/examples/failing/ConflictingImports/B.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ConflictingImports/B.purs @@ -0,0 +1,4 @@ +module B where + +thing :: Int +thing = 2 diff --git a/examples/failing/ConflictingImports2.purs b/examples/failing/ConflictingImports2.purs --- a/examples/failing/ConflictingImports2.purs +++ b/examples/failing/ConflictingImports2.purs @@ -1,20 +1,10 @@ -- @shouldFailWith ScopeConflict -module A where - - thing :: Int - thing = 1 - -module B where - - thing :: Int - thing = 2 - module Main where - import A (thing) - import B (thing) +import A (thing) +import B (thing) - -- Error due to referencing `thing` which is explicitly in scope as A.thing - -- and B.thing - what :: Int - what = thing +-- Error due to referencing `thing` which is explicitly in scope as A.thing +-- and B.thing +what :: Int +what = thing diff --git a/examples/failing/ConflictingImports2/A.purs b/examples/failing/ConflictingImports2/A.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ConflictingImports2/A.purs @@ -0,0 +1,4 @@ +module A where + +thing :: Int +thing = 1 diff --git a/examples/failing/ConflictingImports2/B.purs b/examples/failing/ConflictingImports2/B.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ConflictingImports2/B.purs @@ -0,0 +1,4 @@ +module B where + +thing :: Int +thing = 2 diff --git a/examples/failing/ConflictingQualifiedImports.purs b/examples/failing/ConflictingQualifiedImports.purs --- a/examples/failing/ConflictingQualifiedImports.purs +++ b/examples/failing/ConflictingQualifiedImports.purs @@ -1,17 +1,7 @@ -- @shouldFailWith ScopeConflict -module A where - - thing :: Int - thing = 1 - -module B where - - thing :: Int - thing = 2 - module Main where - import A as X - import B as X +import A as X +import B as X - foo = X.thing +foo = X.thing diff --git a/examples/failing/ConflictingQualifiedImports/A.purs b/examples/failing/ConflictingQualifiedImports/A.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ConflictingQualifiedImports/A.purs @@ -0,0 +1,4 @@ +module A where + +thing :: Int +thing = 1 diff --git a/examples/failing/ConflictingQualifiedImports/B.purs b/examples/failing/ConflictingQualifiedImports/B.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ConflictingQualifiedImports/B.purs @@ -0,0 +1,4 @@ +module B where + +thing :: Int +thing = 2 diff --git a/examples/failing/ConflictingQualifiedImports2.purs b/examples/failing/ConflictingQualifiedImports2.purs --- a/examples/failing/ConflictingQualifiedImports2.purs +++ b/examples/failing/ConflictingQualifiedImports2.purs @@ -1,15 +1,5 @@ -- @shouldFailWith ScopeConflict -module A where - - thing :: Int - thing = 1 - -module B where - - thing :: Int - thing = 2 - module Main (module X) where - import A as X - import B as X +import A as X +import B as X diff --git a/examples/failing/ConflictingQualifiedImports2/A.purs b/examples/failing/ConflictingQualifiedImports2/A.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ConflictingQualifiedImports2/A.purs @@ -0,0 +1,4 @@ +module A where + +thing :: Int +thing = 1 diff --git a/examples/failing/ConflictingQualifiedImports2/B.purs b/examples/failing/ConflictingQualifiedImports2/B.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ConflictingQualifiedImports2/B.purs @@ -0,0 +1,4 @@ +module B where + +thing :: Int +thing = 2 diff --git a/examples/failing/DeclConflictClassCtor.purs b/examples/failing/DeclConflictClassCtor.purs new file mode 100644 --- /dev/null +++ b/examples/failing/DeclConflictClassCtor.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith DeclConflict +module Main where + +data T = Fail + +class Fail diff --git a/examples/failing/DeclConflictClassSynonym.purs b/examples/failing/DeclConflictClassSynonym.purs new file mode 100644 --- /dev/null +++ b/examples/failing/DeclConflictClassSynonym.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith DeclConflict +module Main where + +import Prelude + +type Fail = Unit + +class Fail diff --git a/examples/failing/DeclConflictClassType.purs b/examples/failing/DeclConflictClassType.purs new file mode 100644 --- /dev/null +++ b/examples/failing/DeclConflictClassType.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith DeclConflict +module Main where + +class Fail + +data Fail diff --git a/examples/failing/DeclConflictCtorClass.purs b/examples/failing/DeclConflictCtorClass.purs new file mode 100644 --- /dev/null +++ b/examples/failing/DeclConflictCtorClass.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith DeclConflict +module Main where + +class Fail + +data T = Fail diff --git a/examples/failing/DeclConflictCtorCtor.purs b/examples/failing/DeclConflictCtorCtor.purs new file mode 100644 --- /dev/null +++ b/examples/failing/DeclConflictCtorCtor.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith DeclConflict +module Main where + +data T1 = Fail + +data T2 = Fail diff --git a/examples/failing/DeclConflictSynonymClass.purs b/examples/failing/DeclConflictSynonymClass.purs new file mode 100644 --- /dev/null +++ b/examples/failing/DeclConflictSynonymClass.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith DeclConflict +module Main where + +import Prelude + +class Fail + +type Fail = Unit diff --git a/examples/failing/DeclConflictSynonymType.purs b/examples/failing/DeclConflictSynonymType.purs new file mode 100644 --- /dev/null +++ b/examples/failing/DeclConflictSynonymType.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith DeclConflict +module Main where + +import Prelude + +data Fail + +type Fail = Unit diff --git a/examples/failing/DeclConflictTypeClass.purs b/examples/failing/DeclConflictTypeClass.purs new file mode 100644 --- /dev/null +++ b/examples/failing/DeclConflictTypeClass.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith DeclConflict +module Main where + +class Fail + +data Fail diff --git a/examples/failing/DeclConflictTypeSynonym.purs b/examples/failing/DeclConflictTypeSynonym.purs new file mode 100644 --- /dev/null +++ b/examples/failing/DeclConflictTypeSynonym.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith DeclConflict +module Main where + +import Prelude + +type Fail = Unit + +data Fail diff --git a/examples/failing/DeclConflictTypeType.purs b/examples/failing/DeclConflictTypeType.purs new file mode 100644 --- /dev/null +++ b/examples/failing/DeclConflictTypeType.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith DeclConflict +module Main where + +data Fail + +data Fail diff --git a/examples/failing/Do.purs b/examples/failing/Do.purs --- a/examples/failing/Do.purs +++ b/examples/failing/Do.purs @@ -8,5 +8,5 @@ test2 y = do x <- y -test3 = do return 1 - return 2 +test3 = do pure 1 + pure 2 diff --git a/examples/failing/ExportConflictClass.purs b/examples/failing/ExportConflictClass.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ExportConflictClass.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith ExportConflict +module C (module A, module B) where + +import A as A +import B as B diff --git a/examples/failing/ExportConflictClass/A.purs b/examples/failing/ExportConflictClass/A.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ExportConflictClass/A.purs @@ -0,0 +1,3 @@ +module A where + +class X diff --git a/examples/failing/ExportConflictClass/B.purs b/examples/failing/ExportConflictClass/B.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ExportConflictClass/B.purs @@ -0,0 +1,3 @@ +module B where + +class X diff --git a/examples/failing/ExportConflictCtor.purs b/examples/failing/ExportConflictCtor.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ExportConflictCtor.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith ExportConflict +module C (module A, module B) where + +import A as A +import B as B diff --git a/examples/failing/ExportConflictCtor/A.purs b/examples/failing/ExportConflictCtor/A.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ExportConflictCtor/A.purs @@ -0,0 +1,3 @@ +module A where + +data T1 = X diff --git a/examples/failing/ExportConflictCtor/B.purs b/examples/failing/ExportConflictCtor/B.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ExportConflictCtor/B.purs @@ -0,0 +1,3 @@ +module B where + +data T2 = X diff --git a/examples/failing/ExportConflictType.purs b/examples/failing/ExportConflictType.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ExportConflictType.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith ExportConflict +module C (module A, module B) where + +import A as A +import B as B diff --git a/examples/failing/ExportConflictType/A.purs b/examples/failing/ExportConflictType/A.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ExportConflictType/A.purs @@ -0,0 +1,3 @@ +module A where + +data T diff --git a/examples/failing/ExportConflictType/B.purs b/examples/failing/ExportConflictType/B.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ExportConflictType/B.purs @@ -0,0 +1,3 @@ +module B where + +data T diff --git a/examples/failing/ExportConflictTypeOp.purs b/examples/failing/ExportConflictTypeOp.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ExportConflictTypeOp.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith ExportConflict +module C (module A, module B) where + +import A as A +import B as B diff --git a/examples/failing/ExportConflictTypeOp/A.purs b/examples/failing/ExportConflictTypeOp/A.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ExportConflictTypeOp/A.purs @@ -0,0 +1,5 @@ +module A where + +type T1 a b = a -> b + +infixr 4 type T1 as ?? diff --git a/examples/failing/ExportConflictTypeOp/B.purs b/examples/failing/ExportConflictTypeOp/B.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ExportConflictTypeOp/B.purs @@ -0,0 +1,5 @@ +module B where + +type T2 a b = a -> b + +infixr 4 type T2 as ?? diff --git a/examples/failing/ExportConflictValue.purs b/examples/failing/ExportConflictValue.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ExportConflictValue.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith ExportConflict +module C (module A, module B) where + +import A as A +import B as B diff --git a/examples/failing/ExportConflictValue/A.purs b/examples/failing/ExportConflictValue/A.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ExportConflictValue/A.purs @@ -0,0 +1,4 @@ +module A where + +x :: Boolean +x = true diff --git a/examples/failing/ExportConflictValue/B.purs b/examples/failing/ExportConflictValue/B.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ExportConflictValue/B.purs @@ -0,0 +1,4 @@ +module B where + +x :: Boolean +x = false diff --git a/examples/failing/ExportConflictValueOp.purs b/examples/failing/ExportConflictValueOp.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ExportConflictValueOp.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith ExportConflict +module C (module A, module B) where + +import A as A +import B as B diff --git a/examples/failing/ExportConflictValueOp/A.purs b/examples/failing/ExportConflictValueOp/A.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ExportConflictValueOp/A.purs @@ -0,0 +1,6 @@ +module A where + +f1 :: forall a b. a -> b -> a +f1 x _ = x + +infix 0 f1 as !! diff --git a/examples/failing/ExportConflictValueOp/B.purs b/examples/failing/ExportConflictValueOp/B.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ExportConflictValueOp/B.purs @@ -0,0 +1,6 @@ +module B where + +f2 :: forall a b. a -> b -> a +f2 x _ = x + +infix 0 f2 as !! diff --git a/examples/failing/ExportExplicit.purs b/examples/failing/ExportExplicit.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ExportExplicit.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith UnknownExport +-- should fail as z does not exist in the module +module M1 (x, y, z) where + +import Prelude + +x = 1 +y = 2 diff --git a/examples/failing/ExportExplicit1.purs b/examples/failing/ExportExplicit1.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ExportExplicit1.purs @@ -0,0 +1,12 @@ +-- @shouldFailWith UnknownName +module Main where + +import M1 +import Control.Monad.Eff.Console (log) + +testX = X + +-- should fail as Y constructor is not exported from M1 +testY = Y + +main = log "Done" diff --git a/examples/failing/ExportExplicit1/M1.purs b/examples/failing/ExportExplicit1/M1.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ExportExplicit1/M1.purs @@ -0,0 +1,3 @@ +module M1 (X(X)) where + +data X = X | Y diff --git a/examples/failing/ExportExplicit2.purs b/examples/failing/ExportExplicit2.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ExportExplicit2.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith UnknownExportDataConstructor +-- should fail as Y is not a data constructor for X +module M1 (X(Y)) where + +import Prelude + +data X = X +data Y = Y diff --git a/examples/failing/ExportExplicit3.purs b/examples/failing/ExportExplicit3.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ExportExplicit3.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith UnknownName +module Main where + +import M1 as M +import Control.Monad.Eff.Console (log) + +-- should fail as Z is not exported from M1 +testZ = M.Z + +main = log "Done" diff --git a/examples/failing/ExportExplicit3/M1.purs b/examples/failing/ExportExplicit3/M1.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ExportExplicit3/M1.purs @@ -0,0 +1,4 @@ +module M1 (X(..)) where + +data X = X | Y +data Z = Z diff --git a/examples/failing/ImportExplicit.purs b/examples/failing/ImportExplicit.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ImportExplicit.purs @@ -0,0 +1,4 @@ +-- @shouldFailWith UnknownImport +module Main where + +import M1 (X(..)) diff --git a/examples/failing/ImportExplicit/M1.purs b/examples/failing/ImportExplicit/M1.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ImportExplicit/M1.purs @@ -0,0 +1,3 @@ +module M1 where + +foo = "foo" diff --git a/examples/failing/ImportExplicit2.purs b/examples/failing/ImportExplicit2.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ImportExplicit2.purs @@ -0,0 +1,4 @@ +-- @shouldFailWith UnknownImportDataConstructor +module Main where + +import M1 (X(Z, Q)) diff --git a/examples/failing/ImportExplicit2/M1.purs b/examples/failing/ImportExplicit2/M1.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ImportExplicit2/M1.purs @@ -0,0 +1,3 @@ +module M1 where + +data X = Y diff --git a/examples/failing/ImportHidingModule.purs b/examples/failing/ImportHidingModule.purs --- a/examples/failing/ImportHidingModule.purs +++ b/examples/failing/ImportHidingModule.purs @@ -1,10 +1,4 @@ --- @shouldFailWith ImportHidingModule -module A where - x = 1 - -module B (module B, module A) where - import A - y = 1 - -module C where - import B hiding (module A) +-- @shouldFailWith ImportHidingModule +module Main where + +import B hiding (module A) diff --git a/examples/failing/ImportHidingModule/A.purs b/examples/failing/ImportHidingModule/A.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ImportHidingModule/A.purs @@ -0,0 +1,2 @@ +module A where +x = 1 diff --git a/examples/failing/ImportHidingModule/B.purs b/examples/failing/ImportHidingModule/B.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ImportHidingModule/B.purs @@ -0,0 +1,3 @@ +module B (module B, module A) where +import A +y = 1 diff --git a/examples/failing/ImportModule.purs b/examples/failing/ImportModule.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ImportModule.purs @@ -0,0 +1,4 @@ +-- @shouldFailWith UnknownName +module Main where + +import M1 diff --git a/examples/failing/ImportModule/M2.purs b/examples/failing/ImportModule/M2.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ImportModule/M2.purs @@ -0,0 +1,3 @@ +module M2 where + +data X = X diff --git a/examples/failing/InstanceExport.purs b/examples/failing/InstanceExport.purs --- a/examples/failing/InstanceExport.purs +++ b/examples/failing/InstanceExport.purs @@ -1,19 +1,7 @@ --- @shouldFailWith TransitiveExportError -module InstanceExport (S(..), f) where - -import Prelude - -newtype S = S String - -class F a where - f :: a -> String - -instance fs :: F S where - f (S s) = s - -module Test where - -import InstanceExport -import Prelude - -test = f $ S "Test" +-- @shouldFailWith TransitiveExportError +module Test where + +import InstanceExport +import Prelude + +test = f $ S "Test" diff --git a/examples/failing/InstanceExport/InstanceExport.purs b/examples/failing/InstanceExport/InstanceExport.purs new file mode 100644 --- /dev/null +++ b/examples/failing/InstanceExport/InstanceExport.purs @@ -0,0 +1,11 @@ +module InstanceExport (S(..), f) where + +import Prelude + +newtype S = S String + +class F a where + f :: a -> String + +instance fs :: F S where + f (S s) = s diff --git a/examples/failing/MissingClassMemberExport.purs b/examples/failing/MissingClassMemberExport.purs --- a/examples/failing/MissingClassMemberExport.purs +++ b/examples/failing/MissingClassMemberExport.purs @@ -1,5 +1,5 @@ -- @shouldFailWith TransitiveExportError -module Test (Foo) where +module Test (class Foo) where import Prelude diff --git a/examples/failing/MultipleErrors2.purs b/examples/failing/MultipleErrors2.purs --- a/examples/failing/MultipleErrors2.purs +++ b/examples/failing/MultipleErrors2.purs @@ -1,5 +1,5 @@ --- @shouldFailWith UnknownValue --- @shouldFailWith UnknownValue +-- @shouldFailWith UnknownName +-- @shouldFailWith UnknownName module MultipleErrors2 where import Prelude diff --git a/examples/failing/MultipleTypeOpFixities.purs b/examples/failing/MultipleTypeOpFixities.purs new file mode 100644 --- /dev/null +++ b/examples/failing/MultipleTypeOpFixities.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith MultipleTypeOpFixities +module MultipleTypeOpFixities where + +import Prelude + +type Op x y = Op x y + +infix 2 type Op as !? +infix 2 type Op as !? diff --git a/examples/failing/MultipleValueOpFixities.purs b/examples/failing/MultipleValueOpFixities.purs new file mode 100644 --- /dev/null +++ b/examples/failing/MultipleValueOpFixities.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith MultipleValueOpFixities +module MultipleValueOpFixities where + +import Prelude + +add x y = x + y + +infix 2 add as !? +infix 2 add as !? diff --git a/examples/failing/OrphanInstance.purs b/examples/failing/OrphanInstance.purs --- a/examples/failing/OrphanInstance.purs +++ b/examples/failing/OrphanInstance.purs @@ -1,12 +1,7 @@ --- @shouldFailWith OrphanInstance -module Class where - - class C a where - op :: a -> a - -module Test where - - import Class - - instance cBoolean :: C Boolean where - op a = a +-- @shouldFailWith OrphanInstance +module Test where + +import Class + +instance cBoolean :: C Boolean where + op a = a diff --git a/examples/failing/OrphanInstance/Class.purs b/examples/failing/OrphanInstance/Class.purs new file mode 100644 --- /dev/null +++ b/examples/failing/OrphanInstance/Class.purs @@ -0,0 +1,4 @@ +module Class where + +class C a where + op :: a -> a diff --git a/examples/failing/OrphanTypeDecl.purs b/examples/failing/OrphanTypeDecl.purs new file mode 100644 --- /dev/null +++ b/examples/failing/OrphanTypeDecl.purs @@ -0,0 +1,4 @@ +-- @shouldFailWith OrphanTypeDeclaration +module OrphanTypeDecl where + +fn :: Number -> Boolean diff --git a/examples/failing/OverlappingReExport.purs b/examples/failing/OverlappingReExport.purs deleted file mode 100644 --- a/examples/failing/OverlappingReExport.purs +++ /dev/null @@ -1,10 +0,0 @@ --- @shouldFailWith DuplicateValueExport -module A where - x = true - -module B where - x = false - -module C (module A, module M2) where - import A - import qualified B as M2 diff --git a/examples/failing/ProgrammableTypeErrors.purs b/examples/failing/ProgrammableTypeErrors.purs new file mode 100644 --- /dev/null +++ b/examples/failing/ProgrammableTypeErrors.purs @@ -0,0 +1,16 @@ +-- @shouldFailWith NoInstanceFound + +module Main where + +import Prelude +import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Console (log) + +class MyShow a where + myShow :: a -> String + +instance cannotShowFunctions :: Fail "Cannot show functions" => MyShow (a -> b) where + myShow _ = "unreachable" + +main :: Eff _ _ +main = log (myShow (_ + 1)) diff --git a/examples/failing/RequiredHiddenType.purs b/examples/failing/RequiredHiddenType.purs new file mode 100644 --- /dev/null +++ b/examples/failing/RequiredHiddenType.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith TransitiveExportError +-- exporting `a` should fail as `A` is hidden +module Foo (B(..), a, b) where + +data A = A +data B = B + +a = A +b = B diff --git a/examples/failing/RowConstructors1.purs b/examples/failing/RowConstructors1.purs --- a/examples/failing/RowConstructors1.purs +++ b/examples/failing/RowConstructors1.purs @@ -1,9 +1,9 @@ -- @shouldFailWith KindsDoNotUnify module Main where -import Prelude +import Control.Monad.Eff.Console (log) data Foo = Bar type Baz = { | Foo } -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/failing/RowConstructors2.purs b/examples/failing/RowConstructors2.purs --- a/examples/failing/RowConstructors2.purs +++ b/examples/failing/RowConstructors2.purs @@ -1,9 +1,9 @@ -- @shouldFailWith KindsDoNotUnify module Main where -import Prelude +import Control.Monad.Eff.Console (log) type Foo r = (x :: Number | r) type Bar = { | Foo } -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/failing/RowConstructors3.purs b/examples/failing/RowConstructors3.purs --- a/examples/failing/RowConstructors3.purs +++ b/examples/failing/RowConstructors3.purs @@ -1,9 +1,9 @@ -- @shouldFailWith KindsDoNotUnify module Main where -import Prelude +import Control.Monad.Eff.Console (log) type Foo = { x :: Number } type Bar = { | Foo } -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/failing/SkolemEscape2.purs b/examples/failing/SkolemEscape2.purs --- a/examples/failing/SkolemEscape2.purs +++ b/examples/failing/SkolemEscape2.purs @@ -7,4 +7,4 @@ test _ = do r <- runST (newSTRef 0) - return 0 + pure 0 diff --git a/examples/failing/SuggestComposition.purs b/examples/failing/SuggestComposition.purs --- a/examples/failing/SuggestComposition.purs +++ b/examples/failing/SuggestComposition.purs @@ -4,4 +4,4 @@ import Prelude -f = g . g where g = (+1) +f = g . g where g = (_ + 1) diff --git a/examples/failing/Superclasses5.purs b/examples/failing/Superclasses5.purs --- a/examples/failing/Superclasses5.purs +++ b/examples/failing/Superclasses5.purs @@ -3,6 +3,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (logShow) class Su a where su :: a -> a @@ -22,4 +23,4 @@ test :: forall a. (Cl a) => a -> Array a test x = su [cl x x] -main = Control.Monad.Eff.Console.print $ test 10.0 +main = logShow $ test 10.0 diff --git a/examples/failing/TypeError.purs b/examples/failing/TypeError.purs --- a/examples/failing/TypeError.purs +++ b/examples/failing/TypeError.purs @@ -3,4 +3,4 @@ import Prelude -test = 1 ++ "A" +test = 1 <> "A" diff --git a/examples/failing/TypedBinders.purs b/examples/failing/TypedBinders.purs --- a/examples/failing/TypedBinders.purs +++ b/examples/failing/TypedBinders.purs @@ -1,10 +1,10 @@ --- @shouldFailWith ErrorParsingModule +-- @shouldFailWith ErrorParsingModule module Main where -import Prelude +import Control.Monad.Eff.Console (log) test = (\f :: Int -> Int -> f 10) id main = do let t1 = test - Control.Monad.Eff.Console.log "Done" + log "Done" diff --git a/examples/failing/TypedBinders2.purs b/examples/failing/TypedBinders2.purs --- a/examples/failing/TypedBinders2.purs +++ b/examples/failing/TypedBinders2.purs @@ -2,8 +2,8 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) main = do - s :: String <- Control.Monad.Eff.Console.log "Foo" - Control.Monad.Eff.Console.log "Done" - + s :: String <- log "Foo" + log "Done" diff --git a/examples/failing/TypedBinders3.purs b/examples/failing/TypedBinders3.purs --- a/examples/failing/TypedBinders3.purs +++ b/examples/failing/TypedBinders3.purs @@ -2,6 +2,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) test = case 1 of (0 :: String) -> true @@ -9,4 +10,4 @@ main = do let t = test - Control.Monad.Eff.Console.log "Done" + log "Done" diff --git a/examples/failing/UnderscoreModuleName.purs b/examples/failing/UnderscoreModuleName.purs --- a/examples/failing/UnderscoreModuleName.purs +++ b/examples/failing/UnderscoreModuleName.purs @@ -1,6 +1,6 @@ -- @shouldFailWith ErrorParsingModule module Bad_Module where -import Prelude +import Control.Monad.Eff.Console (log) -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/failing/UnknownType.purs b/examples/failing/UnknownType.purs --- a/examples/failing/UnknownType.purs +++ b/examples/failing/UnknownType.purs @@ -1,4 +1,4 @@ --- @shouldFailWith UnknownType +-- @shouldFailWith UnknownName module Main where import Prelude diff --git a/examples/passing/1185.purs b/examples/passing/1185.purs --- a/examples/passing/1185.purs +++ b/examples/passing/1185.purs @@ -1,5 +1,7 @@ module Main where +import Control.Monad.Eff.Console (log) + data Person = Person String Boolean getName :: Person -> String @@ -10,4 +12,4 @@ name :: String name = getName (Person "John Smith" true) -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/1335.purs b/examples/passing/1335.purs --- a/examples/passing/1335.purs +++ b/examples/passing/1335.purs @@ -1,12 +1,14 @@ -module Main where - -import Prelude -import Control.Monad.Eff.Console (log) - -x :: forall a. a -> String -x a = y "Done" - where - y :: forall a. (Show a) => a -> String - y a = show (a :: a) - -main = log (x 0) +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +x :: forall a. a -> String +x a = y "Test" + where + y :: forall a. (Show a) => a -> String + y a = show (a :: a) + +main = do + log (x 0) + log "Done" diff --git a/examples/passing/1570.purs b/examples/passing/1570.purs --- a/examples/passing/1570.purs +++ b/examples/passing/1570.purs @@ -1,6 +1,8 @@ module Main where +import Control.Monad.Eff.Console (log) + test :: forall a. a -> a test = \(x :: a) -> x -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/1664.purs b/examples/passing/1664.purs --- a/examples/passing/1664.purs +++ b/examples/passing/1664.purs @@ -11,6 +11,6 @@ test :: forall e a. IdentityEff e a -> IdentityEff e Unit test (IdentityEff action) = IdentityEff $ do (Identity x :: Identity _) <- action - return $ Identity unit + pure $ Identity unit main = log "Done" diff --git a/examples/passing/1697.purs b/examples/passing/1697.purs --- a/examples/passing/1697.purs +++ b/examples/passing/1697.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) _2 :: forall a. a -> a _2 a = a @@ -21,4 +22,4 @@ let tmp = _2 1 pure unit -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/1881.purs b/examples/passing/1881.purs new file mode 100644 --- /dev/null +++ b/examples/passing/1881.purs @@ -0,0 +1,19 @@ +module Main where + +import Control.Monad.Eff.Console (log) + +foo = + 1 + +bar + = 2 + +baz + = + 3 + +qux + = + 3 + +main = log "Done" diff --git a/examples/passing/1991.purs b/examples/passing/1991.purs --- a/examples/passing/1991.purs +++ b/examples/passing/1991.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) singleton :: forall a. a -> Array a singleton x = [x] @@ -10,11 +11,12 @@ foldMap :: forall a m. (Semigroup m) => (a -> m) -> Array a -> m foldMap f [a, b, c, d, e] = f a <> f b <> f c <> f d <> f e +foldMap f xs = foldMap f xs -- spin, not used regression :: Array Int regression = let as = [1,2,3,4,5] as' = foldMap (\x -> if 1 < x && x < 4 then singleton x else empty) as in as' - -main = Control.Monad.Eff.Console.log "Done" + +main = log "Done" diff --git a/examples/passing/2018.purs b/examples/passing/2018.purs --- a/examples/passing/2018.purs +++ b/examples/passing/2018.purs @@ -1,15 +1,3 @@ -module B where - - data Foo = X | Y - -module A where - - import B as Main - - -- Prior to the 2018 fix this would be detected as a cycle between A and Main. - foo ∷ Main.Foo → Main.Foo - foo x = x - module Main where import Prelude @@ -22,4 +10,3 @@ main = do let tmp = foo X log "Done" - diff --git a/examples/passing/2018/A.purs b/examples/passing/2018/A.purs new file mode 100644 --- /dev/null +++ b/examples/passing/2018/A.purs @@ -0,0 +1,7 @@ +module A where + +import B as Main + +-- Prior to the 2018 fix this would be detected as a cycle between A and Main. +foo ∷ Main.Foo → Main.Foo +foo x = x diff --git a/examples/passing/2018/B.purs b/examples/passing/2018/B.purs new file mode 100644 --- /dev/null +++ b/examples/passing/2018/B.purs @@ -0,0 +1,3 @@ +module B where + +data Foo = X | Y diff --git a/examples/passing/2049.purs b/examples/passing/2049.purs new file mode 100644 --- /dev/null +++ b/examples/passing/2049.purs @@ -0,0 +1,14 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +data List a = Cons a (List a) | Nil + +infixr 6 Cons as : + +f :: List { x :: Int, y :: Int } -> Int +f ( r@{ x } : _) = x + r.y +f _ = 0 + +main = log "Done" diff --git a/examples/passing/2138.purs b/examples/passing/2138.purs new file mode 100644 --- /dev/null +++ b/examples/passing/2138.purs @@ -0,0 +1,7 @@ +module Main where + +import Control.Monad.Eff.Console (log) + +import Lib (A(B,C)) + +main = log "Done" diff --git a/examples/passing/2138/Lib.purs b/examples/passing/2138/Lib.purs new file mode 100644 --- /dev/null +++ b/examples/passing/2138/Lib.purs @@ -0,0 +1,3 @@ +module Lib (A(..), A) where + +data A = B | C diff --git a/examples/passing/2172.js b/examples/passing/2172.js new file mode 100644 --- /dev/null +++ b/examples/passing/2172.js @@ -0,0 +1,5 @@ +exports['a\''] = 0; +exports["\x62\x27"] = 1; +// NOTE: I wanted to use "\c'" here, but langauge-javascript doesn't support it... +exports["c'"] = 2; +exports["\u0064\u0027"] = 3; diff --git a/examples/passing/2172.purs b/examples/passing/2172.purs new file mode 100644 --- /dev/null +++ b/examples/passing/2172.purs @@ -0,0 +1,10 @@ +module Main where + +import Control.Monad.Eff.Console (log) + +foreign import a' :: Number +foreign import b' :: Number +foreign import c' :: Number +foreign import d' :: Number + +main = log "Done" diff --git a/examples/passing/652.purs b/examples/passing/652.purs --- a/examples/passing/652.purs +++ b/examples/passing/652.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) class Foo a b @@ -14,4 +15,4 @@ instance baz :: (Eq a) => Baz (a -> b) a b -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/810.purs b/examples/passing/810.purs --- a/examples/passing/810.purs +++ b/examples/passing/810.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data Maybe a = Nothing | Just a @@ -10,4 +11,4 @@ o = case m of Nothing -> { x : Nothing } Just a -> { x : Just a } -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/Applicative.purs b/examples/passing/Applicative.purs --- a/examples/passing/Applicative.purs +++ b/examples/passing/Applicative.purs @@ -1,6 +1,6 @@ module Main where -import Prelude () +import Control.Monad.Eff.Console (log) class Applicative f where pure :: forall a. a -> f a @@ -13,4 +13,4 @@ apply (Just f) (Just a) = Just (f a) apply _ _ = Nothing -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/ArrayType.purs b/examples/passing/ArrayType.purs --- a/examples/passing/ArrayType.purs +++ b/examples/passing/ArrayType.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) class Pointed p where point :: forall a. a -> p a @@ -8,4 +9,4 @@ instance pointedArray :: Pointed Array where point a = [a] -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/Auto.purs b/examples/passing/Auto.purs --- a/examples/passing/Auto.purs +++ b/examples/passing/Auto.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data Auto s i o = Auto { state :: s, step :: s -> i -> o } @@ -12,4 +13,4 @@ run :: forall i o. SomeAuto i o -> i -> o run = \s i -> s (\a -> case a of Auto a -> a.step a.state i) -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/AutoPrelude.purs b/examples/passing/AutoPrelude.purs --- a/examples/passing/AutoPrelude.purs +++ b/examples/passing/AutoPrelude.purs @@ -1,9 +1,11 @@ -module Main where - -import Prelude -import Control.Monad.Eff.Console - -f x = x * 10.0 -g y = y - 10.0 - -main = log $ show $ (f <<< g) 100.0 +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +f x = x * 10.0 +g y = y - 10.0 + +main = do + log $ show $ (f <<< g) 100.0 + log "Done" diff --git a/examples/passing/AutoPrelude2.purs b/examples/passing/AutoPrelude2.purs --- a/examples/passing/AutoPrelude2.purs +++ b/examples/passing/AutoPrelude2.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import qualified Prelude as P +import Prelude as P import Control.Monad.Eff.Console f :: forall a. a -> a diff --git a/examples/passing/BindersInFunctions.purs b/examples/passing/BindersInFunctions.purs --- a/examples/passing/BindersInFunctions.purs +++ b/examples/passing/BindersInFunctions.purs @@ -1,11 +1,16 @@ module Main where import Prelude -import Test.Assert +import Partial.Unsafe (unsafePartial) +import Test.Assert (assert') +import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Console (log) +snd :: forall a. Partial => Array a -> a snd = \[_, y] -> y +main :: Eff _ _ main = do - let ts = snd [1.0, 2.0] + let ts = unsafePartial (snd [1.0, 2.0]) assert' "Incorrect result from 'snd'." (ts == 2.0) - Control.Monad.Eff.Console.log "Done" + log "Done" diff --git a/examples/passing/BindingGroups.purs b/examples/passing/BindingGroups.purs --- a/examples/passing/BindingGroups.purs +++ b/examples/passing/BindingGroups.purs @@ -1,10 +1,11 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) foo = bar where bar r = r + 1.0 r = foo 2.0 -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/BlockString.purs b/examples/passing/BlockString.purs --- a/examples/passing/BlockString.purs +++ b/examples/passing/BlockString.purs @@ -1,8 +1,9 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) foo :: String foo = """foo""" -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/CaseInDo.purs b/examples/passing/CaseInDo.purs --- a/examples/passing/CaseInDo.purs +++ b/examples/passing/CaseInDo.purs @@ -1,19 +1,21 @@ module Main where import Prelude +import Partial.Unsafe (unsafeCrashWith) import Control.Monad.Eff.Console import Control.Monad.Eff doIt :: forall eff. Eff eff Boolean -doIt = return true +doIt = pure true set = do log "Testing..." case 0 of 0 -> doIt - _ -> return false + _ -> pure false main = do b <- set case b of true -> log "Done" + false -> unsafeCrashWith "Failed" diff --git a/examples/passing/CaseMultipleExpressions.purs b/examples/passing/CaseMultipleExpressions.purs --- a/examples/passing/CaseMultipleExpressions.purs +++ b/examples/passing/CaseMultipleExpressions.purs @@ -1,19 +1,21 @@ module Main where import Prelude +import Partial.Unsafe (unsafeCrashWith) import Control.Monad.Eff.Console import Control.Monad.Eff doIt :: forall eff. Eff eff Boolean -doIt = return true +doIt = pure true set = do log "Testing..." case 42, 10 of 42, 10 -> doIt - _ , _ -> return false + _ , _ -> pure false main = do b <- set case b of true -> log "Done" + false -> unsafeCrashWith "Failed" diff --git a/examples/passing/CaseStatement.purs b/examples/passing/CaseStatement.purs --- a/examples/passing/CaseStatement.purs +++ b/examples/passing/CaseStatement.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data A = A | B | C @@ -18,4 +19,4 @@ h f a N = a h f (J a) (J b) = J (f a b) -main = Control.Monad.Eff.Console.log $ f "Done" "Failed" A +main = log $ f "Done" "Failed" A diff --git a/examples/passing/CheckFunction.purs b/examples/passing/CheckFunction.purs --- a/examples/passing/CheckFunction.purs +++ b/examples/passing/CheckFunction.purs @@ -1,7 +1,8 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) test = ((\x -> x+1.0) >>> (\x -> x*2.0)) 4.0 -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/CheckSynonymBug.purs b/examples/passing/CheckSynonymBug.purs --- a/examples/passing/CheckSynonymBug.purs +++ b/examples/passing/CheckSynonymBug.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) length :: forall a. Array a -> Int length _ = 0 @@ -9,4 +10,4 @@ foo _ = length ([] :: Foo Number) -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/CheckTypeClass.purs b/examples/passing/CheckTypeClass.purs --- a/examples/passing/CheckTypeClass.purs +++ b/examples/passing/CheckTypeClass.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data Bar a = Bar data Baz @@ -14,5 +15,4 @@ mkBar :: forall a. a -> Bar a mkBar _ = Bar -main = Control.Monad.Eff.Console.log "Done" - +main = log "Done" diff --git a/examples/passing/Church.purs b/examples/passing/Church.purs --- a/examples/passing/Church.purs +++ b/examples/passing/Church.purs @@ -1,6 +1,6 @@ module Main where -import Prelude () +import Control.Monad.Eff.Console (log) type List a = forall r. r -> (a -> r -> r) -> r @@ -15,4 +15,4 @@ test = append (cons 1 empty) (cons 2 empty) -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/ClassRefSyntax.purs b/examples/passing/ClassRefSyntax.purs --- a/examples/passing/ClassRefSyntax.purs +++ b/examples/passing/ClassRefSyntax.purs @@ -1,13 +1,9 @@ -module Lib (class X, go) where - - class X a where - go :: a -> a - module Main where - import Lib (class X, go) +import Lib (class X, go) +import Control.Monad.Eff.Console (log) - go' :: forall a. (X a) => a -> a - go' = go +go' :: forall a. (X a) => a -> a +go' = go - main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/ClassRefSyntax/Lib.purs b/examples/passing/ClassRefSyntax/Lib.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ClassRefSyntax/Lib.purs @@ -0,0 +1,4 @@ +module Lib (class X, go) where + +class X a where + go :: a -> a diff --git a/examples/passing/Collatz.purs b/examples/passing/Collatz.purs --- a/examples/passing/Collatz.purs +++ b/examples/passing/Collatz.purs @@ -3,6 +3,7 @@ import Prelude import Control.Monad.Eff import Control.Monad.ST +import Control.Monad.Eff.Console (log, logShow) collatz :: Int -> Int collatz n = runPure (runST (do @@ -12,7 +13,9 @@ modifySTRef count $ (+) 1 m <- readSTRef r writeSTRef r $ if m `mod` 2 == 0 then m / 2 else 3 * m + 1 - return $ m == 1 + pure $ m == 1 readSTRef count)) -main = Control.Monad.Eff.Console.print $ collatz 1000 +main = do + logShow $ collatz 1000 + log "Done" diff --git a/examples/passing/Comparisons.purs b/examples/passing/Comparisons.purs --- a/examples/passing/Comparisons.purs +++ b/examples/passing/Comparisons.purs @@ -1,15 +1,15 @@ -module Main where - -import Prelude -import Control.Monad.Eff -import Control.Monad.Eff.Console -import Test.Assert - -main = do - assert (1.0 < 2.0) - assert (2.0 == 2.0) - assert (3.0 > 1.0) - assert ("a" < "b") - assert ("a" == "a") - assert ("z" > "a") - log "Done!" +module Main where + +import Prelude +import Control.Monad.Eff +import Control.Monad.Eff.Console +import Test.Assert + +main = do + assert (1.0 < 2.0) + assert (2.0 == 2.0) + assert (3.0 > 1.0) + assert ("a" < "b") + assert ("a" == "a") + assert ("z" > "a") + log "Done" diff --git a/examples/passing/Conditional.purs b/examples/passing/Conditional.purs --- a/examples/passing/Conditional.purs +++ b/examples/passing/Conditional.purs @@ -1,9 +1,9 @@ module Main where -import Prelude () +import Control.Monad.Eff.Console (log) fns = \f -> if f true then f else \x -> x not = \x -> if x then false else true -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/Console.purs b/examples/passing/Console.purs --- a/examples/passing/Console.purs +++ b/examples/passing/Console.purs @@ -5,9 +5,11 @@ import Control.Monad.Eff.Console replicateM_ :: forall m a. (Monad m) => Number -> m a -> m {} -replicateM_ 0.0 _ = return {} +replicateM_ 0.0 _ = pure {} replicateM_ n act = do act replicateM_ (n - 1.0) act -main = replicateM_ 10.0 (log "Hello World!") +main = do + replicateM_ 10.0 (log "Hello World!") + log "Done" diff --git a/examples/passing/ConstraintInference.purs b/examples/passing/ConstraintInference.purs --- a/examples/passing/ConstraintInference.purs +++ b/examples/passing/ConstraintInference.purs @@ -1,7 +1,10 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) -shout = Control.Monad.Eff.Console.log <<< (<> "!") <<< show +shout = log <<< (_ <> "!") <<< show -main = shout "Done" +main = do + shout "Test" + log "Done" diff --git a/examples/passing/ContextSimplification.purs b/examples/passing/ContextSimplification.purs --- a/examples/passing/ContextSimplification.purs +++ b/examples/passing/ContextSimplification.purs @@ -3,11 +3,13 @@ import Prelude import Control.Monad.Eff.Console -shout = log <<< (<> "!") <<< show +shout = log <<< (_ <> "!") <<< show -- Here, we should simplify the context so that only one Show -- constraint is added. usesShowTwice true = shout -usesShowTwice false = print +usesShowTwice false = logShow -main = usesShowTwice true "Done" +main = do + usesShowTwice true "Test" + log "Done" diff --git a/examples/passing/DataAndType.purs b/examples/passing/DataAndType.purs --- a/examples/passing/DataAndType.purs +++ b/examples/passing/DataAndType.purs @@ -1,9 +1,10 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data A = A B type B = A -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/DctorOperatorAlias.purs b/examples/passing/DctorOperatorAlias.purs --- a/examples/passing/DctorOperatorAlias.purs +++ b/examples/passing/DctorOperatorAlias.purs @@ -1,17 +1,11 @@ -module Data.List where - - data List a = Cons a (List a) | Nil - - infixr 6 Cons as : - module Main where import Prelude (Unit, bind, (==)) import Control.Monad.Eff (Eff) import Control.Monad.Eff.Console (CONSOLE, log) import Test.Assert (ASSERT, assert') - import Data.List (List(..), (:)) - import Data.List as L + import List (List(..), (:)) + import List as L -- unqualified infixl 6 Cons as ! diff --git a/examples/passing/DctorOperatorAlias/List.purs b/examples/passing/DctorOperatorAlias/List.purs new file mode 100644 --- /dev/null +++ b/examples/passing/DctorOperatorAlias/List.purs @@ -0,0 +1,5 @@ +module List where + +data List a = Cons a (List a) | Nil + +infixr 6 Cons as : diff --git a/examples/passing/DeepArrayBinder.purs b/examples/passing/DeepArrayBinder.purs --- a/examples/passing/DeepArrayBinder.purs +++ b/examples/passing/DeepArrayBinder.purs @@ -2,6 +2,7 @@ import Prelude import Control.Monad.Eff +import Control.Monad.Eff.Console (log) import Test.Assert data List a = Cons a (List a) | Nil @@ -13,4 +14,4 @@ main = do let result = match2 (Cons 1.0 (Cons 2.0 (Cons 3.0 (Cons 4.0 (Cons 5.0 (Cons 6.0 (Cons 7.0 (Cons 8.0 (Cons 9.0 Nil))))))))) assert' "Incorrect result!" (result == 100.0) - Control.Monad.Eff.Console.log "Done" + log "Done" diff --git a/examples/passing/DeepCase.purs b/examples/passing/DeepCase.purs --- a/examples/passing/DeepCase.purs +++ b/examples/passing/DeepCase.purs @@ -1,9 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console -import Control.Monad.Eff -import Control.Monad.ST +import Control.Monad.Eff.Console (log, logShow) f x y = let @@ -12,4 +10,6 @@ x -> 1.0 + x * x in g + x + y -main = print $ f 1.0 10.0 +main = do + logShow $ f 1.0 10.0 + log "Done" diff --git a/examples/passing/Deriving.purs b/examples/passing/Deriving.purs --- a/examples/passing/Deriving.purs +++ b/examples/passing/Deriving.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) import Test.Assert data V @@ -27,5 +28,7 @@ assert $ X 0 < X 1 assert $ X 0 < Y "Foo" assert $ Y "Bar" < Y "Baz" - assert $ z == z where - z = Z { left: X 0, right: Y "Foo" } + assert $ z == z + log "Done" + where + z = Z { left: X 0, right: Y "Foo" } diff --git a/examples/passing/Do.purs b/examples/passing/Do.purs --- a/examples/passing/Do.purs +++ b/examples/passing/Do.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data Maybe a = Nothing | Just a @@ -19,7 +20,7 @@ bind Nothing _ = Nothing bind (Just a) f = f a -instance monadMaybe :: Prelude.Monad Maybe +instance monadMaybe :: Monad Maybe test1 = \_ -> do Just "abc" @@ -64,4 +65,4 @@ g x = f x / 2.0 Just (f 10.0) -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/Dollar.purs b/examples/passing/Dollar.purs --- a/examples/passing/Dollar.purs +++ b/examples/passing/Dollar.purs @@ -1,11 +1,11 @@ module Main where -import Prelude () +import Control.Monad.Eff.Console (log) -($) :: forall a b. (a -> b) -> a -> b -($) f x = f x +applyFn :: forall a b. (a -> b) -> a -> b +applyFn f x = f x -infixr 1000 $ +infixr 1000 applyFn as $ id x = x @@ -13,4 +13,4 @@ test2 x = id id $ id x -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/Eff.purs b/examples/passing/Eff.purs --- a/examples/passing/Eff.purs +++ b/examples/passing/Eff.purs @@ -3,7 +3,7 @@ import Prelude import Control.Monad.Eff import Control.Monad.ST -import Control.Monad.Eff.Console +import Control.Monad.Eff.Console (log, logShow) test1 = do log "Line 1" @@ -21,5 +21,6 @@ main = do test1 - Control.Monad.Eff.Console.print test2 - Control.Monad.Eff.Console.print test3 + logShow test2 + logShow test3 + log "Done" diff --git a/examples/passing/EmptyDataDecls.purs b/examples/passing/EmptyDataDecls.purs --- a/examples/passing/EmptyDataDecls.purs +++ b/examples/passing/EmptyDataDecls.purs @@ -2,6 +2,7 @@ import Prelude import Test.Assert +import Control.Monad.Eff.Console (log) data Z data S n @@ -15,5 +16,5 @@ cons' x (ArrayBox xs) = ArrayBox $ append [x] xs main = case cons' 1 $ cons' 2 $ cons' 3 nil of - ArrayBox [1, 2, 3] -> Control.Monad.Eff.Console.log "Done" + ArrayBox [1, 2, 3] -> log "Done" _ -> assert' "Failed" false diff --git a/examples/passing/EmptyRow.purs b/examples/passing/EmptyRow.purs --- a/examples/passing/EmptyRow.purs +++ b/examples/passing/EmptyRow.purs @@ -1,10 +1,11 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data Foo r = Foo { | r } test :: Foo () test = Foo {} -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/EmptyTypeClass.purs b/examples/passing/EmptyTypeClass.purs --- a/examples/passing/EmptyTypeClass.purs +++ b/examples/passing/EmptyTypeClass.purs @@ -1,12 +1,11 @@ module Main where import Prelude - -class PartialP +import Control.Monad.Eff +import Control.Monad.Eff.Console -head :: forall a. (PartialP) => Array a -> a +head :: forall a. Partial => Array a -> a head [x] = x -instance allowPartials :: PartialP - -main = Control.Monad.Eff.Console.log $ head ["Done"] +main :: Eff _ _ +main = log "Done" diff --git a/examples/passing/EqOrd.purs b/examples/passing/EqOrd.purs --- a/examples/passing/EqOrd.purs +++ b/examples/passing/EqOrd.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log, logShow) data Pair a b = Pair a b @@ -12,4 +13,6 @@ instance eqPair :: (Eq a, Eq b) => Eq (Pair a b) where eq (Pair a1 b1) (Pair a2 b2) = a1 == a2 && b1 == b2 -main = Control.Monad.Eff.Console.print $ Pair 1.0 2.0 == Pair 1.0 2.0 +main = do + logShow $ Pair 1.0 2.0 == Pair 1.0 2.0 + log "Done" diff --git a/examples/passing/ExplicitImportReExport.purs b/examples/passing/ExplicitImportReExport.purs --- a/examples/passing/ExplicitImportReExport.purs +++ b/examples/passing/ExplicitImportReExport.purs @@ -1,16 +1,11 @@ --- from #1244 -module Foo where - - foo :: Int - foo = 3 - -module Bar (module Foo) where - - import Foo - -module Baz where - - import Bar (foo) - - baz :: Int - baz = foo +-- from #1244 +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) +import Bar (foo) + +baz :: Int +baz = foo + +main = log "Done" diff --git a/examples/passing/ExplicitImportReExport/Bar.purs b/examples/passing/ExplicitImportReExport/Bar.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ExplicitImportReExport/Bar.purs @@ -0,0 +1,3 @@ +module Bar (module Foo) where + +import Foo diff --git a/examples/passing/ExplicitImportReExport/Foo.purs b/examples/passing/ExplicitImportReExport/Foo.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ExplicitImportReExport/Foo.purs @@ -0,0 +1,4 @@ +module Foo where + +foo :: Int +foo = 3 diff --git a/examples/passing/ExplicitOperatorSections.purs b/examples/passing/ExplicitOperatorSections.purs --- a/examples/passing/ExplicitOperatorSections.purs +++ b/examples/passing/ExplicitOperatorSections.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) subtractOne :: Int -> Int subtractOne = (_ - 1) @@ -11,4 +12,4 @@ named :: Int -> Int named = (_ `sub` 1) -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/ExportExplicit.purs b/examples/passing/ExportExplicit.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ExportExplicit.purs @@ -0,0 +1,10 @@ +module Main where + +import M1 +import Control.Monad.Eff.Console (log) + +testX = X +testZ = Z +testFoo = foo + +main = log "Done" diff --git a/examples/passing/ExportExplicit/M1.purs b/examples/passing/ExportExplicit/M1.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ExportExplicit/M1.purs @@ -0,0 +1,10 @@ +module M1 (X(X), Z(..), foo) where + +data X = X | Y +data Z = Z + +foo :: Int +foo = 0 + +bar :: Int +bar = 1 diff --git a/examples/passing/ExportExplicit2.purs b/examples/passing/ExportExplicit2.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ExportExplicit2.purs @@ -0,0 +1,8 @@ +module Main where + +import M1 +import Control.Monad.Eff.Console (log) + +testBar = bar + +main = log "Done" diff --git a/examples/passing/ExportExplicit2/M1.purs b/examples/passing/ExportExplicit2/M1.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ExportExplicit2/M1.purs @@ -0,0 +1,7 @@ +module M1 (bar) where + +foo :: Int +foo = 0 + +bar :: Int +bar = foo diff --git a/examples/passing/ExportedInstanceDeclarations.purs b/examples/passing/ExportedInstanceDeclarations.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ExportedInstanceDeclarations.purs @@ -0,0 +1,45 @@ +-- Tests that instances for non-exported classes / types do not appear in the +-- result of `exportedDeclarations`. +module Main + ( Const(..) + , class Foo + , foo + , main + ) where + +import Prelude +import Control.Monad.Eff.Console (log) + +data Const a b = Const a + +class Foo a where + foo :: a + +data NonexportedType = NonexportedType + +class NonexportedClass a where + notExported :: a + +-- There are three places that a nonexported type or type class can occur, +-- leading an instance to count as non-exported: +-- * Constraints +-- * The type class itself +-- * The instance types + +-- Case 1: constraints +instance nonExportedFoo :: (NonexportedClass a) => Foo a where + foo = notExported + +-- Another instance of case 1: +instance nonExportedFoo2 :: (Foo NonexportedType) => Foo (a -> a) where + foo = id + +-- Case 2: type class +instance nonExportedNonexportedType :: NonexportedClass (Const Int a) where + notExported = Const 0 + +-- Case 3: instance types +instance constFoo :: Foo (Const NonexportedType b) where + foo = Const NonexportedType + +main = log "Done" diff --git a/examples/passing/ExtendedInfixOperators.purs b/examples/passing/ExtendedInfixOperators.purs --- a/examples/passing/ExtendedInfixOperators.purs +++ b/examples/passing/ExtendedInfixOperators.purs @@ -1,9 +1,11 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log, logShow) +import Data.Function (on) comparing :: forall a b. (Ord b) => (a -> b) -> a -> a -> Ordering -comparing f = compare `Data.Function.on` f +comparing f = compare `on` f null [] = true null _ = false @@ -11,4 +13,5 @@ test = [1.0, 2.0, 3.0] `comparing null` [4.0, 5.0, 6.0] main = do - Control.Monad.Eff.Console.print test + logShow test + log "Done" diff --git a/examples/passing/Fib.purs b/examples/passing/Fib.purs --- a/examples/passing/Fib.purs +++ b/examples/passing/Fib.purs @@ -1,15 +1,18 @@ module Main where import Prelude -import Control.Monad.Eff -import Control.Monad.ST +import Control.Monad.Eff (whileE) +import Control.Monad.Eff.Console (log, logShow) +import Control.Monad.ST (runST, newSTRef, readSTRef, writeSTRef) -main = runST (do - n1 <- newSTRef 1.0 - n2 <- newSTRef 1.0 - whileE ((>) 1000.0 <$> readSTRef n1) $ do - n1' <- readSTRef n1 - n2' <- readSTRef n2 - writeSTRef n2 $ n1' + n2' - writeSTRef n1 n2' - Control.Monad.Eff.Console.print n2') +main = do + runST do + n1 <- newSTRef 1.0 + n2 <- newSTRef 1.0 + whileE ((>) 1000.0 <$> readSTRef n1) $ do + n1' <- readSTRef n1 + n2' <- readSTRef n2 + writeSTRef n2 $ n1' + n2' + writeSTRef n1 n2' + logShow n2' + log "Done" diff --git a/examples/passing/FieldConsPuns.purs b/examples/passing/FieldConsPuns.purs --- a/examples/passing/FieldConsPuns.purs +++ b/examples/passing/FieldConsPuns.purs @@ -1,10 +1,13 @@ -module Main where - -import Prelude -import Control.Monad.Eff.Console - -greet { greeting, name } = log $ greeting <> ", " <> name <> "." - -main = greet { greeting, name} where - greeting = "Hello" - name = "World" +module Main where + +import Prelude +import Control.Monad.Eff.Console (log, logShow) + +greet { greeting, name } = log $ greeting <> ", " <> name <> "." + +main = do + greet { greeting, name } + log "Done" + where + greeting = "Hello" + name = "World" diff --git a/examples/passing/FieldPuns.purs b/examples/passing/FieldPuns.purs --- a/examples/passing/FieldPuns.purs +++ b/examples/passing/FieldPuns.purs @@ -1,8 +1,10 @@ -module Main where - -import Prelude -import Control.Monad.Eff.Console - -greet { greeting, name } = log $ greeting <> ", " <> name <> "." - -main = greet { greeting: "Hello", name: "World" } +module Main where + +import Prelude +import Control.Monad.Eff.Console + +greet { greeting, name } = log $ greeting <> ", " <> name <> "." + +main = do + greet { greeting: "Hello", name: "World" } + log "Done" diff --git a/examples/passing/FinalTagless.purs b/examples/passing/FinalTagless.purs --- a/examples/passing/FinalTagless.purs +++ b/examples/passing/FinalTagless.purs @@ -1,6 +1,7 @@ module Main where import Prelude hiding (add) +import Control.Monad.Eff.Console (log, logShow) class E e where num :: Number -> e Number @@ -19,4 +20,6 @@ three :: Expr Number three = add (num 1.0) (num 2.0) -main = Control.Monad.Eff.Console.print $ runId three +main = do + logShow $ runId three + log "Done" diff --git a/examples/passing/FunctionScope.purs b/examples/passing/FunctionScope.purs --- a/examples/passing/FunctionScope.purs +++ b/examples/passing/FunctionScope.purs @@ -2,6 +2,7 @@ import Prelude import Test.Assert +import Control.Monad.Eff.Console (log) mkValue :: Number -> Number mkValue id = id @@ -9,4 +10,4 @@ main = do let value = mkValue 1.0 assert $ value == 1.0 - Control.Monad.Eff.Console.log "Done" + log "Done" diff --git a/examples/passing/Functions.purs b/examples/passing/Functions.purs --- a/examples/passing/Functions.purs +++ b/examples/passing/Functions.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) test1 = \_ -> 0.0 @@ -8,8 +9,4 @@ test3 = \a -> a -test4 = \(%%) -> 1.0 %% 2.0 - -test5 = \(+++) (***) -> 1.0 +++ 2.0 *** 3.0 - -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/Functions2.purs b/examples/passing/Functions2.purs --- a/examples/passing/Functions2.purs +++ b/examples/passing/Functions2.purs @@ -2,6 +2,7 @@ import Prelude import Test.Assert +import Control.Monad.Eff.Console (log) test :: forall a b. a -> b -> a test = \const _ -> const @@ -9,4 +10,4 @@ main = do let value = test "Done" {} assert' "Not done" $ value == "Done" - Control.Monad.Eff.Console.log "Done" + log "Done" diff --git a/examples/passing/Generalization1.purs b/examples/passing/Generalization1.purs --- a/examples/passing/Generalization1.purs +++ b/examples/passing/Generalization1.purs @@ -1,10 +1,11 @@ module Main where import Prelude -import Control.Monad.Eff.Console (print) +import Control.Monad.Eff.Console (logShow, log) main = do - print (sum 1.0 2.0) - print (sum 1 2) + logShow (sum 1.0 2.0) + logShow (sum 1 2) + log "Done" sum x y = x + y diff --git a/examples/passing/Guards.purs b/examples/passing/Guards.purs --- a/examples/passing/Guards.purs +++ b/examples/passing/Guards.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) collatz = \x -> case x of y | y `mod` 2.0 == 0.0 -> y / 2.0 @@ -26,4 +27,4 @@ | otherwise = y - x -main = Control.Monad.Eff.Console.log $ min "Done" "ZZZZ" +main = log $ min "Done" "ZZZZ" diff --git a/examples/passing/IfThenElseMaybe.purs b/examples/passing/IfThenElseMaybe.purs --- a/examples/passing/IfThenElseMaybe.purs +++ b/examples/passing/IfThenElseMaybe.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data Maybe a = Nothing | Just a @@ -8,4 +9,4 @@ test2 = if true then Nothing else Just 10 -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/ImplicitEmptyImport.purs b/examples/passing/ImplicitEmptyImport.purs --- a/examples/passing/ImplicitEmptyImport.purs +++ b/examples/passing/ImplicitEmptyImport.purs @@ -1,8 +1,9 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) main = do - Control.Monad.Eff.Console.log "Hello" - Control.Monad.Eff.Console.log "Goodbye" - Control.Monad.Eff.Console.log "Done" + log "Hello" + log "Goodbye" + log "Done" diff --git a/examples/passing/Import.purs b/examples/passing/Import.purs new file mode 100644 --- /dev/null +++ b/examples/passing/Import.purs @@ -0,0 +1,6 @@ +module Main where + +import M2 +import Control.Monad.Eff.Console (log) + +main = log "Done" diff --git a/examples/passing/Import/M1.purs b/examples/passing/Import/M1.purs new file mode 100644 --- /dev/null +++ b/examples/passing/Import/M1.purs @@ -0,0 +1,8 @@ +module M1 where + +import Prelude () + +id :: forall a. a -> a +id = \x -> x + +foo = id diff --git a/examples/passing/Import/M2.purs b/examples/passing/Import/M2.purs new file mode 100644 --- /dev/null +++ b/examples/passing/Import/M2.purs @@ -0,0 +1,6 @@ +module M2 where + +import Prelude () +import M1 + +main = \_ -> foo 42 diff --git a/examples/passing/ImportExplicit.purs b/examples/passing/ImportExplicit.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ImportExplicit.purs @@ -0,0 +1,10 @@ +module Main where + +import M1 (X(..)) +import Control.Monad.Eff.Console (log) + +testX :: X +testX = X +testY = Y + +main = log "Done" diff --git a/examples/passing/ImportExplicit/M1.purs b/examples/passing/ImportExplicit/M1.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ImportExplicit/M1.purs @@ -0,0 +1,4 @@ +module M1 where + +data X = X | Y +data Z = Z diff --git a/examples/passing/ImportHiding.purs b/examples/passing/ImportHiding.purs --- a/examples/passing/ImportHiding.purs +++ b/examples/passing/ImportHiding.purs @@ -3,7 +3,7 @@ import Control.Monad.Eff.Console import Prelude hiding ( show, -- a value - Show, -- a type class + class Show, -- a type class Unit(..) -- a constructor ) @@ -15,4 +15,5 @@ data Unit = X | Y main = do - print show + logShow show + log "Done" diff --git a/examples/passing/ImportQualified.purs b/examples/passing/ImportQualified.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ImportQualified.purs @@ -0,0 +1,8 @@ +module Main where + +import Prelude +import Control.Monad.Eff +import M1 +import Control.Monad.Eff.Console as C + +main = C.log (log "Done") diff --git a/examples/passing/ImportQualified/M1.purs b/examples/passing/ImportQualified/M1.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ImportQualified/M1.purs @@ -0,0 +1,3 @@ +module M1 where + +log x = x diff --git a/examples/passing/InferRecFunWithConstrainedArgument.purs b/examples/passing/InferRecFunWithConstrainedArgument.purs --- a/examples/passing/InferRecFunWithConstrainedArgument.purs +++ b/examples/passing/InferRecFunWithConstrainedArgument.purs @@ -1,8 +1,11 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log, logShow) -test 100.0 = 100.0 -test n = test(1.0 + n) +test 100 = 100 +test n = test(1 + n) -main = Control.Monad.Eff.Console.print $ test 0.0 +main = do + logShow (test 0) + log "Done" diff --git a/examples/passing/InstanceBeforeClass.purs b/examples/passing/InstanceBeforeClass.purs --- a/examples/passing/InstanceBeforeClass.purs +++ b/examples/passing/InstanceBeforeClass.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) instance fooNumber :: Foo Number where foo = 0.0 @@ -8,4 +9,4 @@ class Foo a where foo :: a -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/IntAndChar.purs b/examples/passing/IntAndChar.purs --- a/examples/passing/IntAndChar.purs +++ b/examples/passing/IntAndChar.purs @@ -2,6 +2,7 @@ import Prelude import Control.Monad.Eff +import Control.Monad.Eff.Console (log) import Test.Assert f 1 = 1 @@ -15,4 +16,4 @@ assert $ f 0 == 0 assert $ g 'a' == 'a' assert $ g 'b' == 'b' - Control.Monad.Eff.Console.log "Done" + log "Done" diff --git a/examples/passing/JSReserved.purs b/examples/passing/JSReserved.purs --- a/examples/passing/JSReserved.purs +++ b/examples/passing/JSReserved.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) yield = 0 member = 1 @@ -9,4 +10,4 @@ this catch = catch -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/KindedType.purs b/examples/passing/KindedType.purs --- a/examples/passing/KindedType.purs +++ b/examples/passing/KindedType.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) type Star2Star f = f :: * -> * @@ -30,4 +31,4 @@ instance clazzString :: Clazz String where def = "test" -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/LargeSumType.purs b/examples/passing/LargeSumType.purs --- a/examples/passing/LargeSumType.purs +++ b/examples/passing/LargeSumType.purs @@ -1,5 +1,7 @@ module Main where - + +import Control.Monad.Eff.Console (log) + data Large = A | B | C | D | E | F | G | H | I | J | K | L | M | N | O | P | Q | R | S | T | U | V | W | X | Y | Z explode A A = "A" @@ -30,4 +32,4 @@ explode Z Z = "Z" explode _ _ = "" -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/Let.purs b/examples/passing/Let.purs --- a/examples/passing/Let.purs +++ b/examples/passing/Let.purs @@ -1,7 +1,9 @@ module Main where import Prelude +import Partial.Unsafe (unsafePartial) import Control.Monad.Eff +import Control.Monad.Eff.Console (log, logShow) import Control.Monad.ST test1 x = let @@ -17,8 +19,9 @@ test3 = let f x y z = x + y + z in f 1.0 2.0 3.0 -test4 = let f x [y, z] = x y z in - f (+) [1.0, 2.0] +test4 = let + f x [y, z] = x y z + in f (+) [1.0, 2.0] test5 = let f x | x > 0.0 = g (x / 2.0) + 1.0 @@ -43,11 +46,13 @@ g x = f x / 2.0 in f 10.0 +main :: Eff _ _ main = do - Control.Monad.Eff.Console.print (test1 1.0) - Control.Monad.Eff.Console.print (test2 1.0 2.0) - Control.Monad.Eff.Console.print test3 - Control.Monad.Eff.Console.print test4 - Control.Monad.Eff.Console.print test5 - Control.Monad.Eff.Console.print test7 - Control.Monad.Eff.Console.print (test8 100.0) + logShow (test1 1.0) + logShow (test2 1.0 2.0) + logShow test3 + unsafePartial (logShow test4) + logShow test5 + logShow test7 + logShow (test8 100.0) + log "Done" diff --git a/examples/passing/Let2.purs b/examples/passing/Let2.purs --- a/examples/passing/Let2.purs +++ b/examples/passing/Let2.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log, logShow) test = let f :: Number -> Boolean @@ -14,4 +15,6 @@ x = f 1.0 in not x -main = Control.Monad.Eff.Console.print test +main = do + logShow test + log "Done" diff --git a/examples/passing/LetInInstance.purs b/examples/passing/LetInInstance.purs --- a/examples/passing/LetInInstance.purs +++ b/examples/passing/LetInInstance.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) class Foo a where foo :: a -> String @@ -11,4 +12,4 @@ go :: String -> String go s = s -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/LiberalTypeSynonyms.purs b/examples/passing/LiberalTypeSynonyms.purs --- a/examples/passing/LiberalTypeSynonyms.purs +++ b/examples/passing/LiberalTypeSynonyms.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) type Reader = (->) String @@ -9,13 +10,13 @@ type AndFoo r = (foo :: String | r) -getFoo :: forall r. Prim.Object (AndFoo r) -> String +getFoo :: forall r. Prim.Record (AndFoo r) -> String getFoo o = o.foo type F r = { | r } -> { | r } f :: (forall r. F r) -> String f g = case g { x: "Hello" } of - { x = x } -> x + { x: x } -> x -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/MPTCs.purs b/examples/passing/MPTCs.purs --- a/examples/passing/MPTCs.purs +++ b/examples/passing/MPTCs.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) class NullaryTypeClass where greeting :: String @@ -14,7 +15,7 @@ instance coerceRefl :: Coerce a a where coerce a = a -instance coerceShow :: (Prelude.Show a) => Coerce a String where +instance coerceShow :: Show a => Coerce a String where coerce = show -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/Match.purs b/examples/passing/Match.purs --- a/examples/passing/Match.purs +++ b/examples/passing/Match.purs @@ -1,9 +1,10 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data Foo a = Foo foo = \f -> case f of Foo -> "foo" -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/Module.purs b/examples/passing/Module.purs new file mode 100644 --- /dev/null +++ b/examples/passing/Module.purs @@ -0,0 +1,7 @@ +module Main where + +import M1 +import M2 +import Control.Monad.Eff.Console (log) + +main = log "Done" diff --git a/examples/passing/Module/M1.purs b/examples/passing/Module/M1.purs new file mode 100644 --- /dev/null +++ b/examples/passing/Module/M1.purs @@ -0,0 +1,14 @@ +module M1 where + +import Prelude + +data Foo = Foo String + +foo :: Foo -> String +foo = \f -> case f of Foo s -> s <> "foo" + +bar :: Foo -> String +bar = foo + +incr :: Int -> Int +incr x = x + 1 diff --git a/examples/passing/Module/M2.purs b/examples/passing/Module/M2.purs new file mode 100644 --- /dev/null +++ b/examples/passing/Module/M2.purs @@ -0,0 +1,10 @@ +module M2 where + +import Prelude +import M1 as M1 + +baz :: M1.Foo -> String +baz = M1.foo + +match :: M1.Foo -> String +match = \f -> case f of M1.Foo s -> s <> "foo" diff --git a/examples/passing/ModuleDeps.purs b/examples/passing/ModuleDeps.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ModuleDeps.purs @@ -0,0 +1,6 @@ +module Main where + +import M1 +import Control.Monad.Eff.Console (log) + +main = log "Done" diff --git a/examples/passing/ModuleDeps/M1.purs b/examples/passing/ModuleDeps/M1.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ModuleDeps/M1.purs @@ -0,0 +1,5 @@ +module M1 where + +import M2 as M2 + +foo = M2.bar diff --git a/examples/passing/ModuleDeps/M2.purs b/examples/passing/ModuleDeps/M2.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ModuleDeps/M2.purs @@ -0,0 +1,5 @@ +module M2 where + +import M3 as M3 + +bar = M3.baz diff --git a/examples/passing/ModuleDeps/M3.purs b/examples/passing/ModuleDeps/M3.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ModuleDeps/M3.purs @@ -0,0 +1,3 @@ +module M3 where + +baz = 1 diff --git a/examples/passing/ModuleExport.purs b/examples/passing/ModuleExport.purs --- a/examples/passing/ModuleExport.purs +++ b/examples/passing/ModuleExport.purs @@ -1,9 +1,8 @@ -module A (module Prelude) where - import Prelude - module Main where - import Control.Monad.Eff.Console - import A - main = do - print (show 1.0) +import Control.Monad.Eff.Console (log, logShow) +import A + +main = do + logShow (show 1.0) + log "Done" diff --git a/examples/passing/ModuleExport/A.purs b/examples/passing/ModuleExport/A.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ModuleExport/A.purs @@ -0,0 +1,3 @@ +module A (module Prelude) where + +import Prelude diff --git a/examples/passing/ModuleExportDupes.purs b/examples/passing/ModuleExportDupes.purs --- a/examples/passing/ModuleExportDupes.purs +++ b/examples/passing/ModuleExportDupes.purs @@ -1,14 +1,5 @@ -module A (module Prelude) where - import Prelude - -module B (module Prelude) where - import Prelude - -module C (module Prelude, module A) where - import Prelude - import A - module Main where + import Control.Monad.Eff.Console import A import B @@ -16,4 +7,5 @@ import Prelude main = do - print (show 1.0) + logShow (show 1.0) + log "Done" diff --git a/examples/passing/ModuleExportDupes/A.purs b/examples/passing/ModuleExportDupes/A.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ModuleExportDupes/A.purs @@ -0,0 +1,3 @@ +module A (module Prelude) where + +import Prelude diff --git a/examples/passing/ModuleExportDupes/B.purs b/examples/passing/ModuleExportDupes/B.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ModuleExportDupes/B.purs @@ -0,0 +1,3 @@ +module B (module Prelude) where + +import Prelude diff --git a/examples/passing/ModuleExportDupes/C.purs b/examples/passing/ModuleExportDupes/C.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ModuleExportDupes/C.purs @@ -0,0 +1,4 @@ +module C (module Prelude, module A) where + +import Prelude +import A diff --git a/examples/passing/ModuleExportExcluded.purs b/examples/passing/ModuleExportExcluded.purs --- a/examples/passing/ModuleExportExcluded.purs +++ b/examples/passing/ModuleExportExcluded.purs @@ -1,14 +1,11 @@ -module A (module Prelude, foo) where - import Prelude - - foo :: Number -> Number - foo _ = 0.0 - module Main where - import Control.Monad.Eff.Console - import A (foo) - otherwise = false +import Prelude +import Control.Monad.Eff.Console (log, logShow) +import A (foo) - main = do - print "1.0" +otherwise = false + +main = do + logShow "1.0" + log "Done" diff --git a/examples/passing/ModuleExportExcluded/A.purs b/examples/passing/ModuleExportExcluded/A.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ModuleExportExcluded/A.purs @@ -0,0 +1,6 @@ +module A (module Prelude, foo) where + +import Prelude + +foo :: Number -> Number +foo _ = 0.0 diff --git a/examples/passing/ModuleExportQualified.purs b/examples/passing/ModuleExportQualified.purs --- a/examples/passing/ModuleExportQualified.purs +++ b/examples/passing/ModuleExportQualified.purs @@ -1,9 +1,9 @@ -module A (module Prelude) where - import Prelude - module Main where - import Control.Monad.Eff.Console - import qualified A as B - main = do - print (B.show 1.0) +import Prelude +import Control.Monad.Eff.Console (log, logShow) +import A as B + +main = do + logShow (B.show 1.0) + log "Done" diff --git a/examples/passing/ModuleExportQualified/A.purs b/examples/passing/ModuleExportQualified/A.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ModuleExportQualified/A.purs @@ -0,0 +1,3 @@ +module A (module Prelude) where + +import Prelude diff --git a/examples/passing/ModuleExportSelf.purs b/examples/passing/ModuleExportSelf.purs --- a/examples/passing/ModuleExportSelf.purs +++ b/examples/passing/ModuleExportSelf.purs @@ -1,14 +1,11 @@ -module A (module A, module Prelude) where - import Prelude - - type Foo = Boolean - module Main where - import Control.Monad.Eff.Console - import A - bar :: Foo - bar = true +import Control.Monad.Eff.Console +import A - main = do - print (show bar) +bar :: Foo +bar = true + +main = do + logShow (show bar) + log "Done" diff --git a/examples/passing/ModuleExportSelf/A.purs b/examples/passing/ModuleExportSelf/A.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ModuleExportSelf/A.purs @@ -0,0 +1,5 @@ +module A (module A, module Prelude) where + +import Prelude + +type Foo = Boolean diff --git a/examples/passing/Monad.purs b/examples/passing/Monad.purs --- a/examples/passing/Monad.purs +++ b/examples/passing/Monad.purs @@ -1,6 +1,6 @@ module Main where -import Prelude () +import Control.Monad.Eff.Console (log) type Monad m = { return :: forall a. a -> m a , bind :: forall a b. m a -> (a -> m b) -> m b } @@ -29,4 +29,4 @@ test2 = test maybe -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/MonadState.purs b/examples/passing/MonadState.purs --- a/examples/passing/MonadState.purs +++ b/examples/passing/MonadState.purs @@ -58,4 +58,6 @@ same :: forall a. (a -> a) -> (a -> a) same = id -main = print $ runState 0 (modify (+ 1)) +main = do + logShow $ runState 0 (modify (_ + 1)) + log "Done" diff --git a/examples/passing/MultiArgFunctions.purs b/examples/passing/MultiArgFunctions.purs --- a/examples/passing/MultiArgFunctions.purs +++ b/examples/passing/MultiArgFunctions.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Data.Function +import Data.Function.Uncurried import Control.Monad.Eff import Control.Monad.Eff.Console @@ -23,5 +23,5 @@ runFn8 (mkFn8 $ \a b c d e f g h -> log $ show [a, b, c, d, e, f, g, h]) 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 runFn9 (mkFn9 $ \a b c d e f g h i -> log $ show [a, b, c, d, e, f, g, h, i]) 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 runFn10 (mkFn10 $ \a b c d e f g h i j-> log $ show [a, b, c, d, e, f, g, h, i, j]) 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 - print $ runFn2 g 0.0 0.0 - log "Done!" + logShow $ runFn2 g 0.0 0.0 + log "Done" diff --git a/examples/passing/MutRec.purs b/examples/passing/MutRec.purs --- a/examples/passing/MutRec.purs +++ b/examples/passing/MutRec.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) f 0.0 = 0.0 f x = g x + 0.0 @@ -16,4 +17,4 @@ oddToNumber (Odd n) = evenToNumber n + 0.0 -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/MutRec2.purs b/examples/passing/MutRec2.purs --- a/examples/passing/MutRec2.purs +++ b/examples/passing/MutRec2.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data A = A B @@ -16,4 +17,4 @@ showN :: A -> S showN a = f a -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/MutRec3.purs b/examples/passing/MutRec3.purs --- a/examples/passing/MutRec3.purs +++ b/examples/passing/MutRec3.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data A = A B @@ -16,4 +17,4 @@ showN :: A -> S showN a = f a -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/NamedPatterns.purs b/examples/passing/NamedPatterns.purs --- a/examples/passing/NamedPatterns.purs +++ b/examples/passing/NamedPatterns.purs @@ -1,9 +1,10 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) foo = \x -> case x of - y@{ foo = "Foo" } -> y + y@{ foo: "Foo" } -> y y -> y -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/NegativeBinder.purs b/examples/passing/NegativeBinder.purs --- a/examples/passing/NegativeBinder.purs +++ b/examples/passing/NegativeBinder.purs @@ -1,9 +1,10 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) test :: Number -> Boolean test -1.0 = false test _ = true -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/NegativeIntInRange.purs b/examples/passing/NegativeIntInRange.purs --- a/examples/passing/NegativeIntInRange.purs +++ b/examples/passing/NegativeIntInRange.purs @@ -1,8 +1,9 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) n :: Int n = -2147483648 -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/Nested.purs b/examples/passing/Nested.purs --- a/examples/passing/Nested.purs +++ b/examples/passing/Nested.purs @@ -1,9 +1,10 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data Extend r a = Extend { prev :: r a, next :: a } data Matrix r a = Square (r (r a)) | Bigger (Matrix (Extend r) a) -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/NestedTypeSynonyms.purs b/examples/passing/NestedTypeSynonyms.purs --- a/examples/passing/NestedTypeSynonyms.purs +++ b/examples/passing/NestedTypeSynonyms.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) type X = String type Y = X -> X @@ -8,4 +9,4 @@ fn :: Y fn a = a -main = Control.Monad.Eff.Console.print (fn "Done") +main = log (fn "Done") diff --git a/examples/passing/NestedWhere.purs b/examples/passing/NestedWhere.purs --- a/examples/passing/NestedWhere.purs +++ b/examples/passing/NestedWhere.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) f x = g x where @@ -9,4 +10,4 @@ go x = go1 (x - 1.0) go1 x = go x -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/Newtype.purs b/examples/passing/Newtype.purs --- a/examples/passing/Newtype.purs +++ b/examples/passing/Newtype.purs @@ -7,17 +7,17 @@ newtype Thing = Thing String instance showThing :: Show Thing where - show (Thing x) = "Thing " ++ show x + show (Thing x) = "Thing " <> show x newtype Box a = Box a instance showBox :: (Show a) => Show (Box a) where - show (Box x) = "Box " ++ show x + show (Box x) = "Box " <> show x apply f x = f x main = do - print $ Thing "hello" - print $ Box 42.0 - print $ apply Box 9000.0 + logShow $ Thing "hello" + logShow $ Box 42.0 + logShow $ apply Box 9000.0 log "Done" diff --git a/examples/passing/NewtypeWithRecordUpdate.purs b/examples/passing/NewtypeWithRecordUpdate.purs --- a/examples/passing/NewtypeWithRecordUpdate.purs +++ b/examples/passing/NewtypeWithRecordUpdate.purs @@ -5,9 +5,9 @@ import Prelude import Control.Monad.Eff.Console -newtype NewType a = NewType (Object a) +newtype NewType a = NewType (Record a) -rec1 :: Object (a :: Number, b :: Number, c:: Number) +rec1 :: Record (a :: Number, b :: Number, c:: Number) rec1 = { a: 0.0, b: 0.0, c: 0.0 } rec2 :: NewType (a :: Number, b :: Number, c :: Number) diff --git a/examples/passing/NonConflictingExports.purs b/examples/passing/NonConflictingExports.purs --- a/examples/passing/NonConflictingExports.purs +++ b/examples/passing/NonConflictingExports.purs @@ -1,14 +1,10 @@ -module A where - - thing :: Int - thing = 1 - -- No failure here as the export `thing` only refers to Main.thing module Main (thing, main) where - import A +import A +import Control.Monad.Eff.Console (log) - thing :: Int - thing = 2 +thing :: Int +thing = 2 - main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/NonConflictingExports/A.purs b/examples/passing/NonConflictingExports/A.purs new file mode 100644 --- /dev/null +++ b/examples/passing/NonConflictingExports/A.purs @@ -0,0 +1,4 @@ +module A where + +thing :: Int +thing = 1 diff --git a/examples/passing/NumberLiterals.purs b/examples/passing/NumberLiterals.purs new file mode 100644 --- /dev/null +++ b/examples/passing/NumberLiterals.purs @@ -0,0 +1,39 @@ +module Main where + +-- See issue #2115. + +import Prelude +import Test.Assert (assert') +import Control.Monad.Eff.Console (log) + +main = do + test "0.17" 0.17 + test "0.25996181067141905" 0.25996181067141905 + test "0.3572019862807257" 0.3572019862807257 + test "0.46817723004874223" 0.46817723004874223 + test "0.9640035681058178" 0.9640035681058178 + test "4.23808622486133" 4.23808622486133 + test "4.540362294799751" 4.540362294799751 + test "5.212384849884261" 5.212384849884261 + test "13.958257048123212" 13.958257048123212 + test "32.96176575630599" 32.96176575630599 + test "38.47735512322269" 38.47735512322269 + + test "10000000000" 1e10 + test "10000000000" 1.0e10 + test "0.00001" 1e-5 + test "0.00001" 1.0e-5 + test "1.5339794352098402e-118" 1.5339794352098402e-118 + test "2.108934760892056e-59" 2.108934760892056e-59 + test "2.250634744599241e-19" 2.250634744599241e-19 + test "5.960464477539063e-8" 5.960464477539063e-8 + test "5e-324" 5e-324 + test "5e-324" 5.0e-324 + + log "Done" + +test str num = + if (show num == str) + then pure unit + else flip assert' false $ + "Expected " <> show str <> ", got " <> show (show num) <> "." diff --git a/examples/passing/ObjectGetter.purs b/examples/passing/ObjectGetter.purs --- a/examples/passing/ObjectGetter.purs +++ b/examples/passing/ObjectGetter.purs @@ -1,13 +1,14 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log, logShow) getX = _.x point = { x: 1.0, y: 0.0 } main = do - Control.Monad.Eff.Console.print $ getX point - Control.Monad.Eff.Console.log $ _." 123 string Prop Name " { " 123 string Prop Name ": "OK" } - Control.Monad.Eff.Console.log $ (_.x >>> _.y) { x: { y: "Nested" } } - Control.Monad.Eff.Console.log $ _.value { value: "Done!" } + logShow $ getX point + log $ _." 123 string Prop Name " { " 123 string Prop Name ": "OK" } + log $ (_.x >>> _.y) { x: { y: "Nested" } } + log $ _.value { value: "Done" } diff --git a/examples/passing/ObjectSynonym.purs b/examples/passing/ObjectSynonym.purs --- a/examples/passing/ObjectSynonym.purs +++ b/examples/passing/ObjectSynonym.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) type Inner = Number @@ -12,4 +13,4 @@ outer :: Outer outer = { inner: inner } -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/ObjectUpdate.purs b/examples/passing/ObjectUpdate.purs --- a/examples/passing/ObjectUpdate.purs +++ b/examples/passing/ObjectUpdate.purs @@ -1,20 +1,23 @@ -module Main where - -import Prelude - -update1 = \o -> o { foo = "Foo" } - -update2 :: forall r. { foo :: String | r } -> { foo :: String | r } -update2 = \o -> o { foo = "Foo" } - -replace = \o -> case o of - { foo = "Foo" } -> o { foo = "Bar" } - { foo = "Bar" } -> o { bar = "Baz" } - o -> o - -polyUpdate :: forall a r. { foo :: a | r } -> { foo :: String | r } -polyUpdate = \o -> o { foo = "Foo" } - -inferPolyUpdate = \o -> o { foo = "Foo" } - -main = Control.Monad.Eff.Console.log ((update1 {foo: ""}).foo) +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +update1 = \o -> o { foo = "Foo" } + +update2 :: forall r. { foo :: String | r } -> { foo :: String | r } +update2 = \o -> o { foo = "Foo" } + +replace = \o -> case o of + { foo: "Foo" } -> o { foo = "Bar" } + { foo: "Bar" } -> o { bar = "Baz" } + o -> o + +polyUpdate :: forall a r. { foo :: a | r } -> { foo :: String | r } +polyUpdate = \o -> o { foo = "Foo" } + +inferPolyUpdate = \o -> o { foo = "Foo" } + +main = do + log ((update1 {foo: ""}).foo) + log "Done" diff --git a/examples/passing/ObjectUpdate2.purs b/examples/passing/ObjectUpdate2.purs --- a/examples/passing/ObjectUpdate2.purs +++ b/examples/passing/ObjectUpdate2.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) type X r = { | r } @@ -14,4 +15,4 @@ { baz = "blah" } -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/ObjectUpdater.purs b/examples/passing/ObjectUpdater.purs --- a/examples/passing/ObjectUpdater.purs +++ b/examples/passing/ObjectUpdater.purs @@ -6,7 +6,7 @@ import Test.Assert getValue :: forall e. Eff (| e) Boolean -getValue = return true +getValue = pure true main = do let record = { value: false } @@ -22,3 +22,5 @@ let record2 = (_ { x = _ }) { x: 0.0 } 10.0 assert $ record2.x == 10.0 + + log "Done" diff --git a/examples/passing/ObjectWildcards.purs b/examples/passing/ObjectWildcards.purs --- a/examples/passing/ObjectWildcards.purs +++ b/examples/passing/ObjectWildcards.purs @@ -8,13 +8,13 @@ mkRecord = { foo: _, bar: _, baz: "baz" } getValue :: forall e. Eff (| e) Boolean -getValue = return true +getValue = pure true main = do obj <- { value: _ } <$> getValue - print obj.value + logShow obj.value let x = 1.0 - point <- { x: _, y: x } <$> return 2.0 + point <- { x: _, y: x } <$> pure 2.0 assert $ point.x == 2.0 assert $ point.y == 1.0 - log (mkRecord 1.0 "Done!").bar + log (mkRecord 1.0 "Done").bar diff --git a/examples/passing/Objects.purs b/examples/passing/Objects.purs --- a/examples/passing/Objects.purs +++ b/examples/passing/Objects.purs @@ -1,6 +1,7 @@ module Main where import Prelude hiding (append) +import Control.Monad.Eff.Console (log) test = \x -> x.foo + x.bar + 1.0 @@ -25,11 +26,11 @@ weirdObj = { "!@#": 1.0 } test5 = case { "***": 1.0 } of - { "***" = n } -> n + { "***": n } -> n test6 = case { "***": 1.0 } of { "***": n } -> n test7 {a: snoog , b : blah } = blah -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/OneConstructor.purs b/examples/passing/OneConstructor.purs --- a/examples/passing/OneConstructor.purs +++ b/examples/passing/OneConstructor.purs @@ -1,9 +1,10 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data One a = One a one' (One a) = a -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/OperatorAliasElsewhere.purs b/examples/passing/OperatorAliasElsewhere.purs --- a/examples/passing/OperatorAliasElsewhere.purs +++ b/examples/passing/OperatorAliasElsewhere.purs @@ -1,8 +1,3 @@ -module Def where - -what :: forall a b. a -> b -> a -what a _ = a - module Main where import Prelude diff --git a/examples/passing/OperatorAliasElsewhere/Def.purs b/examples/passing/OperatorAliasElsewhere/Def.purs new file mode 100644 --- /dev/null +++ b/examples/passing/OperatorAliasElsewhere/Def.purs @@ -0,0 +1,4 @@ +module Def where + +what :: forall a b. a -> b -> a +what a _ = a diff --git a/examples/passing/OperatorAssociativity.purs b/examples/passing/OperatorAssociativity.purs --- a/examples/passing/OperatorAssociativity.purs +++ b/examples/passing/OperatorAssociativity.purs @@ -1,25 +1,25 @@ -module Main where - -import Prelude -import Control.Monad.Eff -import Control.Monad.Eff.Console -import Test.Assert - -bug :: Number -> Number -> Number -bug a b = 0.0 - (a - b) - -main = do - assert (bug 0.0 2.0 == 2.0) - assert (0.0 - (0.0 - 2.0) == 2.0) - assert (0.0 - (0.0 + 2.0) == -2.0) - assert (6.0 / (3.0 * 2.0) == 1.0) - assert ((6.0 / 3.0) * 2.0 == 4.0) - assert (not (1.0 < 0.0) == true) - assert (not ((negate 1.0) < 0.0) == false) - assert (negate (1.0 + 10.0) == -11.0) - assert (2.0 * 3.0 / 4.0 == 1.5) - assert (1.0 * 2.0 * 3.0 * 4.0 * 5.0 / 6.0 == 20.0) - assert (1.0 + 10.0 - 5.0 == 6.0) - assert (1.0 + 10.0 * 5.0 == 51.0) - assert (10.0 * 5.0 - 1.0 == 49.0) - log "Success!" +module Main where + +import Prelude +import Control.Monad.Eff +import Control.Monad.Eff.Console +import Test.Assert + +bug :: Number -> Number -> Number +bug a b = 0.0 - (a - b) + +main = do + assert (bug 0.0 2.0 == 2.0) + assert (0.0 - (0.0 - 2.0) == 2.0) + assert (0.0 - (0.0 + 2.0) == -2.0) + assert (6.0 / (3.0 * 2.0) == 1.0) + assert ((6.0 / 3.0) * 2.0 == 4.0) + assert (not (1.0 < 0.0) == true) + assert (not ((negate 1.0) < 0.0) == false) + assert (negate (1.0 + 10.0) == -11.0) + assert (2.0 * 3.0 / 4.0 == 1.5) + assert (1.0 * 2.0 * 3.0 * 4.0 * 5.0 / 6.0 == 20.0) + assert (1.0 + 10.0 - 5.0 == 6.0) + assert (1.0 + 10.0 * 5.0 == 51.0) + assert (10.0 * 5.0 - 1.0 == 49.0) + log "Done" diff --git a/examples/passing/OperatorInlining.purs b/examples/passing/OperatorInlining.purs --- a/examples/passing/OperatorInlining.purs +++ b/examples/passing/OperatorInlining.purs @@ -1,47 +1,48 @@ module Main where import Prelude -import Control.Monad.Eff.Console +import Control.Monad.Eff.Console (logShow, log) main = do -- semiringNumber - print (1.0 + 2.0) - print (1.0 * 2.0) + logShow (1.0 + 2.0) + logShow (1.0 * 2.0) -- ringNumber - print (1.0 - 2.0) - print (negate 1.0) + logShow (1.0 - 2.0) + logShow (negate 1.0) -- moduleSemiringNumber - print (1.0 / 2.0) + logShow (1.0 / 2.0) -- ordNumber - print (1.0 > 2.0) - print (1.0 < 2.0) - print (1.0 <= 2.0) - print (1.0 >= 2.0) - print (1.0 == 2.0) + logShow (1.0 > 2.0) + logShow (1.0 < 2.0) + logShow (1.0 <= 2.0) + logShow (1.0 >= 2.0) + logShow (1.0 == 2.0) -- eqNumber - print (1.0 == 2.0) - print (1.0 /= 2.0) + logShow (1.0 == 2.0) + logShow (1.0 /= 2.0) -- eqString - print ("foo" == "bar") - print ("foo" /= "bar") + logShow ("foo" == "bar") + logShow ("foo" /= "bar") -- eqBoolean - print (true == false) - print (true /= false) + logShow (true == false) + logShow (true /= false) -- semigroupString - print ("foo" ++ "bar") - print ("foo" <> "bar") + logShow ("foo" <> "bar") -- latticeBoolean - print (top && true) - print (bottom || false) + logShow (top && true) + logShow (bottom || false) -- complementedLatticeBoolean - print (not true) + logShow (not true) + + log "Done" diff --git a/examples/passing/OperatorSections.purs b/examples/passing/OperatorSections.purs --- a/examples/passing/OperatorSections.purs +++ b/examples/passing/OperatorSections.purs @@ -1,17 +1,18 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) import Test.Assert main = do - assert $ (/ 2.0) 4.0 == 2.0 - assert $ (2.0 /) 4.0 == 0.5 - assert $ (`const` 1.0) 2.0 == 2.0 - assert $ (1.0 `const`) 2.0 == 1.0 + assert $ (_ / 2.0) 4.0 == 2.0 + assert $ (2.0 / _) 4.0 == 0.5 + assert $ (_ `const` 1.0) 2.0 == 2.0 + assert $ (1.0 `const` _) 2.0 == 1.0 let foo = { x: 2.0 } - assert $ (/ foo.x) 4.0 == 2.0 - assert $ (foo.x /) 4.0 == 0.5 - let (//) x y = x.x / y.x - assert $ (// foo { x = 4.0 }) { x: 4.0 } == 1.0 - assert $ (foo { x = 4.0 } //) { x: 4.0 } == 1.0 - Control.Monad.Eff.Console.log "Done!" + assert $ (_ / foo.x) 4.0 == 2.0 + assert $ (foo.x / _) 4.0 == 0.5 + let div x y = x.x / y.x + assert $ (_ `div` foo { x = 4.0 }) { x: 4.0 } == 1.0 + assert $ (foo { x = 4.0 } `div` _) { x: 4.0 } == 1.0 + log "Done" diff --git a/examples/passing/Operators.purs b/examples/passing/Operators.purs --- a/examples/passing/Operators.purs +++ b/examples/passing/Operators.purs @@ -1,16 +1,17 @@ module Main where import Prelude +import Other (foo) +import Other as Other import Control.Monad.Eff import Control.Monad.Eff.Console -(?!) :: forall a. a -> a -> a -(?!) x _ = x +op1 :: forall a. a -> a -> a +op1 x _ = x -bar :: String -> String -> String -bar = \s1 s2 -> s1 ++ s2 +infix 4 op1 as ?! -test1 :: forall n. (Num n) => n -> n -> (n -> n -> n) -> n +test1 :: forall n. (Semiring n) => n -> n -> (n -> n -> n) -> n test1 x y z = x * y + z x y test2 = (\x -> x.foo false) { foo : \_ -> 1.0 } @@ -21,40 +22,39 @@ test4 = 1 `k` 2 -infixl 5 %% +op2 :: Number -> Number -> Number +op2 x y = x * y + y -(%%) :: Number -> Number -> Number -(%%) x y = x * y + y +infixl 5 op2 as %% test5 = 1.0 %% 2.0 %% 3.0 test6 = ((\x -> x) `k` 2.0) 3.0 -(<+>) :: String -> String -> String -(<+>) = \s1 s2 -> s1 ++ s2 +op3 :: String -> String -> String +op3 = \s1 s2 -> s1 <> s2 +infix 4 op3 as <+> + test7 = "Hello" <+> "World!" -(@@) :: forall a b. (a -> b) -> a -> b -(@@) = \f x -> f x +op4 :: forall a b. (a -> b) -> a -> b +op4 = \f x -> f x -foo :: String -> String -foo = \s -> s +infix 4 op4 as @@ test8 = foo @@ "Hello World" -test9 = Main.foo @@ "Hello World" - -test10 = "Hello" `Main.bar` "World" +test9 = Other.foo @@ "Hello World" -(...) :: forall a. Array a -> Array a -> Array a -(...) = \as -> \bs -> as +test10 = "Hello" `Other.baz` "World" -test11 = [1.0, 2.0, 0.0] ... [4.0, 5.0, 6.0] +op5 :: forall a. Array a -> Array a -> Array a +op5 = \as -> \bs -> as -test12 (<%>) a b = a <%> b +infix 4 op5 as ... -test13 = \(<%>) a b -> a <%> b +test11 = [1.0, 2.0, 0.0] ... [4.0, 5.0, 6.0] test14 :: Number -> Number -> Boolean test14 a b = a < b @@ -71,11 +71,6 @@ test19 :: Number test19 = negate $ negate (-1.0) -test20 :: Number -test20 = 1.0 @ 2.0 - where - (@) x y = x + y * y - main = do let t1 = test1 1.0 2.0 (\x y -> x + y) let t2 = test2 @@ -88,12 +83,9 @@ let t9 = test9 let t10 = test10 let t11 = test11 - let t12 = test12 k 1.0 2.0 - let t13 = test13 k 1.0 2.0 let t14 = test14 1.0 2.0 let t15 = test15 1.0 2.0 let t17 = test17 let t18 = test18 let t19 = test19 - let t20 = test20 log "Done" diff --git a/examples/passing/Operators/Other.purs b/examples/passing/Operators/Other.purs new file mode 100644 --- /dev/null +++ b/examples/passing/Operators/Other.purs @@ -0,0 +1,7 @@ +module Other where + +foo :: String -> String +foo s = s + +baz :: String -> String -> String +baz s _ = s diff --git a/examples/passing/OptimizerBug.purs b/examples/passing/OptimizerBug.purs --- a/examples/passing/OptimizerBug.purs +++ b/examples/passing/OptimizerBug.purs @@ -1,9 +1,10 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) x a = 1.0 + y a y a = x a -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/OptionalQualified.purs b/examples/passing/OptionalQualified.purs --- a/examples/passing/OptionalQualified.purs +++ b/examples/passing/OptionalQualified.purs @@ -1,7 +1,6 @@ module Main where --- qualified import with the "qualified" keyword -import qualified Prelude as P +import Prelude as P -- qualified import without the "qualified" keyword import Control.Monad.Eff.Console as Console @@ -9,5 +8,5 @@ bind = P.bind main = do - message <- P.return "success!" + message <- P.pure "Done" Console.log message diff --git a/examples/passing/OverlappingInstances.purs b/examples/passing/OverlappingInstances.purs --- a/examples/passing/OverlappingInstances.purs +++ b/examples/passing/OverlappingInstances.purs @@ -1,13 +1,17 @@ -module Main where - -import Prelude - -data A = A - -instance showA1 :: Show A where - show A = "Instance 1" - -instance showA2 :: Show A where - show A = "Instance 2" - -main = Test.Assert.assert $ show A == "Instance 1" +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) +import Test.Assert (assert) + +data A = A + +instance showA1 :: Show A where + show A = "Instance 1" + +instance showA2 :: Show A where + show A = "Instance 2" + +main = do + assert $ show A == "Instance 1" + log "Done" diff --git a/examples/passing/OverlappingInstances2.purs b/examples/passing/OverlappingInstances2.purs --- a/examples/passing/OverlappingInstances2.purs +++ b/examples/passing/OverlappingInstances2.purs @@ -1,23 +1,27 @@ -module Main where - -import Prelude - -data A = A | B - -instance eqA1 :: Eq A where - eq A A = true - eq B B = true - eq _ _ = false - -instance eqA2 :: Eq A where - eq _ _ = true - -instance ordA :: Ord A where - compare A B = LT - compare B A = GT - compare _ _ = EQ - -test :: forall a. (Ord a) => a -> a -> String -test x y = show $ x == y - -main = Test.Assert.assert $ test A B == "false" +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) +import Test.Assert (assert) + +data A = A | B + +instance eqA1 :: Eq A where + eq A A = true + eq B B = true + eq _ _ = false + +instance eqA2 :: Eq A where + eq _ _ = true + +instance ordA :: Ord A where + compare A B = LT + compare B A = GT + compare _ _ = EQ + +test :: forall a. (Ord a) => a -> a -> String +test x y = show $ x == y + +main = do + assert $ test A B == "false" + log "Done" diff --git a/examples/passing/OverlappingInstances3.purs b/examples/passing/OverlappingInstances3.purs --- a/examples/passing/OverlappingInstances3.purs +++ b/examples/passing/OverlappingInstances3.purs @@ -1,16 +1,20 @@ -module Main where - -import Prelude - -class Foo a - -instance foo1 :: Foo Number - -instance foo2 :: Foo Number - -test :: forall a. (Foo a) => a -> a -test a = a - -test1 = test 0.0 - -main = Test.Assert.assert (test1 == 0.0) +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) +import Test.Assert (assert) + +class Foo a + +instance foo1 :: Foo Number + +instance foo2 :: Foo Number + +test :: forall a. (Foo a) => a -> a +test a = a + +test1 = test 0.0 + +main = do + assert (test1 == 0.0) + log "Done" diff --git a/examples/passing/ParensInTypedBinder.purs b/examples/passing/ParensInTypedBinder.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ParensInTypedBinder.purs @@ -0,0 +1,20 @@ +module Main where + +import Prelude +import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Console (CONSOLE, log) + +foo :: Array Int +foo = do + xss :: Array (Array Int) <- [[[1,2,3], [4, 5]], [[6]]] + xs :: Array Int <- xss + xs + +main :: + forall eff. + Eff + ( console :: CONSOLE + | eff + ) + Unit +main = log "Done" diff --git a/examples/passing/PartialFunction.purs b/examples/passing/PartialFunction.purs --- a/examples/passing/PartialFunction.purs +++ b/examples/passing/PartialFunction.purs @@ -1,9 +1,11 @@ module Main where import Prelude -import Test.Assert +import Control.Monad.Eff +import Control.Monad.Eff.Console +fn :: Partial => Number -> Number fn 0.0 = 0.0 fn 1.0 = 2.0 -main = assertThrows $ \_ -> fn 2.0 +main = log "Done" diff --git a/examples/passing/Patterns.purs b/examples/passing/Patterns.purs --- a/examples/passing/Patterns.purs +++ b/examples/passing/Patterns.purs @@ -1,14 +1,15 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) test = \x -> case x of - { str = "Foo", bool = true } -> true - { str = "Bar", bool = b } -> b + { str: "Foo", bool: true } -> true + { str: "Bar", bool: b } -> b _ -> false f = \o -> case o of - { foo = "Foo" } -> o.bar + { foo: "Foo" } -> o.bar _ -> 0 h = \o -> case o of @@ -19,4 +20,4 @@ isDesc [x, y] | x > y = true isDesc _ = false -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/PendingConflictingImports.purs b/examples/passing/PendingConflictingImports.purs --- a/examples/passing/PendingConflictingImports.purs +++ b/examples/passing/PendingConflictingImports.purs @@ -1,17 +1,8 @@ -module A where - - thing :: Int - thing = 1 - -module B where - - thing :: Int - thing = 2 - module Main where - -- No error as we never force `thing` to be resolved in `Main` - import A - import B +-- No error as we never force `thing` to be resolved in `Main` +import A +import B +import Control.Monad.Eff.Console (log) - main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/PendingConflictingImports/A.purs b/examples/passing/PendingConflictingImports/A.purs new file mode 100644 --- /dev/null +++ b/examples/passing/PendingConflictingImports/A.purs @@ -0,0 +1,4 @@ +module A where + +thing :: Int +thing = 1 diff --git a/examples/passing/PendingConflictingImports/B.purs b/examples/passing/PendingConflictingImports/B.purs new file mode 100644 --- /dev/null +++ b/examples/passing/PendingConflictingImports/B.purs @@ -0,0 +1,4 @@ +module B where + +thing :: Int +thing = 2 diff --git a/examples/passing/PendingConflictingImports2.purs b/examples/passing/PendingConflictingImports2.purs --- a/examples/passing/PendingConflictingImports2.purs +++ b/examples/passing/PendingConflictingImports2.purs @@ -1,14 +1,10 @@ -module A where - - thing :: Int - thing = 1 - module Main where - import A +import A +import Control.Monad.Eff.Console (log) - -- No error as we never force `thing` to be resolved in `Main` - thing :: Int - thing = 2 +-- No error as we never force `thing` to be resolved in `Main` +thing :: Int +thing = 2 - main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/PendingConflictingImports2/A.purs b/examples/passing/PendingConflictingImports2/A.purs new file mode 100644 --- /dev/null +++ b/examples/passing/PendingConflictingImports2/A.purs @@ -0,0 +1,4 @@ +module A where + +thing :: Int +thing = 1 diff --git a/examples/passing/Person.purs b/examples/passing/Person.purs --- a/examples/passing/Person.purs +++ b/examples/passing/Person.purs @@ -1,11 +1,12 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data Person = Person { name :: String, age :: Number } showPerson :: Person -> String showPerson = \p -> case p of - Person o -> o.name ++ ", aged " ++ show o.age + Person o -> o.name <> ", aged " <> show o.age -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/PrimedTypeName.purs b/examples/passing/PrimedTypeName.purs new file mode 100644 --- /dev/null +++ b/examples/passing/PrimedTypeName.purs @@ -0,0 +1,20 @@ +module Main (T, T', T'', T''', main) where + +import Prelude +import Control.Monad.Eff.Console (log) + +data T a = T +type T' = T Unit + +data T'' = TP + +foreign import data T''' ∷ * + +instance eqT ∷ Eq T'' where + eq _ _ = true + +type A' a b = b → a + +infixr 4 type A' as ↫ + +main = log "Done" diff --git a/examples/passing/QualifiedNames.purs b/examples/passing/QualifiedNames.purs new file mode 100644 --- /dev/null +++ b/examples/passing/QualifiedNames.purs @@ -0,0 +1,11 @@ +module Main where + +import Prelude +import Either as Either +import Control.Monad.Eff.Console (log) + +either :: forall a b c. (a -> c) -> (b -> c) -> Either.Either a b -> c +either f _ (Either.Left x) = f x +either _ g (Either.Right y) = g y + +main = log (either id id (Either.Left "Done")) diff --git a/examples/passing/QualifiedNames/Either.purs b/examples/passing/QualifiedNames/Either.purs new file mode 100644 --- /dev/null +++ b/examples/passing/QualifiedNames/Either.purs @@ -0,0 +1,5 @@ +module Either where + +import Prelude + +data Either a b = Left a | Right b diff --git a/examples/passing/QualifiedQualifiedImports.purs b/examples/passing/QualifiedQualifiedImports.purs --- a/examples/passing/QualifiedQualifiedImports.purs +++ b/examples/passing/QualifiedQualifiedImports.purs @@ -1,6 +1,6 @@ module Main where -- qualified import with qualified imported names -import qualified Control.Monad.Eff.Console (log) as Console +import Control.Monad.Eff.Console (log) as Console -main = Console.log "Success!" +main = Console.log "Done" diff --git a/examples/passing/Rank2Data.purs b/examples/passing/Rank2Data.purs --- a/examples/passing/Rank2Data.purs +++ b/examples/passing/Rank2Data.purs @@ -1,29 +1,30 @@ -module Main where - -import Prelude hiding (add) - -data Id = Id forall a. a -> a - -runId = \id a -> case id of - Id f -> f a - -data Nat = Nat forall r. r -> (r -> r) -> r - -runNat = \nat -> case nat of - Nat f -> f 0.0 (\n -> n + 1.0) - -zero' = Nat (\zero' _ -> zero') - -succ = \n -> case n of - Nat f -> Nat (\zero' succ -> succ (f zero' succ)) - -add = \n m -> case n of - Nat f -> case m of - Nat g -> Nat (\zero' succ -> g (f zero' succ) succ) - -one' = succ zero' -two = succ zero' -four = add two two -fourNumber = runNat four - -main = Control.Monad.Eff.Console.log "Done'" +module Main where + +import Prelude hiding (add) +import Control.Monad.Eff.Console (log) + +data Id = Id forall a. a -> a + +runId = \id a -> case id of + Id f -> f a + +data Nat = Nat forall r. r -> (r -> r) -> r + +runNat = \nat -> case nat of + Nat f -> f 0.0 (\n -> n + 1.0) + +zero' = Nat (\zero' _ -> zero') + +succ = \n -> case n of + Nat f -> Nat (\zero' succ -> succ (f zero' succ)) + +add = \n m -> case n of + Nat f -> case m of + Nat g -> Nat (\zero' succ -> g (f zero' succ) succ) + +one' = succ zero' +two = succ zero' +four = add two two +fourNumber = runNat four + +main = log "Done" diff --git a/examples/passing/Rank2Object.purs b/examples/passing/Rank2Object.purs --- a/examples/passing/Rank2Object.purs +++ b/examples/passing/Rank2Object.purs @@ -6,6 +6,6 @@ data Foo = Foo { id :: forall a. a -> a } foo :: Foo -> Number -foo (Foo { id = f }) = f 0.0 +foo (Foo { id: f }) = f 0.0 main = log "Done" diff --git a/examples/passing/Rank2TypeSynonym.purs b/examples/passing/Rank2TypeSynonym.purs --- a/examples/passing/Rank2TypeSynonym.purs +++ b/examples/passing/Rank2TypeSynonym.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff +import Control.Monad.Eff.Console (log, logShow) type Foo a = forall f. (Monad f) => f a @@ -13,4 +13,5 @@ main = do x <- bar - Control.Monad.Eff.Console.print x + logShow x + log "Done" diff --git a/examples/passing/Rank2Types.purs b/examples/passing/Rank2Types.purs --- a/examples/passing/Rank2Types.purs +++ b/examples/passing/Rank2Types.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) test1 :: (forall a. (a -> a)) -> Number test1 = \f -> f 0.0 @@ -8,4 +9,4 @@ forever :: forall m a b. (forall a b. m a -> (a -> m b) -> m b) -> m a -> m b forever = \bind action -> bind action $ \_ -> forever bind action -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/ReExportQualified.purs b/examples/passing/ReExportQualified.purs --- a/examples/passing/ReExportQualified.purs +++ b/examples/passing/ReExportQualified.purs @@ -1,16 +1,7 @@ -module A where - x = "Do" - -module B where - y = "ne" - -module C (module A, module M2) where - import A - import qualified B as M2 - module Main where - import Prelude - import C +import Prelude +import C +import Control.Monad.Eff.Console (log) - main = Control.Monad.Eff.Console.log (x ++ y) +main = log (x <> y) diff --git a/examples/passing/ReExportQualified/A.purs b/examples/passing/ReExportQualified/A.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ReExportQualified/A.purs @@ -0,0 +1,3 @@ +module A where + +x = "Do" diff --git a/examples/passing/ReExportQualified/B.purs b/examples/passing/ReExportQualified/B.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ReExportQualified/B.purs @@ -0,0 +1,3 @@ +module B where + +y = "ne" diff --git a/examples/passing/ReExportQualified/C.purs b/examples/passing/ReExportQualified/C.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ReExportQualified/C.purs @@ -0,0 +1,4 @@ +module C (module A, module M2) where + +import A +import B as M2 diff --git a/examples/passing/RebindableSyntax.purs b/examples/passing/RebindableSyntax.purs --- a/examples/passing/RebindableSyntax.purs +++ b/examples/passing/RebindableSyntax.purs @@ -1,39 +1,43 @@ -module Main where - -import Prelude - -example1 :: String -example1 = do - "Do" - " notation" - " for" - " Semigroup" - where - bind 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 - map _ (Const a) = Const a - -instance applyConst :: (Semigroup a) => Apply (Const a) where - apply (Const a1) (Const a2) = Const (a1 <> a2) - -example2 :: Const String Unit -example2 = do - Const "Do" - Const " notation" - Const " for" - Const " Apply" - where - bind x f = x *> f unit - -main = do - Control.Monad.Eff.Console.log example1 - Control.Monad.Eff.Console.log $ runConst example2 +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +example1 :: String +example1 = do + "Do" + " notation" + " for" + " Semigroup" + where + bind x f = x <> f unit + +applySecond :: forall f a b. (Apply f) => f a -> f b -> f b +applySecond fa fb = const id <$> fa <*> fb + +infixl 4 applySecond as *> + +newtype Const a b = Const a + +runConst :: forall a b. Const a b -> a +runConst (Const a) = a + +instance functorConst :: Functor (Const a) where + map _ (Const a) = Const a + +instance applyConst :: (Semigroup a) => Apply (Const a) where + apply (Const a1) (Const a2) = Const (a1 <> a2) + +example2 :: Const String Unit +example2 = do + Const "Do" + Const " notation" + Const " for" + Const " Apply" + where + bind x f = x *> f unit + +main = do + log example1 + log $ runConst example2 + log "Done" diff --git a/examples/passing/Recursion.purs b/examples/passing/Recursion.purs --- a/examples/passing/Recursion.purs +++ b/examples/passing/Recursion.purs @@ -1,10 +1,11 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) fib = \n -> case n of 0.0 -> 1.0 1.0 -> 1.0 n -> fib (n - 1.0) + fib (n - 2.0) -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/RedefinedFixity.purs b/examples/passing/RedefinedFixity.purs new file mode 100644 --- /dev/null +++ b/examples/passing/RedefinedFixity.purs @@ -0,0 +1,6 @@ +module Main where + +import M3 +import Control.Monad.Eff.Console (log) + +main = log "Done" diff --git a/examples/passing/RedefinedFixity/M1.purs b/examples/passing/RedefinedFixity/M1.purs new file mode 100644 --- /dev/null +++ b/examples/passing/RedefinedFixity/M1.purs @@ -0,0 +1,6 @@ +module M1 where + +applyFn :: forall a b. (forall c d. c -> d) -> a -> b +applyFn f a = f a + +infixr 1000 applyFn as $ diff --git a/examples/passing/RedefinedFixity/M2.purs b/examples/passing/RedefinedFixity/M2.purs new file mode 100644 --- /dev/null +++ b/examples/passing/RedefinedFixity/M2.purs @@ -0,0 +1,5 @@ +module M2 where + +import Prelude () + +import M1 diff --git a/examples/passing/RedefinedFixity/M3.purs b/examples/passing/RedefinedFixity/M3.purs new file mode 100644 --- /dev/null +++ b/examples/passing/RedefinedFixity/M3.purs @@ -0,0 +1,6 @@ +module M3 where + +import Prelude () + +import M1 +import M2 diff --git a/examples/passing/ReservedWords.purs b/examples/passing/ReservedWords.purs --- a/examples/passing/ReservedWords.purs +++ b/examples/passing/ReservedWords.purs @@ -2,6 +2,8 @@ module Main where import Prelude +import Control.Monad.Eff +import Control.Monad.Eff.Console (log) o :: { type :: String } o = { type: "o" } @@ -10,6 +12,8 @@ p = o { type = "p" } f :: forall r. { type :: String | r } -> String -f { type = "p" } = "Done" +f { type: "p" } = "Done" +f _ = "Fail" -main = Control.Monad.Eff.Console.log $ f { type: p.type, foo: "bar" } +main :: Eff _ _ +main = log $ f { type: p.type, foo: "bar" } diff --git a/examples/passing/ResolvableScopeConflict.purs b/examples/passing/ResolvableScopeConflict.purs --- a/examples/passing/ResolvableScopeConflict.purs +++ b/examples/passing/ResolvableScopeConflict.purs @@ -1,25 +1,13 @@ -module A where - - thing :: Int - thing = 1 - -module B where - - thing :: Int - thing = 2 - - zing :: Int - zing = 3 - module Main where - import A (thing) - import B +import A (thing) +import B +import Control.Monad.Eff.Console (log) - -- Not an error as although we have `thing` in scope from both A and B, it is - -- imported explicitly from A, giving it a resolvable solution. - what :: Boolean -> Int - what true = thing - what false = zing +-- Not an error as although we have `thing` in scope from both A and B, it is +-- imported explicitly from A, giving it a resolvable solution. +what :: Boolean -> Int +what true = thing +what false = zing - main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/ResolvableScopeConflict/A.purs b/examples/passing/ResolvableScopeConflict/A.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ResolvableScopeConflict/A.purs @@ -0,0 +1,4 @@ +module A where + +thing :: Int +thing = 1 diff --git a/examples/passing/ResolvableScopeConflict/B.purs b/examples/passing/ResolvableScopeConflict/B.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ResolvableScopeConflict/B.purs @@ -0,0 +1,7 @@ +module B where + +thing :: Int +thing = 2 + +zing :: Int +zing = 3 diff --git a/examples/passing/ResolvableScopeConflict2.purs b/examples/passing/ResolvableScopeConflict2.purs --- a/examples/passing/ResolvableScopeConflict2.purs +++ b/examples/passing/ResolvableScopeConflict2.purs @@ -1,22 +1,15 @@ -module A where - - thing :: Int - thing = 2 - - zing :: Int - zing = 3 - module Main where - import A +import A +import Control.Monad.Eff.Console (log) - thing :: Int - thing = 1 +thing :: Int +thing = 1 - -- Not an error as although we have `thing` in scope from both Main and A, - -- as the local declaration takes precedence over the implicit import - what :: Boolean -> Int - what true = thing - what false = zing +-- Not an error as although we have `thing` in scope from both Main and A, +-- as the local declaration takes precedence over the implicit import +what :: Boolean -> Int +what true = thing +what false = zing - main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/ResolvableScopeConflict2/A.purs b/examples/passing/ResolvableScopeConflict2/A.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ResolvableScopeConflict2/A.purs @@ -0,0 +1,7 @@ +module A where + +thing :: Int +thing = 2 + +zing :: Int +zing = 3 diff --git a/examples/passing/ResolvableScopeConflict3.purs b/examples/passing/ResolvableScopeConflict3.purs --- a/examples/passing/ResolvableScopeConflict3.purs +++ b/examples/passing/ResolvableScopeConflict3.purs @@ -1,15 +1,9 @@ -module A where - - thing :: Int - thing = 1 - module Main (thing, main, module A) where - import A - - thing :: Int - thing = 2 - - main = Control.Monad.Eff.Console.log "Done" +import A +import Control.Monad.Eff.Console (log) +thing :: Int +thing = 2 +main = log "Done" diff --git a/examples/passing/ResolvableScopeConflict3/A.purs b/examples/passing/ResolvableScopeConflict3/A.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ResolvableScopeConflict3/A.purs @@ -0,0 +1,4 @@ +module A where + +thing :: Int +thing = 1 diff --git a/examples/passing/RowConstructors.purs b/examples/passing/RowConstructors.purs --- a/examples/passing/RowConstructors.purs +++ b/examples/passing/RowConstructors.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) type Foo = (x :: Number | (y :: Number | (z :: Number))) type Bar = (x :: Number, y :: Number, z :: Number) @@ -12,7 +13,7 @@ bar :: { | Bar } bar = { x: 0.0, y: 0.0, z: 0.0 } -id' :: Object Foo -> Object Bar +id' :: Record Foo -> Record Bar id' = id foo' :: { | Foo } @@ -39,4 +40,4 @@ wildcard' :: { | Quux _ } -> Number wildcard' { q: q } = q -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/RowPolyInstanceContext.purs b/examples/passing/RowPolyInstanceContext.purs --- a/examples/passing/RowPolyInstanceContext.purs +++ b/examples/passing/RowPolyInstanceContext.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) class T s m where state :: (s -> s) -> m Unit @@ -11,12 +12,12 @@ state f = S $ \s -> { new: f s, ret: unit } test1 :: forall r . S { foo :: String | r } Unit -test1 = state $ \o -> o { foo = o.foo ++ "!" } +test1 = state $ \o -> o { foo = o.foo <> "!" } test2 :: forall m r . (T { foo :: String | r } m) => m Unit -test2 = state $ \o -> o { foo = o.foo ++ "!" } +test2 = state $ \o -> o { foo = o.foo <> "!" } main = do let t1 = test1 let t2 = test2 - Control.Monad.Eff.Console.log "Done" + log "Done" diff --git a/examples/passing/RuntimeScopeIssue.purs b/examples/passing/RuntimeScopeIssue.purs --- a/examples/passing/RuntimeScopeIssue.purs +++ b/examples/passing/RuntimeScopeIssue.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log, logShow) class A a where a :: a -> Boolean @@ -16,4 +17,6 @@ b 0.0 = false b n = a (n - 1.0) -main = Control.Monad.Eff.Console.print $ a 10.0 +main = do + logShow $ a 10.0 + log "Done" diff --git a/examples/passing/ScopedTypeVariables.purs b/examples/passing/ScopedTypeVariables.purs --- a/examples/passing/ScopedTypeVariables.purs +++ b/examples/passing/ScopedTypeVariables.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) test1 :: forall a. (a -> a) -> a -> a test1 f x = g (g x) @@ -33,4 +34,4 @@ j x = x -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/Sequence.purs b/examples/passing/Sequence.purs --- a/examples/passing/Sequence.purs +++ b/examples/passing/Sequence.purs @@ -2,6 +2,7 @@ import Prelude import Control.Monad.Eff +import Control.Monad.Eff.Console (log) data List a = Cons a (List a) | Nil @@ -12,4 +13,4 @@ sequence Nil = pure Nil sequence (Cons x xs) = Cons <$> x <*> sequence xs -main = sequence $ Cons (Control.Monad.Eff.Console.log "Done") Nil +main = sequence $ Cons (log "Done") Nil diff --git a/examples/passing/SequenceDesugared.purs b/examples/passing/SequenceDesugared.purs --- a/examples/passing/SequenceDesugared.purs +++ b/examples/passing/SequenceDesugared.purs @@ -2,6 +2,7 @@ import Prelude import Control.Monad.Eff +import Control.Monad.Eff.Console (log) data List a = Cons a (List a) | Nil @@ -31,7 +32,7 @@ Cons x xs -> Cons <$> x <*> sequence sequenceList''' xs) :: forall m a. (Monad m) => List (m a) -> m (List a)) main = do - sequence sequenceList $ Cons (Control.Monad.Eff.Console.log "Done") Nil - sequence sequenceList' $ Cons (Control.Monad.Eff.Console.log "Done") Nil - sequence sequenceList'' $ Cons (Control.Monad.Eff.Console.log "Done") Nil - sequence sequenceList''' $ Cons (Control.Monad.Eff.Console.log "Done") Nil + sequence sequenceList $ Cons (log "Done") Nil + sequence sequenceList' $ Cons (log "Done") Nil + sequence sequenceList'' $ Cons (log "Done") Nil + sequence sequenceList''' $ Cons (log "Done") Nil diff --git a/examples/passing/ShadowedModuleName.purs b/examples/passing/ShadowedModuleName.purs --- a/examples/passing/ShadowedModuleName.purs +++ b/examples/passing/ShadowedModuleName.purs @@ -1,15 +1,8 @@ -module Test where - - data Z = Z String - - runZ :: Z -> String - runZ (Z s) = s - module Main where - import Test - import Control.Monad.Eff.Console +import Test +import Control.Monad.Eff.Console - data Test = Test +data Test = Test - main = log (runZ (Z "done")) +main = log (runZ (Z "Done")) diff --git a/examples/passing/ShadowedModuleName/Test.purs b/examples/passing/ShadowedModuleName/Test.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ShadowedModuleName/Test.purs @@ -0,0 +1,6 @@ +module Test where + +data Z = Z String + +runZ :: Z -> String +runZ (Z s) = s diff --git a/examples/passing/ShadowedName.purs b/examples/passing/ShadowedName.purs new file mode 100644 --- /dev/null +++ b/examples/passing/ShadowedName.purs @@ -0,0 +1,11 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console +import Control.Monad.Eff.Console (log) + +done :: String +done = let str = "Not yet done" in + let str = "Done" in str + +main = log done diff --git a/examples/passing/ShadowedTCO.purs b/examples/passing/ShadowedTCO.purs --- a/examples/passing/ShadowedTCO.purs +++ b/examples/passing/ShadowedTCO.purs @@ -1,18 +1,21 @@ -module Main where - -import Prelude hiding (add) - -runNat f = f 0.0 (\n -> n + 1.0) - -zero' z _ = z - -succ f zero' succ = succ (f zero' succ) - -add f g zero' succ = g (f zero' succ) succ - -one' = succ zero' -two = succ one' -four = add two two -fourNumber = runNat four - -main = Control.Monad.Eff.Console.log $ show fourNumber +module Main where + +import Prelude hiding (add) +import Control.Monad.Eff.Console (log) + +runNat f = f 0.0 (\n -> n + 1.0) + +zero' z _ = z + +succ f zero' succ = succ (f zero' succ) + +add f g zero' succ = g (f zero' succ) succ + +one' = succ zero' +two = succ one' +four = add two two +fourNumber = runNat four + +main = do + log $ show fourNumber + log "Done" diff --git a/examples/passing/ShadowedTCOLet.purs b/examples/passing/ShadowedTCOLet.purs --- a/examples/passing/ShadowedTCOLet.purs +++ b/examples/passing/ShadowedTCOLet.purs @@ -1,9 +1,15 @@ -module Main where - -import Prelude - -f x y z = - let f 1.0 2.0 3.0 = 1.0 - in f x z y - -main = Control.Monad.Eff.Console.log $ show $ f 1.0 3.0 2.0 +module Main where + +import Prelude +import Partial.Unsafe (unsafePartial) +import Control.Monad.Eff +import Control.Monad.Eff.Console (log) + +f x y z = + let f 1.0 2.0 3.0 = 1.0 + in f x z y + +main :: Eff _ _ +main = do + log $ show $ unsafePartial f 1.0 3.0 2.0 + log "Done" diff --git a/examples/passing/SignedNumericLiterals.purs b/examples/passing/SignedNumericLiterals.purs --- a/examples/passing/SignedNumericLiterals.purs +++ b/examples/passing/SignedNumericLiterals.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) p = 0.5 q = 1.0 @@ -14,4 +15,4 @@ test1 = 2.0 - 1.0 -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/StringEscapes.purs b/examples/passing/StringEscapes.purs --- a/examples/passing/StringEscapes.purs +++ b/examples/passing/StringEscapes.purs @@ -1,15 +1,17 @@ -module Main where - -import Prelude ((==), bind) -import Test.Assert (assert) - -singleCharacter = "\0\b\t\n\v\f\r\"\\" == "\x0\x8\x9\xA\xB\xC\xD\x22\x5C" -hex = "\x1D306\x2603\x3C6\xE0\x0" == "𝌆☃φà\0" -decimal = "\119558\9731\966\224\0" == "𝌆☃φà\0" -surrogatePair = "\xD834\xDF06" == "\x1D306" - -main = do - assert singleCharacter - assert hex - assert decimal - assert surrogatePair +module Main where + +import Prelude ((==), bind) +import Test.Assert (assert) +import Control.Monad.Eff.Console (log) + +singleCharacter = "\0\b\t\n\v\f\r\"\\" == "\x0\x8\x9\xA\xB\xC\xD\x22\x5C" +hex = "\x1D306\x2603\x3C6\xE0\x0" == "𝌆☃φà\0" +decimal = "\119558\9731\966\224\0" == "𝌆☃φà\0" +surrogatePair = "\xD834\xDF06" == "\x1D306" + +main = do + assert singleCharacter + assert hex + assert decimal + assert surrogatePair + log "Done" diff --git a/examples/passing/Superclasses1.purs b/examples/passing/Superclasses1.purs --- a/examples/passing/Superclasses1.purs +++ b/examples/passing/Superclasses1.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log, logShow) class Su a where su :: a -> a @@ -17,4 +18,6 @@ test :: forall a. (Cl a) => a -> a test a = su (cl a a) -main = Control.Monad.Eff.Console.print $ test 10.0 +main = do + logShow $ test 10.0 + log "Done" diff --git a/examples/passing/Superclasses3.purs b/examples/passing/Superclasses3.purs --- a/examples/passing/Superclasses3.purs +++ b/examples/passing/Superclasses3.purs @@ -28,7 +28,7 @@ apply = ap instance applicativeMTrace :: Applicative MTrace where - pure = MTrace <<< return + pure = MTrace <<< pure instance bindMTrace :: Bind MTrace where bind m f = MTrace (runMTrace m >>= (runMTrace <<< f)) diff --git a/examples/passing/TCO.purs b/examples/passing/TCO.purs --- a/examples/passing/TCO.purs +++ b/examples/passing/TCO.purs @@ -1,20 +1,20 @@ module Main where import Prelude -import Control.Monad.Eff.Console (print) +import Control.Monad.Eff.Console (log, logShow) main = do let f x = x + 1 let v = 0 - print (applyN 0 f v) - print (applyN 1 f v) - print (applyN 2 f v) - print (applyN 3 f v) - print (applyN 4 f v) + logShow (applyN 0 f v) + logShow (applyN 1 f v) + logShow (applyN 2 f v) + logShow (applyN 3 f v) + logShow (applyN 4 f v) + log "Done" applyN :: forall a. Int -> (a -> a) -> a -> a applyN = go id where go f n _ | n <= 0 = f go f n g = go (f >>> g) (n - 1) g - diff --git a/examples/passing/TCOCase.purs b/examples/passing/TCOCase.purs --- a/examples/passing/TCOCase.purs +++ b/examples/passing/TCOCase.purs @@ -1,10 +1,11 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data Data = One | More Data -main = Control.Monad.Eff.Console.log (from (to 10000.0 One)) +main = log (from (to 10000.0 One)) where to 0.0 a = a to n a = to (n - 1.0) (More a) diff --git a/examples/passing/TailCall.purs b/examples/passing/TailCall.purs --- a/examples/passing/TailCall.purs +++ b/examples/passing/TailCall.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log, logShow) data L a = C a (L a) | N @@ -14,4 +15,6 @@ notATailCall = \x -> (\notATailCall -> notATailCall x) (\x -> x) -main = Control.Monad.Eff.Console.print (test 0.0 (1.0 `C` (2.0 `C` (3.0 `C` N)))) +main = do + logShow (test 0.0 (1.0 `C` (2.0 `C` (3.0 `C` N)))) + log "Done" diff --git a/examples/passing/Tick.purs b/examples/passing/Tick.purs --- a/examples/passing/Tick.purs +++ b/examples/passing/Tick.purs @@ -1,7 +1,8 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) test' x = x -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/TopLevelCase.purs b/examples/passing/TopLevelCase.purs --- a/examples/passing/TopLevelCase.purs +++ b/examples/passing/TopLevelCase.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) gcd :: Number -> Number -> Number gcd 0.0 x = x @@ -15,4 +16,4 @@ parseTest A 0.0 = 0.0 -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/TransitiveImport.purs b/examples/passing/TransitiveImport.purs new file mode 100644 --- /dev/null +++ b/examples/passing/TransitiveImport.purs @@ -0,0 +1,9 @@ +module Main where + + import Prelude + import Middle + import Control.Monad.Eff.Console + + main = do + logShow (middle unit) + log "Done" diff --git a/examples/passing/TransitiveImport/Middle.purs b/examples/passing/TransitiveImport/Middle.purs new file mode 100644 --- /dev/null +++ b/examples/passing/TransitiveImport/Middle.purs @@ -0,0 +1,5 @@ +module Middle where + +import Test (test) + +middle = test diff --git a/examples/passing/TransitiveImport/Test.purs b/examples/passing/TransitiveImport/Test.purs new file mode 100644 --- /dev/null +++ b/examples/passing/TransitiveImport/Test.purs @@ -0,0 +1,9 @@ +module Test where + +import Prelude + +class TestCls a where + test :: a -> a + +instance unitTestCls :: TestCls Unit where + test _ = unit diff --git a/examples/passing/TypeClassMemberOrderChange.purs b/examples/passing/TypeClassMemberOrderChange.purs --- a/examples/passing/TypeClassMemberOrderChange.purs +++ b/examples/passing/TypeClassMemberOrderChange.purs @@ -1,13 +1,16 @@ -module Main where - -import Prelude - -class Test a where - fn :: a -> a -> a - val :: a - -instance testBoolean :: Test Boolean where - val = true - fn x y = y - -main = Control.Monad.Eff.Console.log (show (fn true val)) +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +class Test a where + fn :: a -> a -> a + val :: a + +instance testBoolean :: Test Boolean where + val = true + fn x y = y + +main = do + log (show (fn true val)) + log "Done" diff --git a/examples/passing/TypeClasses.purs b/examples/passing/TypeClasses.purs --- a/examples/passing/TypeClasses.purs +++ b/examples/passing/TypeClasses.purs @@ -1,23 +1,24 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) test1 = \_ -> show "testing" -f :: forall a. (Prelude.Show a) => a -> String +f :: forall a. (Show a) => a -> String f x = show x test2 = \_ -> f "testing" -test7 :: forall a. (Prelude.Show a) => a -> String +test7 :: forall a. (Show a) => a -> String test7 = show test8 = \_ -> show $ "testing" data Data a = Data a -instance showData :: (Prelude.Show a) => Prelude.Show (Data a) where - show (Data a) = "Data (" ++ show a ++ ")" +instance showData :: (Show a) => Show (Data a) where + show (Data a) = "Data (" <> show a <> ")" test3 = \_ -> show (Data "testing") @@ -53,9 +54,9 @@ instance monadMaybe :: Monad Maybe test4 :: forall a m. (Monad m) => a -> m Number -test4 = \_ -> return 1.0 +test4 = \_ -> pure 1.0 -test5 = \_ -> Just 1.0 >>= \n -> return (n + 1.0) +test5 = \_ -> Just 1.0 >>= \n -> pure (n + 1.0) ask r = r @@ -63,7 +64,8 @@ test9 _ = runReader 0.0 $ do n <- ask - return $ n + 1.0 - -main = Control.Monad.Eff.Console.log (test7 "Done") + pure $ n + 1.0 +main = do + log (test7 "Hello") + log "Done" diff --git a/examples/passing/TypeClassesInOrder.purs b/examples/passing/TypeClassesInOrder.purs --- a/examples/passing/TypeClassesInOrder.purs +++ b/examples/passing/TypeClassesInOrder.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) class Foo a where foo :: a -> String @@ -8,4 +9,4 @@ instance fooString :: Foo String where foo s = s -main = Control.Monad.Eff.Console.log $ foo "Done" +main = log $ foo "Done" diff --git a/examples/passing/TypeClassesWithOverlappingTypeVariables.purs b/examples/passing/TypeClassesWithOverlappingTypeVariables.purs --- a/examples/passing/TypeClassesWithOverlappingTypeVariables.purs +++ b/examples/passing/TypeClassesWithOverlappingTypeVariables.purs @@ -1,11 +1,12 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data Either a b = Left a | Right b -instance functorEither :: Prelude.Functor (Either a) where +instance functorEither :: Functor (Either a) where map _ (Left x) = Left x map f (Right y) = Right (f y) -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/TypeDecl.purs b/examples/passing/TypeDecl.purs --- a/examples/passing/TypeDecl.purs +++ b/examples/passing/TypeDecl.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) k :: String -> Number -> String k x y = x @@ -9,4 +10,4 @@ iterate 0.0 f a = a iterate n f a = iterate (n - 1.0) f (f a) -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/TypeOperators.purs b/examples/passing/TypeOperators.purs --- a/examples/passing/TypeOperators.purs +++ b/examples/passing/TypeOperators.purs @@ -1,34 +1,20 @@ -module A - ( Tuple(..) - , type (/\) - , (/\) - , Natural - , type (~>) - ) where - - data Tuple a b = Tuple a b - - infixl 6 Tuple as /\ - infixl 6 type Tuple as /\ - - type Natural f g = ∀ a. f a → g a - - infixr 0 type Natural as ~> +module Main where - tup ∷ ∀ a b. a → b → b /\ a - tup a b = b /\ a +import A (type (~>), type (/\), (/\)) +import Control.Monad.Eff.Console (log) - tupX ∷ ∀ a b c. a /\ b /\ c → c - tupX (a /\ b /\ c) = c +natty ∷ ∀ f. f ~> f +natty x = x -module Main where +data Compose f g a = Compose (f (g a)) - import A (type (~>), type (/\), (/\)) +testPrecedence1 ∷ ∀ f g. Compose f g ~> Compose f g +testPrecedence1 x = x - natty ∷ ∀ f. f ~> f - natty x = x +testPrecedence2 ∷ ∀ f g. f ~> g → f ~> g +testPrecedence2 nat fx = nat fx - swap ∷ ∀ a b. a /\ b → b /\ a - swap (a /\ b) = b /\ a +swap ∷ ∀ a b. a /\ b → b /\ a +swap (a /\ b) = b /\ a - main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/TypeOperators/A.purs b/examples/passing/TypeOperators/A.purs new file mode 100644 --- /dev/null +++ b/examples/passing/TypeOperators/A.purs @@ -0,0 +1,22 @@ +module A +( Tuple(..) +, type (/\) +, (/\) +, Natural +, type (~>) +) where + +data Tuple a b = Tuple a b + +infixl 6 Tuple as /\ +infixl 6 type Tuple as /\ + +type Natural f g = ∀ a. f a → g a + +infixr 0 type Natural as ~> + +tup ∷ ∀ a b. a → b → b /\ a +tup a b = b /\ a + +tupX ∷ ∀ a b c. a /\ b /\ c → c +tupX (a /\ b /\ c) = c diff --git a/examples/passing/TypeSynonymInData.purs b/examples/passing/TypeSynonymInData.purs --- a/examples/passing/TypeSynonymInData.purs +++ b/examples/passing/TypeSynonymInData.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) type A a = Array a @@ -8,4 +9,4 @@ foo (Foo []) = Bar -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/TypeSynonyms.purs b/examples/passing/TypeSynonyms.purs --- a/examples/passing/TypeSynonyms.purs +++ b/examples/passing/TypeSynonyms.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) type Lens a b = { get :: a -> b @@ -24,4 +25,4 @@ test1 :: forall a b c. Lens (Pair (Pair a b) c) a test1 = composeLenses fst fst -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/TypeWildcards.purs b/examples/passing/TypeWildcards.purs --- a/examples/passing/TypeWildcards.purs +++ b/examples/passing/TypeWildcards.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) testTopLevel :: _ -> _ testTopLevel n = n + 1.0 @@ -12,4 +13,4 @@ go a1 a2 | a1 == a2 = a1 go a1 _ = go (f a1) a1 -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/TypeWildcardsRecordExtension.purs b/examples/passing/TypeWildcardsRecordExtension.purs --- a/examples/passing/TypeWildcardsRecordExtension.purs +++ b/examples/passing/TypeWildcardsRecordExtension.purs @@ -1,8 +1,9 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) foo :: forall a. {b :: Number | a} -> {b :: Number | _} foo f = f -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/TypeWithoutParens.purs b/examples/passing/TypeWithoutParens.purs --- a/examples/passing/TypeWithoutParens.purs +++ b/examples/passing/TypeWithoutParens.purs @@ -1,16 +1,12 @@ -module Lib (X, Y) where - - data X = X - type Y = X - module Main where - import Lib (X, Y) +import Lib (X, Y) +import Control.Monad.Eff.Console (log) - idX :: X -> X - idX x = x +idX :: X -> X +idX x = x - idY :: Y -> Y - idY y = y +idY :: Y -> Y +idY y = y - main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/TypeWithoutParens/Lib.purs b/examples/passing/TypeWithoutParens/Lib.purs new file mode 100644 --- /dev/null +++ b/examples/passing/TypeWithoutParens/Lib.purs @@ -0,0 +1,4 @@ +module Lib (X, Y) where + +data X = X +type Y = X diff --git a/examples/passing/TypedBinders.purs b/examples/passing/TypedBinders.purs --- a/examples/passing/TypedBinders.purs +++ b/examples/passing/TypedBinders.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data Tuple a b = Tuple a b @@ -31,27 +32,27 @@ get = State (\s -> Tuple s s) put s = State (\_ -> Tuple s {}) -modify :: forall m s. (Prelude.Monad m, MonadState s m) => (s -> s) -> m {} +modify :: forall m s. (Monad m, MonadState s m) => (s -> s) -> m {} modify f = do s <- get put (f s) test :: Tuple String String test = runState "" $ do - modify $ (++) "World!" - modify $ (++) "Hello, " + modify $ (<>) "World!" + modify $ (<>) "Hello, " str :: String <- get - return str + pure str test2 :: (Int -> Int) -> Int test2 = (\(f :: Int -> Int) -> f 10) -test3 :: Int -> Boolean +test3 :: Int -> Boolean test3 n = case n of (0 :: Int) -> true _ -> false -test4 :: Tuple Int Int -> Tuple Int Int +test4 :: Tuple Int Int -> Tuple Int Int test4 = (\(Tuple a b :: Tuple Int Int) -> Tuple b a) type Int1 = Int @@ -64,4 +65,4 @@ t2 = test2 id t3 = test3 1 t4 = test4 (Tuple 1 0) - Control.Monad.Eff.Console.log "Done" + log "Done" diff --git a/examples/passing/TypedWhere.purs b/examples/passing/TypedWhere.purs --- a/examples/passing/TypedWhere.purs +++ b/examples/passing/TypedWhere.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data E a b = L a | R b @@ -14,4 +15,4 @@ go ls (C (L a) rest) = go (C a ls) rest go ls (C _ rest) = go ls rest -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/UTF8Sourcefile.purs b/examples/passing/UTF8Sourcefile.purs --- a/examples/passing/UTF8Sourcefile.purs +++ b/examples/passing/UTF8Sourcefile.purs @@ -1,10 +1,8 @@ -module Main where - -import Control.Monad.Eff.Console - --- '→' is multibyte sequence \u2192. -utf8multibyte = "Hello λ→ world!!" - -main = do - log "done" - +module Main where + +import Control.Monad.Eff.Console + +-- '→' is multibyte sequence \u2192. +utf8multibyte = "Hello λ→ world!!" + +main = log "Done" diff --git a/examples/passing/UnderscoreIdent.purs b/examples/passing/UnderscoreIdent.purs --- a/examples/passing/UnderscoreIdent.purs +++ b/examples/passing/UnderscoreIdent.purs @@ -1,11 +1,13 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data Data_type = Con_Structor | Con_2 String type Type_name = Data_type done (Con_2 s) = s +done _ = "Failed" -main = Control.Monad.Eff.Console.log (done (Con_2 "Done")) +main = log (done (Con_2 "Done")) diff --git a/examples/passing/UnicodeIdentifier.purs b/examples/passing/UnicodeIdentifier.purs --- a/examples/passing/UnicodeIdentifier.purs +++ b/examples/passing/UnicodeIdentifier.purs @@ -1,5 +1,7 @@ module Main where +import Control.Monad.Eff.Console (log) + f asgård = asgård -main = Control.Monad.Eff.Console.log (f "Done") +main = log (f "Done") diff --git a/examples/passing/UnicodeOperators.purs b/examples/passing/UnicodeOperators.purs --- a/examples/passing/UnicodeOperators.purs +++ b/examples/passing/UnicodeOperators.purs @@ -1,5 +1,7 @@ module Main where +import Control.Monad.Eff.Console (log) + compose :: forall a b c. (b -> c) -> (a -> b) -> a -> c compose f g a = f (g a) @@ -17,4 +19,4 @@ test2 = 1 ∈ emptySet -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/UnicodeType.purs b/examples/passing/UnicodeType.purs --- a/examples/passing/UnicodeType.purs +++ b/examples/passing/UnicodeType.purs @@ -1,23 +1,22 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) -class (Monad m) ⇐ Monad1 m where +class Monad m ⇐ Monad1 m where f1 :: Int -class (Monad m) <= Monad2 m where +class Monad m <= Monad2 m where f2 :: Int f ∷ ∀ m. Monad m ⇒ Int → m Int f n = do - n' ← return n - return n' + n' ← pure n + pure n' f' :: forall m. Monad m => Int -> m Int f' n = do - n' <- return n - return n' - -(←→) a b = a ←→ b + n' <- pure n + pure n' -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/Unit.purs b/examples/passing/Unit.purs --- a/examples/passing/Unit.purs +++ b/examples/passing/Unit.purs @@ -1,6 +1,8 @@ module Main where import Prelude -import Control.Monad.Eff.Console +import Control.Monad.Eff.Console (logShow, log) -main = print (const unit $ "Hello world") +main = do + logShow (const unit $ "Hello world") + log "Done" diff --git a/examples/passing/UnknownInTypeClassLookup.purs b/examples/passing/UnknownInTypeClassLookup.purs --- a/examples/passing/UnknownInTypeClassLookup.purs +++ b/examples/passing/UnknownInTypeClassLookup.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) class EQ a b @@ -11,4 +12,4 @@ runTest a = test a a -main = Control.Monad.Eff.Console.log $ runTest 0.0 +main = log $ runTest 0.0 diff --git a/examples/passing/UntupledConstraints.purs b/examples/passing/UntupledConstraints.purs --- a/examples/passing/UntupledConstraints.purs +++ b/examples/passing/UntupledConstraints.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console +import Control.Monad.Eff.Console (log) class Show a <= Nonsense a where method :: a -> a diff --git a/examples/passing/Where.purs b/examples/passing/Where.purs --- a/examples/passing/Where.purs +++ b/examples/passing/Where.purs @@ -1,8 +1,9 @@ module Main where import Prelude +import Partial.Unsafe (unsafePartial) import Control.Monad.Eff -import Control.Monad.ST +import Control.Monad.Eff.Console (logShow, log) test1 x = y where @@ -14,15 +15,12 @@ x' = x + 1.0 y' = y + 1.0 - test3 = f 1.0 2.0 3.0 where f x y z = x + y + z - test4 = f (+) [1.0, 2.0] where f x [y, z] = x y z - test5 = g 10.0 where f x | x > 0.0 = g (x / 2.0) + 1.0 @@ -39,11 +37,13 @@ go y | (x - 0.1 < y * y) && (y * y < x + 0.1) = y go y = go $ (y + x / y) / 2.0 +main :: Eff _ _ main = do - Control.Monad.Eff.Console.print (test1 1.0) - Control.Monad.Eff.Console.print (test2 1.0 2.0) - Control.Monad.Eff.Console.print test3 - Control.Monad.Eff.Console.print test4 - Control.Monad.Eff.Console.print test5 - Control.Monad.Eff.Console.print test6 - Control.Monad.Eff.Console.print (test7 100.0) + logShow (test1 1.0) + logShow (test2 1.0 2.0) + logShow test3 + unsafePartial (logShow test4) + logShow test5 + logShow test6 + logShow (test7 100.0) + log "Done" diff --git a/examples/passing/WildcardType.purs b/examples/passing/WildcardType.purs new file mode 100644 --- /dev/null +++ b/examples/passing/WildcardType.purs @@ -0,0 +1,12 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +f1 :: (_ -> _) -> _ +f1 g = g 1 + +f2 :: _ -> _ +f2 _ = "Done" + +main = log $ f1 f2 diff --git a/examples/passing/iota.purs b/examples/passing/iota.purs --- a/examples/passing/iota.purs +++ b/examples/passing/iota.purs @@ -1,9 +1,11 @@ module Main where +import Control.Monad.Eff.Console (log) + s = \x -> \y -> \z -> x z (y z) k = \x -> \y -> x iota = \x -> x s k -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/s.purs b/examples/passing/s.purs --- a/examples/passing/s.purs +++ b/examples/passing/s.purs @@ -1,7 +1,8 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) s = \x y z -> x z (y z) -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/warning/DuplicateExportRef.purs b/examples/warning/DuplicateExportRef.purs new file mode 100644 --- /dev/null +++ b/examples/warning/DuplicateExportRef.purs @@ -0,0 +1,30 @@ +-- @shouldWarnWith DuplicateExportRef +-- @shouldWarnWith DuplicateExportRef +-- @shouldWarnWith DuplicateExportRef +-- @shouldWarnWith DuplicateExportRef +-- @shouldWarnWith DuplicateExportRef +-- @shouldWarnWith DuplicateExportRef +-- @shouldWarnWith DuplicateExportRef +module Main + ( X(X, X), X + , fn, fn + , (!), (!) + , class Y, class Y + , Natural, type (~>), type (~>) + , module Prelude, module Prelude + ) where + +import Prelude (Unit) + +data X = X + +fn :: X -> X -> X +fn _ _ = X + +infix 2 fn as ! + +class Y a + +type Natural f g = forall a. f a -> g a + +infixl 1 type Natural as ~> diff --git a/examples/warning/DuplicateImport.purs b/examples/warning/DuplicateImport.purs new file mode 100644 --- /dev/null +++ b/examples/warning/DuplicateImport.purs @@ -0,0 +1,10 @@ +-- @shouldWarnWith DuplicateImport +module Main where + +import Prelude (Unit, unit, pure) +import Prelude (Unit, unit, pure) + +import Control.Monad.Eff (Eff) + +main :: Eff () Unit +main = pure unit diff --git a/examples/warning/DuplicateImportRef.purs b/examples/warning/DuplicateImportRef.purs new file mode 100644 --- /dev/null +++ b/examples/warning/DuplicateImportRef.purs @@ -0,0 +1,18 @@ +-- @shouldWarnWith DuplicateImportRef +-- @shouldWarnWith DuplicateImportRef +-- @shouldWarnWith DuplicateImportRef +-- @shouldWarnWith DuplicateImportRef +module Main where + +import Prelude + ( Unit, Unit + , unit, unit + , class Functor, class Functor + , (<>), (<>) + ) + +u :: Unit +u = unit <> unit + +fid :: forall f a. Functor f => f a -> f a +fid fa = fa diff --git a/examples/warning/DuplicateSelectiveImport.purs b/examples/warning/DuplicateSelectiveImport.purs new file mode 100644 --- /dev/null +++ b/examples/warning/DuplicateSelectiveImport.purs @@ -0,0 +1,10 @@ +-- @shouldWarnWith DuplicateSelectiveImport +module Main where + +import Prelude (Unit, unit) +import Prelude (pure) + +import Control.Monad.Eff (Eff) + +main :: Eff () Unit +main = pure unit diff --git a/examples/warning/HidingImport.purs b/examples/warning/HidingImport.purs new file mode 100644 --- /dev/null +++ b/examples/warning/HidingImport.purs @@ -0,0 +1,9 @@ +-- @shouldWarnWith HidingImport +-- @shouldWarnWith HidingImport +module Main where + +import Prelude hiding (one) +import Control.Monad.Eff hiding (runPure) + +main :: Eff () Unit +main = pure unit diff --git a/examples/warning/ImplicitImport.purs b/examples/warning/ImplicitImport.purs new file mode 100644 --- /dev/null +++ b/examples/warning/ImplicitImport.purs @@ -0,0 +1,9 @@ +-- @shouldWarnWith ImplicitImport +-- @shouldWarnWith ImplicitImport +module Main where + +import Prelude +import Control.Monad.Eff + +main :: Eff () Unit +main = pure unit diff --git a/examples/warning/ImplicitQualifiedImport.purs b/examples/warning/ImplicitQualifiedImport.purs new file mode 100644 --- /dev/null +++ b/examples/warning/ImplicitQualifiedImport.purs @@ -0,0 +1,11 @@ +-- @shouldWarnWith ImplicitQualifiedImport +-- @shouldWarnWith ImplicitQualifiedImport +module Main where + +import Data.Unit + +import Control.Monad.Eff as E +import Control.Monad.Eff.Console as E + +main :: E.Eff (console :: E.CONSOLE) Unit +main = E.log "test" diff --git a/examples/warning/MissingTypeDeclaration.purs b/examples/warning/MissingTypeDeclaration.purs new file mode 100644 --- /dev/null +++ b/examples/warning/MissingTypeDeclaration.purs @@ -0,0 +1,4 @@ +-- @shouldWarnWith MissingTypeDeclaration +module Main where + +x = 0 diff --git a/examples/warning/OverlappingInstances.purs b/examples/warning/OverlappingInstances.purs new file mode 100644 --- /dev/null +++ b/examples/warning/OverlappingInstances.purs @@ -0,0 +1,17 @@ +-- @shouldWarnWith OverlappingInstances +module Main where + +class Test a where + test :: a -> a + +instance testRefl :: Test a where + test x = x + +instance testInt :: Test Int where + test _ = 0 + +-- The OverlappingInstances instances warning only arises when there are two +-- choices for a dictionary, not when the instances are defined. So without +-- `value` this module would not raise a warning. +value :: Int +value = test 1 diff --git a/examples/warning/OverlappingPattern.purs b/examples/warning/OverlappingPattern.purs new file mode 100644 --- /dev/null +++ b/examples/warning/OverlappingPattern.purs @@ -0,0 +1,15 @@ +-- @shouldWarnWith OverlappingPattern +-- @shouldWarnWith OverlappingPattern +module Main where + +data X = A | B + +pat1 :: X -> Boolean +pat1 A = true +pat1 A = true +pat1 B = false + +pat2 :: X -> Boolean +pat2 A = true +pat2 _ = false +pat2 B = false diff --git a/examples/warning/ScopeShadowing.purs b/examples/warning/ScopeShadowing.purs new file mode 100644 --- /dev/null +++ b/examples/warning/ScopeShadowing.purs @@ -0,0 +1,13 @@ +-- @shouldWarnWith ScopeShadowing +module Main where + +import Prelude + +-- No warning at the definition, only when the name is later resolved +data Unit = Unit + +-- This is only a warning as the `Prelude` import is implicit. If `Unit` was +-- named explicitly in an import list, then this refernce to `Unit` +-- would be a `ScopeConflict` error instead. +test :: Unit +test = const Unit unit diff --git a/examples/warning/ShadowedTypeVar.purs b/examples/warning/ShadowedTypeVar.purs new file mode 100644 --- /dev/null +++ b/examples/warning/ShadowedTypeVar.purs @@ -0,0 +1,5 @@ +-- @shouldWarnWith ShadowedTypeVar +module Main where + +f :: forall a. (forall a. a -> a) -> a -> a +f g x = g x diff --git a/examples/warning/UnnecessaryFFIModule.js b/examples/warning/UnnecessaryFFIModule.js new file mode 100644 --- /dev/null +++ b/examples/warning/UnnecessaryFFIModule.js @@ -0,0 +1,1 @@ +exports.out = null; diff --git a/examples/warning/UnnecessaryFFIModule.purs b/examples/warning/UnnecessaryFFIModule.purs new file mode 100644 --- /dev/null +++ b/examples/warning/UnnecessaryFFIModule.purs @@ -0,0 +1,5 @@ +-- @shouldWarnWith UnnecessaryFFIModule +module Main where + +t :: Boolean +t = true diff --git a/examples/warning/UnusedDctorExplicitImport.purs b/examples/warning/UnusedDctorExplicitImport.purs new file mode 100644 --- /dev/null +++ b/examples/warning/UnusedDctorExplicitImport.purs @@ -0,0 +1,8 @@ +-- @shouldWarnWith UnusedDctorExplicitImport +module Main where + +import Data.Ordering (Ordering(EQ, LT)) + +f :: Ordering -> Ordering +f EQ = EQ +f x = x diff --git a/examples/warning/UnusedDctorImportAll.purs b/examples/warning/UnusedDctorImportAll.purs new file mode 100644 --- /dev/null +++ b/examples/warning/UnusedDctorImportAll.purs @@ -0,0 +1,7 @@ +-- @shouldWarnWith UnusedDctorImport +module Main where + +import Data.Ordering (Ordering(..)) + +f :: Ordering -> Ordering +f x = x diff --git a/examples/warning/UnusedDctorImportExplicit.purs b/examples/warning/UnusedDctorImportExplicit.purs new file mode 100644 --- /dev/null +++ b/examples/warning/UnusedDctorImportExplicit.purs @@ -0,0 +1,7 @@ +-- @shouldWarnWith UnusedDctorImport +module Main where + +import Data.Ordering (Ordering(EQ)) + +f :: Ordering -> Ordering +f x = x diff --git a/examples/warning/UnusedExplicitImport.purs b/examples/warning/UnusedExplicitImport.purs new file mode 100644 --- /dev/null +++ b/examples/warning/UnusedExplicitImport.purs @@ -0,0 +1,8 @@ +-- @shouldWarnWith UnusedExplicitImport +module Main where + +import Prelude (Unit, unit, pure, bind) +import Control.Monad.Eff (Eff) + +main :: Eff () Unit +main = pure unit diff --git a/examples/warning/UnusedFFIImplementations.js b/examples/warning/UnusedFFIImplementations.js new file mode 100644 --- /dev/null +++ b/examples/warning/UnusedFFIImplementations.js @@ -0,0 +1,2 @@ +exports.yes = true; +exports.no = false; diff --git a/examples/warning/UnusedFFIImplementations.purs b/examples/warning/UnusedFFIImplementations.purs new file mode 100644 --- /dev/null +++ b/examples/warning/UnusedFFIImplementations.purs @@ -0,0 +1,4 @@ +-- @shouldWarnWith UnusedFFIImplementations +module Main where + +foreign import yes :: Boolean diff --git a/examples/warning/UnusedImport.purs b/examples/warning/UnusedImport.purs new file mode 100644 --- /dev/null +++ b/examples/warning/UnusedImport.purs @@ -0,0 +1,14 @@ +-- @shouldWarnWith UnusedImport +-- @shouldWarnWith UnusedImport +-- @shouldWarnWith UnusedImport +module Main where + +import Data.Unit (Unit, unit) + +-- All of the below are unused +import Control.Monad.Eff +import Control.Monad.Eff.Console as Console +import Test.Assert () + +main :: Unit +main = unit diff --git a/examples/warning/UnusedTypeVar.purs b/examples/warning/UnusedTypeVar.purs new file mode 100644 --- /dev/null +++ b/examples/warning/UnusedTypeVar.purs @@ -0,0 +1,5 @@ +-- @shouldWarnWith UnusedTypeVar +module Main where + +f :: forall a b. a -> a +f x = x diff --git a/examples/warning/WildcardInferredType.purs b/examples/warning/WildcardInferredType.purs new file mode 100644 --- /dev/null +++ b/examples/warning/WildcardInferredType.purs @@ -0,0 +1,23 @@ +-- @shouldWarnWith WildcardInferredType +-- @shouldWarnWith WildcardInferredType +-- @shouldWarnWith WildcardInferredType +-- @shouldWarnWith WildcardInferredType +module Main where + +x :: Int +x = 0 :: _ + +y :: _ +y = 0 + +z :: Int +z = + let n :: _ + n = 0 + in n + +w :: Int +w = n + where + n :: _ + n = 0 diff --git a/hierarchy/Main.hs b/hierarchy/Main.hs --- a/hierarchy/Main.hs +++ b/hierarchy/Main.hs @@ -65,7 +65,7 @@ input <- glob inputGlob modules <- readInput input case modules of - Left errs -> hPutStr stderr (P.prettyPrintMultipleErrors False errs) >> exitFailure + Left errs -> hPutStr stderr (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure Right ms -> do for_ ms $ \(P.Module _ _ moduleName decls _) -> let name = runModuleName moduleName @@ -84,7 +84,7 @@ superClasses :: P.Declaration -> [SuperMap] superClasses (P.TypeClassDeclaration sub _ supers@(_:_) _) = - fmap (\(P.Qualified _ super, _) -> SuperMap (Right (super, sub))) supers + fmap (\(P.Constraint (P.Qualified _ super) _ _) -> SuperMap (Right (super, sub))) supers superClasses (P.TypeClassDeclaration sub _ _ _) = [SuperMap (Left sub)] superClasses (P.PositionedDeclaration _ _ decl) = superClasses decl superClasses _ = [] @@ -113,4 +113,3 @@ infoModList = fullDesc <> headerInfo <> footerInfo headerInfo = header "hierarchy - Creates a GraphViz directed graph of PureScript TypeClasses" footerInfo = footer $ "hierarchy " ++ showVersion Paths.version - diff --git a/psc-bundle/Main.hs b/psc-bundle/Main.hs --- a/psc-bundle/Main.hs +++ b/psc-bundle/Main.hs @@ -6,7 +6,6 @@ -- | Bundles compiled PureScript modules for the browser. module Main (main) where -import Data.Maybe import Data.Traversable (for) import Data.Version (showVersion) @@ -36,7 +35,6 @@ , optionsEntryPoints :: [String] , optionsMainModule :: Maybe String , optionsNamespace :: String - , optionsRequirePath :: Maybe FilePath } deriving Show -- | Given a filename, assuming it is in the correct place on disk, infer a ModuleIdentifier. @@ -63,7 +61,7 @@ let entryIds = map (`ModuleIdentifier` Regular) optionsEntryPoints - bundle input entryIds optionsMainModule optionsNamespace optionsRequirePath + bundle input entryIds optionsMainModule optionsNamespace -- | Command line options parser. options :: Parser Options @@ -72,7 +70,6 @@ <*> many entryPoint <*> optional mainModule <*> namespace - <*> optional requirePath where inputFile :: Parser FilePath inputFile = strArgument $ @@ -104,19 +101,12 @@ <> showDefault <> help "Specify the namespace that PureScript modules will be exported to when running in the browser." - requirePath :: Parser FilePath - requirePath = strOption $ - short 'r' - <> long "require-path" - <> help "The path prefix used in require() calls in the generated JavaScript [deprecated]" - -- | Make it go. main :: IO () main = do hSetEncoding stdout utf8 hSetEncoding stderr utf8 opts <- execParser (info (version <*> helper <*> options) infoModList) - when (isJust (optionsRequirePath opts)) $ hPutStrLn stderr "The require-path option is deprecated and will be removed in PureScript 0.9." output <- runExceptT (app opts) case output of Left err -> do diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs --- a/psc-docs/Main.hs +++ b/psc-docs/Main.hs @@ -95,7 +95,7 @@ Right x -> return x Left err -> do - hPutStrLn stderr $ P.prettyPrintMultipleErrors False err + hPutStrLn stderr $ P.prettyPrintMultipleErrors P.defaultPPEOptions err exitFailure takeByName = takeModulesByName D.modName diff --git a/psc-ide-client/Main.hs b/psc-ide-client/Main.hs --- a/psc-ide-client/Main.hs +++ b/psc-ide-client/Main.hs @@ -35,7 +35,7 @@ client :: PortID -> IO () client port = do h <- - connectTo "localhost" port `catch` + connectTo "127.0.0.1" port `catch` (\(SomeException e) -> putStrLn ("Couldn't connect to psc-ide-server on port: " ++ diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs --- a/psc-ide-server/Main.hs +++ b/psc-ide-server/Main.hs @@ -12,7 +12,6 @@ -- The server accepting commands for psc-ide ----------------------------------------------------------------------------- -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -40,10 +39,10 @@ import Language.PureScript.Ide.Error import Language.PureScript.Ide.Types import Language.PureScript.Ide.Watcher -import Network hiding (socketPort) +import Network hiding (socketPort, accept) import Network.BSD (getProtocolNumber) import Network.Socket hiding (PortNumber, Type, - accept, sClose) + sClose) import Options.Applicative import System.Directory import System.FilePath @@ -73,12 +72,13 @@ { optionsDirectory :: Maybe FilePath , optionsOutputPath :: FilePath , optionsPort :: PortID + , optionsNoWatch :: Bool , optionsDebug :: Bool } main :: IO () main = do - Options dir outputPath port debug <- execParser opts + Options dir outputPath port noWatch debug <- execParser opts maybe (pure ()) setCurrentDirectory dir serverState <- newTVarIO emptyPscIdeState cwd <- getCurrentDirectory @@ -89,31 +89,23 @@ (do putStrLn ("Your output directory didn't exist. I'll create it at: " <> fullOutputPath) createDirectory fullOutputPath putStrLn "This usually means you didn't compile your project yet." - putStrLn "psc-ide needs you to compile your project (for example by running pulp build)" - ) + putStrLn "psc-ide needs you to compile your project (for example by running pulp build)") - _ <- forkFinally (watcher serverState fullOutputPath) print - let conf = - Configuration - { - confDebug = debug - , confOutputPath = outputPath - } - let env = - PscIdeEnvironment - { - envStateVar = serverState - , envConfiguration = conf - } + unless noWatch $ + void (forkFinally (watcher serverState fullOutputPath) print) + + let conf = Configuration {confDebug = debug, confOutputPath = outputPath} + env = PscIdeEnvironment {envStateVar = serverState, envConfiguration = conf} startServer port env where parser = - Options <$> - optional (strOption (long "directory" <> short 'd')) <*> - strOption (long "output-directory" <> value "output/") <*> - (PortNumber . fromIntegral <$> - option auto (long "port" <> short 'p' <> value (4242 :: Integer))) <*> - switch (long "debug") + Options + <$> optional (strOption (long "directory" <> short 'd')) + <*> strOption (long "output-directory" <> value "output/") + <*> (PortNumber . fromIntegral <$> + option auto (long "port" <> short 'p' <> value (4242 :: Integer))) + <*> switch (long "no-watch") + <*> switch (long "debug") opts = info (version <*> helper <*> parser) mempty version = abortOption (InfoMsg (showVersion Paths.version)) @@ -167,7 +159,9 @@ pure (cmd, h) where acceptConnection = liftIO $ do - (h,_,_) <- accept sock + -- Use low level accept to prevent accidental reverse name resolution + (s,_) <- accept sock + h <- socketToHandle s ReadWriteMode hSetEncoding h utf8 hSetBuffering h LineBuffering pure h diff --git a/psc/Main.hs b/psc/Main.hs --- a/psc/Main.hs +++ b/psc/Main.hs @@ -1,56 +1,54 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} module Main where -import Control.Applicative -import Control.Monad -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer.Strict +import Control.Applicative +import Control.Monad +import Control.Monad.Writer.Strict -import Data.List (isSuffixOf, partition) -import Data.Version (showVersion) -import qualified Data.Map as M import qualified Data.Aeson as A +import Data.Bool (bool) import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.UTF8 as BU8 +import qualified Data.Map as M +import Data.Version (showVersion) -import Options.Applicative as Opts +import qualified Language.PureScript as P +import Language.PureScript.Errors.JSON +import Language.PureScript.Make -import System.Exit (exitSuccess, exitFailure) -import System.IO (hSetEncoding, hPutStrLn, stdout, stderr, utf8) -import System.IO.UTF8 -import System.FilePath.Glob (glob) +import Options.Applicative as Opts -import qualified Language.PureScript as P import qualified Paths_purescript as Paths -import Language.PureScript.Make -import Language.PureScript.Errors.JSON +import qualified System.Console.ANSI as ANSI +import System.Exit (exitSuccess, exitFailure) +import System.FilePath.Glob (glob) +import System.IO (hSetEncoding, hPutStrLn, stdout, stderr, utf8) +import System.IO.UTF8 data PSCMakeOptions = PSCMakeOptions { pscmInput :: [FilePath] - , pscmForeignInput :: [FilePath] , pscmOutputDir :: FilePath , pscmOpts :: P.Options , pscmUsePrefix :: Bool , pscmJSONErrors :: Bool } -data InputOptions = InputOptions - { ioInputFiles :: [FilePath] - } - -- | Argumnets: verbose, use JSON, warnings, errors printWarningsAndErrors :: Bool -> Bool -> P.MultipleErrors -> Either P.MultipleErrors a -> IO () printWarningsAndErrors verbose False warnings errors = do + cc <- bool Nothing (Just P.defaultCodeColor) <$> ANSI.hSupportsANSI stderr + let ppeOpts = P.defaultPPEOptions { P.ppeCodeColor = cc, P.ppeFull = verbose } when (P.nonEmpty warnings) $ - hPutStrLn stderr (P.prettyPrintMultipleWarnings verbose warnings) + hPutStrLn stderr (P.prettyPrintMultipleWarnings ppeOpts warnings) case errors of Left errs -> do - hPutStrLn stderr (P.prettyPrintMultipleErrors verbose errs) + hPutStrLn stderr (P.prettyPrintMultipleErrors ppeOpts errs) exitFailure Right _ -> return () printWarningsAndErrors verbose True warnings errors = do @@ -65,14 +63,12 @@ when (null input && not pscmJSONErrors) $ do hPutStrLn stderr "psc: No input files." exitFailure - let (jsFiles, pursFiles) = partition (isSuffixOf ".js") input - moduleFiles <- readInput (InputOptions pursFiles) - inputForeign <- globWarningOnMisses (unless pscmJSONErrors . warnFileTypeNotFound) pscmForeignInput - foreignFiles <- forM (inputForeign ++ jsFiles) (\inFile -> (inFile,) <$> readUTF8File inFile) + moduleFiles <- readInput input (makeErrors, makeWarnings) <- runMake pscmOpts $ do - (ms, foreigns) <- parseInputs moduleFiles foreignFiles - let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, fp)) ms - makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix + ms <- P.parseModulesFromFiles id moduleFiles + let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, Right fp)) ms + foreigns <- inferForeignModules filePathMap + let makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix P.make makeActions (map snd ms) printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors makeWarnings makeErrors exitSuccess @@ -89,28 +85,14 @@ return paths concatMapM f = liftM concat . mapM f -readInput :: InputOptions -> IO [(Either P.RebuildPolicy FilePath, String)] -readInput InputOptions{..} = forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readUTF8File inFile - -parseInputs :: (MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m) - => [(Either P.RebuildPolicy FilePath, String)] - -> [(FilePath, P.ForeignJS)] - -> m ([(Either P.RebuildPolicy FilePath, P.Module)], M.Map P.ModuleName FilePath) -parseInputs modules foreigns = - (,) <$> P.parseModulesFromFiles (either (const "") id) modules - <*> P.parseForeignModulesFromFiles foreigns +readInput :: [FilePath] -> IO [(FilePath, String)] +readInput inputFiles = forM inputFiles $ \inFile -> (inFile, ) <$> readUTF8File inFile inputFile :: Parser FilePath inputFile = strArgument $ metavar "FILE" <> help "The input .purs file(s)" -inputForeignFile :: Parser FilePath -inputForeignFile = strOption $ - short 'f' - <> long "ffi" - <> help "The input .js file(s) providing foreign import implementations" - outputDirectory :: Parser FilePath outputDirectory = strOption $ short 'o' @@ -119,12 +101,6 @@ <> showDefault <> help "The output directory" -requirePath :: Parser (Maybe FilePath) -requirePath = optional $ strOption $ - short 'r' - <> long "require-path" - <> help "The path prefix to use for require() calls in the generated JavaScript [deprecated]" - noTco :: Parser Bool noTco = switch $ long "no-tco" @@ -175,12 +151,10 @@ <*> noOpts <*> verboseErrors <*> (not <$> comments) - <*> requirePath <*> sourceMaps pscMakeOptions :: Parser PSCMakeOptions pscMakeOptions = PSCMakeOptions <$> many inputFile - <*> many inputForeignFile <*> outputDirectory <*> options <*> (not <$> noPrefix) diff --git a/psci/Main.hs b/psci/Main.hs new file mode 100644 --- /dev/null +++ b/psci/Main.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module Main (main) where + +import Prelude () +import Prelude.Compat + +import Data.Monoid ((<>)) +import Data.Version (showVersion) + +import Control.Applicative (many) +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except (ExceptT(..), runExceptT) +import Control.Monad.Trans.State.Strict (StateT, evalStateT) +import Control.Monad.Trans.Reader (ReaderT, runReaderT) + +import qualified Language.PureScript as P +import Language.PureScript.Interactive + +import qualified Options.Applicative as Opts + +import qualified Paths_purescript as Paths + +import System.Console.Haskeline +import System.Exit +import System.FilePath.Glob (glob) + +-- | Command line options +data PSCiOptions = PSCiOptions + { psciMultiLineMode :: Bool + , psciInputFile :: [FilePath] + , psciInputNodeFlags :: [String] + } + +multiLineMode :: Opts.Parser Bool +multiLineMode = Opts.switch $ + Opts.long "multi-line-mode" + <> Opts.short 'm' + <> Opts.help "Run in multi-line mode (use ^D to terminate commands)" + +inputFile :: Opts.Parser FilePath +inputFile = Opts.strArgument $ + Opts.metavar "FILE" + <> Opts.help "Optional .purs files to load on start" + +nodeFlagsFlag :: Opts.Parser [String] +nodeFlagsFlag = Opts.option parser $ + Opts.long "node-opts" + <> Opts.metavar "NODE_OPTS" + <> Opts.value [] + <> Opts.help "Flags to pass to node, separated by spaces" + where + parser = words <$> Opts.str + +psciOptions :: Opts.Parser PSCiOptions +psciOptions = PSCiOptions <$> multiLineMode + <*> many inputFile + <*> nodeFlagsFlag + +version :: Opts.Parser (a -> a) +version = Opts.abortOption (Opts.InfoMsg (showVersion Paths.version)) $ + Opts.long "version" <> + Opts.help "Show the version number" <> + Opts.hidden + +getOpt :: IO PSCiOptions +getOpt = Opts.execParser opts + where + opts = Opts.info (version <*> Opts.helper <*> psciOptions) infoModList + infoModList = Opts.fullDesc <> headerInfo <> footerInfo + headerInfo = Opts.header "psci - Interactive mode for PureScript" + footerInfo = Opts.footer $ "psci " ++ showVersion Paths.version + +-- | Parses the input and returns either a command, or an error as a 'String'. +getCommand :: forall m. MonadException m => Bool -> InputT m (Either String (Maybe Command)) +getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do + firstLine <- withInterrupt $ getInputLine "> " + case firstLine of + Nothing -> return (Right (Just QuitPSCi)) -- Ctrl-D when input is empty + Just "" -> return (Right Nothing) + Just s | singleLineMode || head s == ':' -> return . fmap Just $ parseCommand s + Just s -> fmap Just . parseCommand <$> go [s] + where + go :: [String] -> InputT m String + go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " " + +-- | Get command line options and drop into the REPL +main :: IO () +main = getOpt >>= loop + where + loop :: PSCiOptions -> IO () + loop PSCiOptions{..} = do + inputFiles <- concat <$> traverse glob psciInputFile + e <- runExceptT $ do + modules <- ExceptT (loadAllModules inputFiles) + unless (supportModuleIsDefined (map snd modules)) . liftIO $ do + putStrLn supportModuleMessage + exitFailure + (externs, env) <- ExceptT . runMake . make $ modules + return (modules, externs, env) + case e of + Left errs -> putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure + Right (modules, externs, env) -> do + historyFilename <- getHistoryFilename + let settings = defaultSettings { historyFile = Just historyFilename } + initialState = PSCiState [] [] (zip (map snd modules) externs) + config = PSCiConfig inputFiles psciInputNodeFlags env + runner = flip runReaderT config + . flip evalStateT initialState + . runInputT (setComplete completion settings) + putStrLn prologueMessage + runner go + where + go :: InputT (StateT PSCiState (ReaderT PSCiConfig IO)) () + go = do + c <- getCommand (not psciMultiLineMode) + case c of + Left err -> outputStrLn err >> go + Right Nothing -> go + Right (Just QuitPSCi) -> outputStrLn quitMessage + Right (Just c') -> do + handleInterrupt (outputStrLn "Interrupted.") + (withInterrupt (lift (handleCommand c'))) + go diff --git a/psci/PSCi.hs b/psci/PSCi.hs deleted file mode 100644 --- a/psci/PSCi.hs +++ /dev/null @@ -1,372 +0,0 @@ -{-# LANGUAGE DoAndIfThenElse #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE DataKinds #-} - --- | --- PureScript Compiler Interactive. --- -module PSCi (runPSCi) where - -import Prelude () -import Prelude.Compat - -import Data.Foldable (traverse_) -import Data.List (intercalate, nub, sort, find) -import Data.Tuple (swap) -import qualified Data.Map as M - -import Control.Arrow (first) -import Control.Monad -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Trans.Class -import Control.Monad.Trans.Except (ExceptT(), runExceptT) -import Control.Monad.Trans.State.Strict -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Writer.Strict (Writer(), runWriter) - -import System.Console.Haskeline -import System.Directory (doesFileExist, getHomeDirectory, getCurrentDirectory) -import System.Exit -import System.FilePath (()) -import System.FilePath.Glob (glob) -import System.Process (readProcessWithExitCode) -import System.IO.Error (tryIOError) -import System.IO.UTF8 (readUTF8File) - -import qualified Language.PureScript as P -import qualified Language.PureScript.Names as N - -import PSCi.Completion (completion) -import PSCi.Parser (parseCommand) -import PSCi.Option -import PSCi.Types -import PSCi.Message -import PSCi.IO -import PSCi.Printer -import PSCi.Module - --- | --- PSCI monad --- -newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad) - -psciIO :: IO a -> PSCI a -psciIO io = PSCI . lift $ lift io - --- | --- The runner --- -runPSCi :: IO () -runPSCi = getOpt >>= loop - --- | --- The PSCI main loop. --- -loop :: PSCiOptions -> IO () -loop PSCiOptions{..} = do - config <- loadUserConfig - inputFiles <- concat <$> traverse glob psciInputFile - foreignFiles <- concat <$> traverse glob psciForeignInputFiles - modulesOrFirstError <- loadAllModules inputFiles - case modulesOrFirstError of - Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure - Right modules -> do - historyFilename <- getHistoryFilename - let settings = defaultSettings { historyFile = Just historyFilename } - foreignsOrError <- runMake $ do - foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> makeIO (const (P.ErrorMessage [] $ P.CannotReadFile inFile)) (readUTF8File inFile)) - P.parseForeignModulesFromFiles foreignFilesContent - case foreignsOrError of - Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure - Right foreigns -> - flip evalStateT (mkPSCiState [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do - outputStrLn prologueMessage - traverse_ (traverse_ (runPSCI . handleCommand)) config - modules' <- lift $ gets psciLoadedModules - unless (consoleIsDefined (map snd modules')) . outputStrLn $ unlines - [ "PSCi requires the purescript-console module to be installed." - , "For help getting started, visit http://wiki.purescript.org/PSCi" - ] - go - where - go :: InputT (StateT PSCiState IO) () - go = do - c <- getCommand (not psciMultiLineMode) - case c of - Left err -> outputStrLn err >> go - Right Nothing -> go - Right (Just QuitPSCi) -> outputStrLn quitMessage - Right (Just c') -> do - handleInterrupt (outputStrLn "Interrupted.") - (withInterrupt (runPSCI (loadAllImportedModules >> handleCommand c'))) - go - --- Compile the module - --- | --- Load all modules, updating the application state --- -loadAllImportedModules :: PSCI () -loadAllImportedModules = do - files <- PSCI . lift $ fmap psciImportedFilenames get - modulesOrFirstError <- psciIO $ loadAllModules files - case modulesOrFirstError of - Left errs -> PSCI $ printErrors errs - Right modules -> PSCI . lift . modify $ updateModules modules - --- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the --- options and ignores the warning messages. -runMake :: P.Make a -> IO (Either P.MultipleErrors a) -runMake mk = fst <$> P.runMake P.defaultOptions mk - -makeIO :: (IOError -> P.ErrorMessage) -> IO a -> P.Make a -makeIO f io = do - e <- liftIO $ tryIOError io - either (throwError . P.singleError . f) return e - -make :: PSCiState -> [P.Module] -> P.Make P.Environment -make st@PSCiState{..} ms = P.make actions' (map snd loadedModules ++ ms) - where - filePathMap = M.fromList $ (first P.getModuleName . swap) `map` allModules - actions = P.buildMakeActions modulesDir filePathMap psciForeignFiles False - actions' = actions { P.progress = const (return ()) } - loadedModules = psciLoadedModules st - allModules = map (first Right) loadedModules ++ map (Left P.RebuildAlways,) ms - - --- Commands - --- | --- Parses the input and returns either a Metacommand, or an error as a string. --- -getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command)) -getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do - firstLine <- withInterrupt $ getInputLine "> " - case firstLine of - Nothing -> return (Right (Just QuitPSCi)) -- Ctrl-D when input is empty - Just "" -> return (Right Nothing) - Just s | singleLineMode || head s == ':' -> return .fmap Just $ parseCommand s - Just s -> fmap Just . parseCommand <$> go [s] - where - go :: [String] -> InputT (StateT PSCiState IO) String - go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " " - --- | --- Performs an action for each meta-command given, and also for expressions. --- -handleCommand :: Command -> PSCI () -handleCommand (Expression val) = handleExpression val -handleCommand ShowHelp = PSCI $ outputStrLn helpMessage -handleCommand (Import im) = handleImport im -handleCommand (Decls l) = handleDecls l -handleCommand (LoadFile filePath) = PSCI $ whenFileExists filePath $ \absPath -> do - m <- lift . lift $ loadModule absPath - case m of - Left err -> outputStrLn err - Right mods -> lift $ modify (updateModules (map (absPath,) mods)) -handleCommand (LoadForeign filePath) = PSCI $ whenFileExists filePath $ \absPath -> do - foreignsOrError <- lift . lift . runMake $ do - foreignFile <- makeIO (const (P.ErrorMessage [] $ P.CannotReadFile absPath)) (readUTF8File absPath) - P.parseForeignModulesFromFiles [(absPath, foreignFile)] - case foreignsOrError of - Left err -> outputStrLn $ P.prettyPrintMultipleErrors False err - Right foreigns -> lift $ modify (updateForeignFiles foreigns) -handleCommand ResetState = do - PSCI . lift . modify $ \st -> - st { psciImportedModules = [] - , psciLetBindings = [] - } - loadAllImportedModules -handleCommand (TypeOf val) = handleTypeOf val -handleCommand (KindOf typ) = handleKindOf typ -handleCommand (BrowseModule moduleName) = handleBrowse moduleName -handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules -handleCommand (ShowInfo QueryImport) = handleShowImportedModules -handleCommand QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug." - - --- | --- Takes a value expression and evaluates it with the current state. --- -handleExpression :: P.Expr -> PSCI () -handleExpression val = do - st <- PSCI $ lift get - let m = createTemporaryModule True st val - let nodeArgs = psciNodeFlags st ++ [indexFile] - e <- psciIO . runMake $ make st [supportModule, m] - case e of - Left errs -> PSCI $ printErrors errs - Right _ -> do - psciIO $ writeFile indexFile "require('$PSCI')['$main']();" - process <- psciIO findNodeProcess - result <- psciIO $ traverse (\node -> readProcessWithExitCode node nodeArgs "") process - case result of - Just (ExitSuccess, out, _) -> PSCI $ outputStrLn out - Just (ExitFailure _, _, err) -> PSCI $ outputStrLn err - Nothing -> PSCI $ outputStrLn "Couldn't find node.js" - --- | --- Takes a list of declarations and updates the environment, then run a make. If the declaration fails, --- restore the original environment. --- -handleDecls :: [P.Declaration] -> PSCI () -handleDecls ds = do - st <- PSCI $ lift get - let st' = updateLets ds st - let m = createTemporaryModule False st' (P.Literal (P.ObjectLiteral [])) - e <- psciIO . runMake $ make st' [m] - case e of - Left err -> PSCI $ printErrors err - Right _ -> PSCI $ lift (put st') - --- | --- Show actual loaded modules in psci. --- -handleShowLoadedModules :: PSCI () -handleShowLoadedModules = do - loadedModules <- PSCI $ lift $ gets psciLoadedModules - psciIO $ readModules loadedModules >>= putStrLn - return () - where readModules = return . unlines . sort . nub . map toModuleName - toModuleName = N.runModuleName . (\ (P.Module _ _ mdName _ _) -> mdName) . snd - --- | --- Show the imported modules in psci. --- -handleShowImportedModules :: PSCI () -handleShowImportedModules = do - PSCiState { psciImportedModules = importedModules } <- PSCI $ lift get - psciIO $ showModules importedModules >>= putStrLn - return () - where - showModules = return . unlines . sort . map showModule - showModule (mn, declType, asQ) = - "import " ++ N.runModuleName mn ++ showDeclType declType ++ - foldMap (\mn' -> " as " ++ N.runModuleName mn') asQ - - 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 (P.TypeRef pn dctors) = N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")" - showRef (P.TypeOpRef ident) = "type (" ++ N.runIdent ident ++ ")" - showRef (P.ValueRef ident) = N.runIdent ident - showRef (P.TypeClassRef pn) = "class " ++ N.runProperName pn - showRef (P.ProperRef pn) = pn - showRef (P.TypeInstanceRef ident) = N.runIdent ident - showRef (P.ModuleRef name) = "module " ++ N.runModuleName name - showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref - - commaList :: [String] -> String - commaList = intercalate ", " - --- | --- Imports a module, preserving the initial state on failure. --- -handleImport :: ImportedModule -> PSCI () -handleImport im = do - st <- updateImportedModules im <$> PSCI (lift get) - let m = createTemporaryModuleForImports st - e <- psciIO . runMake $ make st [m] - case e of - Left errs -> PSCI $ printErrors errs - Right _ -> do - PSCI $ lift $ put st - return () - --- | --- Takes a value and prints its type --- -handleTypeOf :: P.Expr -> PSCI () -handleTypeOf val = do - st <- PSCI $ lift get - let m = createTemporaryModule False st val - e <- psciIO . runMake $ make st [m] - case e of - Left errs -> PSCI $ 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 - Nothing -> PSCI $ outputStrLn "Could not find type" - --- | --- Browse a module and displays its signature (if module exists). --- -handleBrowse :: P.ModuleName -> PSCI () -handleBrowse moduleName = do - st <- PSCI $ lift get - env <- psciIO . runMake $ make st [] - case env of - Left errs -> PSCI $ printErrors errs - Right env' -> - if isModInEnv moduleName st - then PSCI $ printModuleSignatures moduleName env' - else case lookupUnQualifiedModName moduleName st of - Just unQualifiedName -> - if isModInEnv unQualifiedName st - then PSCI $ printModuleSignatures unQualifiedName env' - else failNotInEnv moduleName - Nothing -> - failNotInEnv moduleName - where - isModInEnv modName = - any ((== modName) . P.getModuleName . snd) . psciLoadedModules - failNotInEnv modName = - PSCI $ outputStrLn $ "Module '" ++ N.runModuleName modName ++ "' is not valid." - lookupUnQualifiedModName quaModName st = - (\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st) - --- | --- Takes a value and prints its kind --- -handleKindOf :: P.Type -> PSCI () -handleKindOf typ = do - st <- PSCI $ lift get - let m = createTemporaryModuleForKind st typ - mName = P.ModuleName [P.ProperName "$PSCI"] - e <- psciIO . runMake $ make st [m] - case e of - Left errs -> PSCI $ printErrors errs - Right env' -> - case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of - Just (_, typ') -> do - let chk = (P.emptyCheckState env') { P.checkCurrentModule = Just mName } - k = check (P.kindOf typ') chk - - check :: StateT P.CheckState (ExceptT P.MultipleErrors (Writer P.MultipleErrors)) a -> P.CheckState -> Either P.MultipleErrors (a, P.CheckState) - check sew = fst . runWriter . runExceptT . runStateT sew - case k of - Left errStack -> PSCI . outputStrLn . P.prettyPrintMultipleErrors False $ errStack - Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind - Nothing -> PSCI $ outputStrLn "Could not find kind" - --- Misc - --- | --- Attempts to read initial commands from '.psci' in the present working --- directory then the user's home --- -loadUserConfig :: IO (Maybe [Command]) -loadUserConfig = onFirstFileMatching readCommands pathGetters - where - pathGetters = [getCurrentDirectory, getHomeDirectory] - readCommands :: IO FilePath -> IO (Maybe [Command]) - readCommands path = do - configFile <- ( ".psci") <$> path - exists <- doesFileExist configFile - if exists - then do - ls <- lines <$> readUTF8File configFile - case traverse parseCommand ls of - Left err -> print err >> exitFailure - Right cs -> return $ Just cs - else - return Nothing - --- | Checks if the Console module is defined -consoleIsDefined :: [P.Module] -> Bool -consoleIsDefined = any ((== P.ModuleName (map P.ProperName [ "Control", "Monad", "Eff", "Console" ])) . P.getModuleName) diff --git a/psci/PSCi/Completion.hs b/psci/PSCi/Completion.hs deleted file mode 100644 --- a/psci/PSCi/Completion.hs +++ /dev/null @@ -1,226 +0,0 @@ -{-# LANGUAGE DataKinds #-} - -module PSCi.Completion where - -import Prelude () -import Prelude.Compat - -import Data.Maybe (mapMaybe) -import Data.List (nub, nubBy, sortBy, isPrefixOf, stripPrefix) -import Data.Char (isUpper) -import Data.Function (on) - -import Control.Arrow (second) -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 PSCi.Directive as D -import PSCi.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, Read) - --- | --- 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 w Foreign = [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 :: (a -> String) -> (P.Module -> [(a, P.Declaration)]) -> CompletionM [String] -mapLoadedModulesAndQualify sho f = do - ms <- getLoadedModules - let argPairs = do m <- ms - fm <- f m - return (m, fm) - concat <$> traverse (uncurry (getAllQualifications sho)) argPairs - -getIdentNames :: CompletionM [String] -getIdentNames = mapLoadedModulesAndQualify P.showIdent identNames - -getDctorNames :: CompletionM [String] -getDctorNames = mapLoadedModulesAndQualify P.runProperName dctorNames - -getTypeNames :: CompletionM [String] -getTypeNames = mapLoadedModulesAndQualify P.runProperName 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 :: (a -> String) -> P.Module -> (a, P.Declaration) -> CompletionM [String] -getAllQualifications sho 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 = P.showQualified sho (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 -> [q | referencedBy refs] - P.Hiding refs -> [q | not $ referencedBy refs] - - --- | 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 'N.TypeName, P.Declaration)] -typeDecls = mapMaybe getTypeName . filter P.isDataDecl . P.exportedDeclarations - where - getTypeName :: P.Declaration -> Maybe (N.ProperName 'N.TypeName, 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 . concatMap getDeclNames . P.exportedDeclarations - where - getDeclNames :: P.Declaration -> [(P.Ident, P.Declaration)] - getDeclNames d@(P.ValueDeclaration ident _ _ _) = [(ident, d)] - getDeclNames d@(P.TypeDeclaration ident _ ) = [(ident, d)] - getDeclNames d@(P.ExternDeclaration ident _) = [(ident, d)] - getDeclNames d@(P.TypeClassDeclaration _ _ _ ds) = map (second (const d)) $ concatMap getDeclNames ds - getDeclNames (P.PositionedDeclaration _ _ d) = getDeclNames d - getDeclNames _ = [] - -dctorNames :: P.Module -> [(N.ProperName 'N.ConstructorName, P.Declaration)] -dctorNames = nubOnFst . concatMap go . P.exportedDeclarations - where - go :: P.Declaration -> [(N.ProperName 'N.ConstructorName, P.Declaration)] - go decl@(P.DataDeclaration _ _ _ ctors) = map (\n -> (n, decl)) (map fst ctors) - go (P.PositionedDeclaration _ _ d) = go d - go _ = [] - -moduleNames :: [P.Module] -> [String] -moduleNames ms = nub [P.runModuleName 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/PSCi/Directive.hs b/psci/PSCi/Directive.hs deleted file mode 100644 --- a/psci/PSCi/Directive.hs +++ /dev/null @@ -1,119 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Directive --- Copyright : --- License : MIT --- --- Maintainer : --- Stability : experimental --- Portability : --- --- | --- Directives for PSCI. --- ------------------------------------------------------------------------------ - -module PSCi.Directive where - -import Prelude () -import Prelude.Compat - - -import Data.Maybe (fromJust, listToMaybe) -import Data.List (isPrefixOf) -import Data.Tuple (swap) - -import PSCi.Types - --- | --- List of all avaliable directives. --- -directives :: [Directive] -directives = map fst directiveStrings - --- | --- A mapping of directives to the different strings that can be used to invoke --- them. --- -directiveStrings :: [(Directive, [String])] -directiveStrings = - [ (Help , ["?", "help"]) - , (Quit , ["quit"]) - , (Reset , ["reset"]) - , (Browse , ["browse"]) - , (Load , ["load", "module"]) - , (Foreign, ["foreign"]) - , (Type , ["type"]) - , (Kind , ["kind"]) - , (Show , ["show"]) - ] - --- | --- Like directiveStrings, but the other way around. --- -directiveStrings' :: [(String, Directive)] -directiveStrings' = concatMap go directiveStrings - where - go (dir, strs) = map (\s -> (s, dir)) strs - --- | --- List of all directive strings. --- -strings :: [String] -strings = concatMap snd directiveStrings - --- | --- Returns all possible string representations of a directive. --- -stringsFor :: Directive -> [String] -stringsFor d = fromJust (lookup d directiveStrings) - --- | --- Returns the default string representation of a directive. --- -stringFor :: Directive -> String -stringFor = head . stringsFor - --- | --- Returns the list of directives which could be expanded from the string --- argument, together with the string alias that matched. --- -directivesFor' :: String -> [(Directive, String)] -directivesFor' str = go directiveStrings' - where - go = map swap . filter ((str `isPrefixOf`) . fst) - -directivesFor :: String -> [Directive] -directivesFor = map fst . directivesFor' - -directiveStringsFor :: String -> [String] -directiveStringsFor = map snd . directivesFor' - -parseDirective :: String -> Maybe Directive -parseDirective = listToMaybe . directivesFor - --- | --- 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. --- -help :: [(Directive, String, String)] -help = - [ (Help, "", "Show this help menu") - , (Quit, "", "Quit PSCi") - , (Reset, "", "Discard all imported modules and declared bindings") - , (Browse, "", "See all functions in ") - , (Load, "", "Load for importing") - , (Foreign, "", "Load foreign module ") - , (Type, "", "Show the type of ") - , (Kind, "", "Show the kind of ") - , (Show, "import", "Show all imported modules") - , (Show, "loaded", "Show all loaded modules") - ] - diff --git a/psci/PSCi/IO.hs b/psci/PSCi/IO.hs deleted file mode 100644 --- a/psci/PSCi/IO.hs +++ /dev/null @@ -1,68 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : IO --- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -module PSCi.IO where - -import Prelude () -import Prelude.Compat - -import System.Directory (createDirectoryIfMissing, getHomeDirectory, findExecutable, doesFileExist) -import System.FilePath (takeDirectory, (), isPathSeparator) -import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) -import Control.Monad (msum) -import Control.Monad.IO.Class (MonadIO, liftIO) -import System.Console.Haskeline (outputStrLn, InputT) - -mkdirp :: FilePath -> IO () -mkdirp = createDirectoryIfMissing True . takeDirectory - --- File helpers - -onFirstFileMatching :: Monad m => (b -> m (Maybe a)) -> [b] -> m (Maybe a) -onFirstFileMatching f pathVariants = runMaybeT . msum $ map (MaybeT . f) pathVariants - --- | --- Locates the node executable. --- Checks for either @nodejs@ or @node@. --- -findNodeProcess :: IO (Maybe String) -findNodeProcess = onFirstFileMatching findExecutable names - where names = ["nodejs", "node"] - --- | --- Grabs the filename where the history is stored. --- -getHistoryFilename :: IO FilePath -getHistoryFilename = do - home <- getHomeDirectory - let filename = home ".purescript" "psci_history" - mkdirp filename - return filename - - --- | --- Expands tilde in path. --- -expandTilde :: FilePath -> IO FilePath -expandTilde ('~':p:rest) | isPathSeparator p = ( rest) <$> getHomeDirectory -expandTilde p = return p - - -whenFileExists :: MonadIO m => FilePath -> (FilePath -> InputT m ()) -> InputT m () -whenFileExists filePath f = do - absPath <- liftIO $ expandTilde filePath - exists <- liftIO $ doesFileExist absPath - if exists - then f absPath - else outputStrLn $ "Couldn't locate: " ++ filePath diff --git a/psci/PSCi/Message.hs b/psci/PSCi/Message.hs deleted file mode 100644 --- a/psci/PSCi/Message.hs +++ /dev/null @@ -1,53 +0,0 @@ -module PSCi.Message where - - -import Data.List (intercalate) -import qualified PSCi.Directive as D -import PSCi.Types - --- Messages - --- | --- The help message. --- -helpMessage :: String -helpMessage = "The following commands are available:\n\n " ++ - intercalate "\n " (map line D.help) ++ - "\n\n" ++ extraHelp - where - line :: (Directive, String, String) -> String - line (dir, arg, desc) = - let cmd = ':' : D.stringFor dir - in unwords [ 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. --- -prologueMessage :: String -prologueMessage = intercalate "\n" - [ " ____ ____ _ _ " - , "| _ \\ _ _ _ __ ___/ ___| ___ _ __(_)_ __ | |_ " - , "| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|" - , "| __/| |_| | | | __/___) | (__| | | | |_) | |_ " - , "|_| \\__,_|_| \\___|____/ \\___|_| |_| .__/ \\__|" - , " |_| " - , "" - , ":? shows help" - ] - --- | --- The quit message. --- -quitMessage :: String -quitMessage = "See ya!" - diff --git a/psci/PSCi/Module.hs b/psci/PSCi/Module.hs deleted file mode 100644 --- a/psci/PSCi/Module.hs +++ /dev/null @@ -1,107 +0,0 @@ -module PSCi.Module where - -import Prelude () -import Prelude.Compat - -import qualified Language.PureScript as P -import PSCi.Types -import System.FilePath (pathSeparator) -import System.IO.UTF8 (readUTF8File) -import Control.Monad - --- | The name of the PSCI support module -supportModuleName :: P.ModuleName -supportModuleName = P.ModuleName [P.ProperName "$PSCI", P.ProperName "Support"] - --- | Support module, contains code to evaluate terms -supportModule :: P.Module -supportModule = - case P.parseModulesFromFiles id [("", code)] of - Right [(_, P.Module ss cs _ ds exps)] -> P.Module ss cs supportModuleName ds exps - _ -> P.internalError "Support module could not be parsed" - where - code :: String - code = unlines - [ "module S where" - , "" - , "import Prelude" - , "import Control.Monad.Eff" - , "import Control.Monad.Eff.Console" - , "import Control.Monad.Eff.Unsafe" - , "" - , "class Eval a where" - , " eval :: a -> Eff (console :: CONSOLE) Unit" - , "" - , "instance evalShow :: (Show a) => Eval a where" - , " eval = print" - , "" - , "instance evalEff :: (Eval a) => Eval (Eff eff a) where" - , " eval x = unsafeInterleaveEff x >>= eval" - ] - --- Module Management - --- | --- Loads a file for use with imports. --- -loadModule :: FilePath -> IO (Either String [P.Module]) -loadModule filename = do - content <- readUTF8File filename - return $ either (Left . P.prettyPrintMultipleErrors False) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)] - --- | --- Load all modules. --- -loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)]) -loadAllModules files = do - filesAndContent <- forM files $ \filename -> do - content <- readUTF8File filename - return (filename, content) - return $ P.parseModulesFromFiles id filesAndContent - - --- | --- Makes a volatile module to execute the current expression. --- -createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module -createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindings = lets} val = - let - moduleName = P.ModuleName [P.ProperName "$PSCI"] - trace = P.Var (P.Qualified (Just supportModuleName) (P.Ident "eval")) - mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it"))) - itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] $ Right val - mainDecl = P.ValueDeclaration (P.Ident "$main") P.Public [] $ Right mainValue - decls = if exec then [itDecl, mainDecl] else [itDecl] - in - P.Module (P.internalModuleSourceSpan "") [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing - - --- | --- Makes a volatile module to hold a non-qualified type synonym for a fully-qualified data type declaration. --- -createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module -createTemporaryModuleForKind PSCiState{psciImportedModules = imports, psciLetBindings = lets} typ = - let - moduleName = P.ModuleName [P.ProperName "$PSCI"] - itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ - in - P.Module (P.internalModuleSourceSpan "") [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing - --- | --- Makes a volatile module to execute the current imports. --- -createTemporaryModuleForImports :: PSCiState -> P.Module -createTemporaryModuleForImports PSCiState{psciImportedModules = imports} = - let - moduleName = P.ModuleName [P.ProperName "$PSCI"] - in - P.Module (P.internalModuleSourceSpan "") [] moduleName (importDecl `map` imports) Nothing - -importDecl :: ImportedModule -> P.Declaration -importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ False - -indexFile :: FilePath -indexFile = ".psci_modules" ++ pathSeparator : "index.js" - -modulesDir :: FilePath -modulesDir = ".psci_modules" ++ pathSeparator : "node_modules" diff --git a/psci/PSCi/Option.hs b/psci/PSCi/Option.hs deleted file mode 100644 --- a/psci/PSCi/Option.hs +++ /dev/null @@ -1,57 +0,0 @@ -module PSCi.Option ( - getOpt -) where - -import Prelude () -import Prelude.Compat - -import Options.Applicative as Opts -import Data.Version (showVersion) - -import PSCi.Types -import qualified Paths_purescript as Paths - --- Parse Command line option - -multiLineMode :: Parser Bool -multiLineMode = switch $ - long "multi-line-mode" - <> short 'm' - <> Opts.help "Run in multi-line mode (use ^D to terminate commands)" - -inputFile :: Parser FilePath -inputFile = strArgument $ - metavar "FILE" - <> Opts.help "Optional .purs files to load on start" - -inputForeignFile :: Parser FilePath -inputForeignFile = strOption $ - short 'f' - <> long "ffi" - <> help "The input .js file(s) providing foreign import implementations" - -nodeFlagsFlag :: Parser [String] -nodeFlagsFlag = option parser $ - long "node-opts" - <> metavar "NODE_OPTS" - <> value [] - <> Opts.help "Flags to pass to node, separated by spaces" - where - parser = words <$> str - -psciOptions :: Parser PSCiOptions -psciOptions = PSCiOptions <$> multiLineMode - <*> many inputFile - <*> many inputForeignFile - <*> nodeFlagsFlag - -version :: Parser (a -> a) -version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> Opts.help "Show the version number" <> hidden - -getOpt :: IO PSCiOptions -getOpt = execParser opts - where - opts = info (version <*> helper <*> psciOptions) infoModList - infoModList = fullDesc <> headerInfo <> footerInfo - headerInfo = header "psci - Interactive mode for PureScript" - footerInfo = footer $ "psci " ++ showVersion Paths.version diff --git a/psci/PSCi/Parser.hs b/psci/PSCi/Parser.hs deleted file mode 100644 --- a/psci/PSCi/Parser.hs +++ /dev/null @@ -1,140 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Parser --- Copyright : (c) Phil Freeman 2014 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- Parser for PSCI. --- ------------------------------------------------------------------------------ - -module PSCi.Parser - ( parseCommand - ) where - -import Prelude () -import Prelude.Compat hiding (lex) - -import Data.Char (isSpace) -import Data.List (intercalate) - -import Text.Parsec hiding ((<|>)) - -import qualified Language.PureScript as P -import Language.PureScript.Parser.Common (mark, same) - -import qualified PSCi.Directive as D -import PSCi.Types - --- | --- Parses PSCI metacommands or expressions input from the user. --- -parseCommand :: String -> Either String Command -parseCommand cmdString = - case cmdString of - (':' : cmd) -> parseDirective cmd - _ -> parseRest psciCommand cmdString - -parseRest :: P.TokenParser a -> String -> Either String a -parseRest p s = either (Left . show) Right $ do - ts <- P.lex "" s - P.runTokenParser "" (p <* eof) ts - -psciCommand :: P.TokenParser Command -psciCommand = choice (map try parsers) - where - parsers = - [ psciLet - , psciImport - , psciOtherDeclaration - , psciExpression - ] - -trim :: String -> String -trim = trimEnd . trimStart - -trimStart :: String -> String -trimStart = dropWhile isSpace - -trimEnd :: String -> String -trimEnd = reverse . trimStart . reverse - -parseDirective :: String -> Either String Command -parseDirective cmd = - case D.directivesFor' dstr of - [(d, _)] -> commandFor d - [] -> Left "Unrecognized directive. Type :? for help." - ds -> Left ("Ambiguous directive. Possible matches: " ++ - intercalate ", " (map snd ds) ++ ". Type :? for help.") - where - (dstr, arg) = break isSpace cmd - - commandFor d = case d of - Help -> return ShowHelp - Quit -> return QuitPSCi - Reset -> return ResetState - Browse -> BrowseModule <$> parseRest P.moduleName arg - Load -> return $ LoadFile (trim arg) - Foreign -> return $ LoadForeign (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 Command -psciExpression = Expression <$> P.parseValue - --- | --- PSCI version of @let@. --- This is essentially let from do-notation. --- However, since we don't support the @Eff@ monad, --- we actually want the normal @let@. --- -psciLet :: P.TokenParser Command -psciLet = Decls <$> (P.reserved "let" *> P.indented *> manyDecls) - where - manyDecls :: P.TokenParser [P.Declaration] - manyDecls = mark (many1 (same *> P.parseLocalDeclaration)) - --- | Imports must be handled separately from other declarations, so that --- :show import works, for example. -psciImport :: P.TokenParser Command -psciImport = do - (mn, declType, asQ, _) <- P.parseImportDeclaration' - return $ Import (mn, declType, asQ) - --- | Any other declaration that we don't need a 'special case' parser for --- (like let or import declarations). -psciOtherDeclaration :: P.TokenParser Command -psciOtherDeclaration = Decls . (:[]) <$> do - decl <- discardPositionInfo <$> P.parseDeclaration - if acceptable decl - then return decl - else fail "this kind of declaration is not supported in psci" - -discardPositionInfo :: P.Declaration -> P.Declaration -discardPositionInfo (P.PositionedDeclaration _ _ d) = d -discardPositionInfo d = d - -acceptable :: P.Declaration -> Bool -acceptable P.DataDeclaration{} = True -acceptable P.TypeSynonymDeclaration{} = True -acceptable P.ExternDeclaration{} = True -acceptable P.ExternDataDeclaration{} = 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/PSCi/Printer.hs b/psci/PSCi/Printer.hs deleted file mode 100644 --- a/psci/PSCi/Printer.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DataKinds #-} - -module PSCi.Printer where - -import Prelude () -import Prelude.Compat - -import qualified Language.PureScript as P -import qualified Text.PrettyPrint.Boxes as Box -import qualified Data.Map as M -import System.Console.Haskeline -import Data.Maybe (mapMaybe) -import Data.List (intersperse) -import Control.Monad.IO.Class (MonadIO) - --- Printers - --- | --- Pretty print a module's signatures --- -printModuleSignatures :: MonadIO m => P.ModuleName -> P.Environment -> InputT m () -printModuleSignatures moduleName (P.Environment {..}) = - -- get relevant components of a module from environment - let moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) names - moduleTypeClasses = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) typeClasses - moduleTypes = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) types - - in - -- print each component - (outputStr . unlines . map trimEnd . lines . Box.render . Box.vsep 1 Box.left) - [ printModule's (mapMaybe (showTypeClass . findTypeClass typeClasses)) moduleTypeClasses -- typeClasses - , printModule's (mapMaybe (showType typeClasses dataConstructors typeSynonyms . findType types)) moduleTypes -- types - , printModule's (map (showNameType . findNameType names)) moduleNamesIdent -- functions - ] - - where printModule's showF = Box.vsep 1 Box.left . showF - - findNameType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) - findNameType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames) - - showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box - showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType - showNameType _ = P.internalError "The impossible happened in printModuleSignatures." - - findTypeClass - :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]) - -> P.Qualified (P.ProperName 'P.ClassName) - -> (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])) - findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses) - - showTypeClass - :: (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])) - -> Maybe Box.Box - showTypeClass (_, Nothing) = Nothing - showTypeClass (P.Qualified _ name, Just (vars, body, constrs)) = - let constraints = - if null constrs - then Box.text "" - else Box.text "(" - Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Qualified _ pn, lt) -> Box.text (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) constrs) - Box.<> Box.text ") <= " - className = - Box.text (P.runProperName name) - Box.<> Box.text (concatMap ((' ':) . fst) vars) - classBody = - Box.vcat Box.top (map (\(i, t) -> Box.text (P.showIdent i ++ " ::") Box.<+> P.typeAsBox t) body) - - in - Just $ - (Box.text "class " - Box.<> constraints - Box.<> className - Box.<+> if null body then Box.text "" else Box.text "where") - Box.// Box.moveRight 2 classBody - - - findType - :: M.Map (P.Qualified (P.ProperName 'P.TypeName)) (P.Kind, P.TypeKind) - -> P.Qualified (P.ProperName 'P.TypeName) - -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind)) - findType envTypes name = (name, M.lookup name envTypes) - - showType - :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]) - -> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.Type, [P.Ident]) - -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(String, Maybe P.Kind)], P.Type) - -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind)) - -> Maybe Box.Box - showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) = - case (typ, M.lookup n typeSynonymsEnv) of - (Just (_, P.TypeSynonym), Just (typevars, dtType)) -> - if M.member (fmap P.coerceProperName n) typeClassesEnv - then - Nothing - else - Just $ - Box.text ("type " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars) - Box.// Box.moveRight 2 (Box.text "=" Box.<+> P.typeAsBox dtType) - - (Just (_, P.DataType typevars pt), _) -> - let prefix = - case pt of - [(dtProperName,_)] -> - case M.lookup (P.Qualified modul dtProperName) dataConstructorsEnv of - Just (dataDeclType, _, _, _) -> P.showDataDeclType dataDeclType - _ -> "data" - _ -> "data" - - in - Just $ Box.text (prefix ++ " " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars) Box.// printCons pt - - _ -> - Nothing - - where printCons pt = - Box.moveRight 2 $ - Box.vcat Box.left $ - mapFirstRest (Box.text "=" Box.<+>) (Box.text "|" Box.<+>) $ - map (\(cons,idents) -> (Box.text (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents))) pt - - prettyPrintType t = Box.text " " Box.<> P.typeAtomAsBox t - - mapFirstRest _ _ [] = [] - mapFirstRest f g (x:xs) = f x : map g xs - - trimEnd = reverse . dropWhile (== ' ') . reverse - --- | Pretty-print errors -printErrors :: MonadIO m => P.MultipleErrors -> InputT m () -printErrors = outputStrLn . P.prettyPrintMultipleErrors False diff --git a/psci/PSCi/Types.hs b/psci/PSCi/Types.hs deleted file mode 100644 --- a/psci/PSCi/Types.hs +++ /dev/null @@ -1,218 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Types --- Copyright : (c) Phil Freeman 2014 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- Type declarations and associated basic functions for PSCI. --- ------------------------------------------------------------------------------ - -module PSCi.Types where - -import Prelude () -import Prelude.Compat - -import Control.Arrow (second) -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Language.PureScript as P - -data PSCiOptions = PSCiOptions - { psciMultiLineMode :: Bool - , psciInputFile :: [FilePath] - , psciForeignInputFiles :: [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 - { psciImportedModules :: [ImportedModule] - , _psciLoadedModules :: Map FilePath [P.Module] - , psciForeignFiles :: Map P.ModuleName FilePath - , psciLetBindings :: [P.Declaration] - , psciNodeFlags :: [String] - } - -initialPSCiState :: PSCiState -initialPSCiState = - PSCiState [] Map.empty Map.empty [] [] - -mkPSCiState :: [ImportedModule] - -> [(FilePath, P.Module)] - -> Map P.ModuleName FilePath - -> [P.Declaration] - -> [String] - -> PSCiState -mkPSCiState imported loaded foreigns lets nodeFlags = - (initialPSCiState - |> each imported updateImportedModules - |> updateModules loaded) - { psciForeignFiles = foreigns - , psciLetBindings = lets - , psciNodeFlags = nodeFlags - } - where - x |> f = f x - each xs f st = foldl (flip f) st xs - --- Public psci state accessors - --- | Get the imported filenames as a list. -psciImportedFilenames :: PSCiState -> [FilePath] -psciImportedFilenames = Map.keys . _psciLoadedModules - --- | Get the loaded modules as a list. -psciLoadedModules :: PSCiState -> [(FilePath, P.Module)] -psciLoadedModules = collect . Map.toList . _psciLoadedModules - where - collect :: [(k, [v])] -> [(k, v)] - collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ] - --- | 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. --- -updateImportedModules :: ImportedModule -> PSCiState -> PSCiState -updateImportedModules im st = st { psciImportedModules = im : psciImportedModules st } - --- | --- Updates the state to have more loaded modules (available for import, but --- not necessarily imported). --- -updateModules :: [(FilePath, P.Module)] -> PSCiState -> PSCiState -updateModules modules st = - st { _psciLoadedModules = Map.union (go modules) (_psciLoadedModules st) } - where - go = Map.fromListWith (++) . map (second (:[])) - --- | --- Updates the state to have more let bindings. --- -updateLets :: [P.Declaration] -> PSCiState -> PSCiState -updateLets ds st = st { psciLetBindings = psciLetBindings st ++ ds } - --- | --- Updates the state to have more let bindings. --- -updateForeignFiles :: Map P.ModuleName FilePath -> PSCiState -> PSCiState -updateForeignFiles fs st = st { psciForeignFiles = psciForeignFiles st `Map.union` fs } - --- | --- 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 - -- | - -- Load a foreign module - -- - | LoadForeign 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 - | Foreign - | Type - | Kind - | Show - deriving (Eq, Show) diff --git a/psci/main/Main.hs b/psci/main/Main.hs deleted file mode 100644 --- a/psci/main/Main.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main where - -import PSCi - -main :: IO () -main = runPSCi diff --git a/purescript.cabal b/purescript.cabal --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.8.5.0 +version: 0.9.1 cabal-version: >=1.8 build-type: Simple license: MIT @@ -20,27 +20,73 @@ tested-with: GHC==7.10.3 extra-source-files: examples/passing/*.purs + , examples/passing/*.js + , examples/passing/2018/*.purs + , examples/passing/2138/*.purs + , examples/passing/ClassRefSyntax/*.purs + , examples/passing/DctorOperatorAlias/*.purs + , examples/passing/ExplicitImportReExport/*.purs + , examples/passing/ExportExplicit/*.purs + , examples/passing/ExportExplicit2/*.purs + , examples/passing/Import/*.purs + , examples/passing/ImportExplicit/*.purs + , examples/passing/ImportQualified/*.purs + , examples/passing/Module/*.purs + , examples/passing/ModuleDeps/*.purs + , examples/passing/ModuleExport/*.purs + , examples/passing/ModuleExportDupes/*.purs + , examples/passing/ModuleExportExcluded/*.purs + , examples/passing/ModuleExportQualified/*.purs + , examples/passing/ModuleExportSelf/*.purs + , examples/passing/NonConflictingExports/*.purs + , examples/passing/OperatorAliasElsewhere/*.purs + , examples/passing/Operators/*.purs + , examples/passing/PendingConflictingImports/*.purs + , examples/passing/PendingConflictingImports2/*.purs + , examples/passing/QualifiedNames/*.purs + , examples/passing/RedefinedFixity/*.purs + , examples/passing/ReExportQualified/*.purs + , examples/passing/ResolvableScopeConflict/*.purs + , examples/passing/ResolvableScopeConflict2/*.purs + , examples/passing/ResolvableScopeConflict3/*.purs + , examples/passing/ShadowedModuleName/*.purs + , examples/passing/TransitiveImport/*.purs + , examples/passing/TypeOperators/*.purs + , examples/passing/TypeWithoutParens/*.purs , examples/failing/*.purs + , examples/failing/1733/*.purs + , examples/failing/ConflictingExports/*.purs + , examples/failing/ConflictingImports/*.purs + , examples/failing/ConflictingImports2/*.purs + , examples/failing/ConflictingQualifiedImports/*.purs + , examples/failing/ConflictingQualifiedImports2/*.purs + , examples/failing/ExportConflictClass/*.purs + , examples/failing/ExportConflictCtor/*.purs + , examples/failing/ExportConflictType/*.purs + , examples/failing/ExportConflictTypeOp/*.purs + , examples/failing/ExportConflictValue/*.purs + , examples/failing/ExportConflictValueOp/*.purs + , examples/failing/ExportExplicit1/*.purs + , examples/failing/ExportExplicit3/*.purs + , examples/failing/ImportExplicit/*.purs + , examples/failing/ImportExplicit2/*.purs + , examples/failing/ImportHidingModule/*.purs + , examples/failing/ImportModule/*.purs + , examples/failing/InstanceExport/*.purs + , examples/failing/OrphanInstance/*.purs + , examples/warning/*.purs + , examples/warning/*.js , examples/docs/bower_components/purescript-prelude/src/*.purs , examples/docs/bower.json , examples/docs/src/*.purs - , tests/support/setup.js , tests/support/package.json - , tests/support/prelude/bower.json - , tests/support/prelude/src/*.purs - , tests/support/prelude/src/*.js - , tests/support/prelude/LICENSE , tests/support/bower.json , tests/support/setup-win.cmd - , tests/support/flattened/*.purs - , tests/support/flattened/*.js , tests/support/psci/*.purs , tests/support/pscide/src/*.purs , tests/support/pscide/src/*.js , tests/support/pscide/src/*.fail , stack.yaml - , stack-lts-5.yaml - , stack-nightly.yaml , README.md , INSTALL.md , CONTRIBUTORS.md @@ -52,47 +98,49 @@ library build-depends: base >=4.8 && <5, + aeson >= 0.8 && < 0.12, + aeson-better-errors >= 0.8, + ansi-terminal >= 0.6.2 && < 0.7, base-compat >=0.6.0, - lifted-base >= 0.2.3 && < 0.2.4, - monad-control >= 1.0.0.0 && < 1.1, - transformers-base >= 0.4.0 && < 0.5, + bower-json >= 0.8, + boxes >= 0.1.4 && < 0.2.0, + bytestring -any, containers -any, - unordered-containers -any, - dlist -any, directory >= 1.2, + dlist -any, + edit-distance -any, filepath -any, + fsnotify >= 0.2.1, + Glob >= 0.7 && < 0.8, + haskeline >= 0.7.0.0, + http-types -any, + language-javascript == 0.6.*, + lifted-base >= 0.2.3 && < 0.2.4, + monad-control >= 1.0.0.0 && < 1.1, + monad-logger >= 0.3 && < 0.4, mtl >= 2.1.0 && < 2.3.0, - parsec -any, - transformers >= 0.3.0 && < 0.6, - transformers-compat >= 0.3.0, - utf8-string >= 1 && < 2, + parallel >= 3.2 && < 3.3, + parsec >=3.1.10, pattern-arrows >= 0.0.2 && < 0.1, - time -any, - boxes >= 0.1.4 && < 0.2.0, - aeson >= 0.8 && < 0.12, - vector -any, - bower-json >= 0.8, - aeson-better-errors >= 0.8, - bytestring -any, - text -any, - split -any, - language-javascript == 0.6.*, - syb -any, - Glob >= 0.7 && < 0.8, + pipes >= 4.0.0 && < 4.2.0, + pipes-http -any, process >= 1.2.0 && < 1.5, + regex-tdfa -any, safe >= 0.3.9 && < 0.4, semigroups >= 0.16.2 && < 0.19, - parallel >= 3.2 && < 3.3, sourcemap >= 0.1.6, + spdx == 0.2.*, + split -any, stm >= 0.2.4.0, - regex-tdfa -any, - edit-distance -any, - fsnotify >= 0.2.1, - monad-logger >= 0.3 && < 0.4, - pipes >= 4.0.0 && < 4.2.0 , - pipes-http -any, - http-types -any, - spdx == 0.2.* + syb -any, + text -any, + time -any, + transformers >= 0.3.0 && < 0.6, + transformers-base >= 0.4.0 && < 0.5, + transformers-compat >= 0.3.0, + unordered-containers -any, + utf8-string >= 1 && < 2, + vector -any exposed-modules: Language.PureScript Language.PureScript.AST @@ -142,7 +190,6 @@ Language.PureScript.Parser.Lexer Language.PureScript.Parser.Common Language.PureScript.Parser.Declarations - Language.PureScript.Parser.JS Language.PureScript.Parser.Kinds Language.PureScript.Parser.State Language.PureScript.Parser.Types @@ -158,9 +205,10 @@ Language.PureScript.Sugar.CaseDeclarations Language.PureScript.Sugar.DoNotation Language.PureScript.Sugar.Names + Language.PureScript.Sugar.Names.Common Language.PureScript.Sugar.Names.Env - Language.PureScript.Sugar.Names.Imports Language.PureScript.Sugar.Names.Exports + Language.PureScript.Sugar.Names.Imports Language.PureScript.Sugar.ObjectWildcards Language.PureScript.Sugar.Operators Language.PureScript.Sugar.Operators.Common @@ -220,13 +268,38 @@ Language.PureScript.Ide.Util Language.PureScript.Ide.Rebuild + Language.PureScript.Interactive + Language.PureScript.Interactive.Types + Language.PureScript.Interactive.Parser + Language.PureScript.Interactive.Directive + Language.PureScript.Interactive.Completion + Language.PureScript.Interactive.IO + Language.PureScript.Interactive.Message + Language.PureScript.Interactive.Module + Language.PureScript.Interactive.Printer + Control.Monad.Logger Control.Monad.Supply Control.Monad.Supply.Class System.IO.UTF8 - extensions: DataKinds + extensions: ConstraintKinds + DataKinds + DeriveFunctor + EmptyDataDecls + FlexibleContexts + KindSignatures + LambdaCase + MultiParamTypeClasses + NoImplicitPrelude + PatternGuards + PatternSynonyms + RankNTypes + RecordWildCards + ScopedTypeVariables + TupleSections + ViewPatterns exposed: True buildable: True hs-source-dirs: src @@ -234,11 +307,23 @@ ghc-options: -Wall -O2 executable psc - build-depends: base >=4 && <5, base-compat >=0.6.0, - containers -any, directory -any, filepath -any, - mtl -any, optparse-applicative >= 0.12.1, parsec -any, purescript -any, - time -any, transformers -any, transformers-compat -any, Glob >= 0.7 && < 0.8, - aeson >= 0.8 && < 0.12, bytestring -any, utf8-string >= 1 && < 2 + build-depends: base >=4 && <5, + purescript -any, + aeson >= 0.8 && < 0.12, + ansi-terminal >= 0.6.2 && < 0.7, + base-compat >=0.6.0, + bytestring -any, + containers -any, + directory -any, + filepath -any, + Glob >= 0.7 && < 0.8, + mtl -any, + optparse-applicative >= 0.12.1, + parsec -any, + time -any, + transformers -any, + transformers-compat -any, + utf8-string >= 1 && < 2 main-is: Main.hs buildable: True hs-source-dirs: psc @@ -246,33 +331,40 @@ ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N" executable psci - build-depends: base >=4 && <5, containers -any, directory -any, filepath -any, - mtl -any, optparse-applicative >= 0.12.1, parsec -any, - haskeline >= 0.7.0.0, purescript -any, transformers -any, - transformers-compat -any, process -any, time -any, Glob -any, base-compat >=0.6.0, - boxes >= 0.1.4 && < 0.2.0 - + build-depends: base >=4 && <5, + purescript -any, + base-compat >=0.6.0, + boxes >= 0.1.4 && < 0.2.0, + containers -any, + directory -any, + filepath -any, + Glob -any, + haskeline >= 0.7.0.0, + mtl -any, + optparse-applicative >= 0.12.1, + parsec -any, + process -any, + time -any, + transformers -any, + transformers-compat -any main-is: Main.hs buildable: True - hs-source-dirs: psci psci/main - other-modules: PSCi - PSCi.Types - PSCi.Parser - PSCi.Directive - PSCi.Completion - PSCi.IO - PSCi.Message - PSCi.Option - PSCi.Module - PSCi.Printer - Paths_purescript + hs-source-dirs: psci + other-modules: Paths_purescript ghc-options: -Wall -O2 executable psc-docs - build-depends: base >=4 && <5, purescript -any, - optparse-applicative >= 0.12.1, process -any, mtl -any, - split -any, ansi-wl-pprint -any, directory -any, - filepath -any, Glob -any, transformers -any, + build-depends: base >=4 && <5, + purescript -any, + ansi-wl-pprint -any, + directory -any, + filepath -any, + Glob -any, + mtl -any, + optparse-applicative >= 0.12.1, + process -any, + split -any, + transformers -any, transformers-compat -any main-is: Main.hs other-modules: Paths_purescript @@ -284,7 +376,11 @@ ghc-options: -Wall -O2 executable psc-publish - build-depends: base >=4 && <5, purescript -any, bytestring -any, aeson -any, optparse-applicative -any + build-depends: base >=4 && <5, + purescript -any, + aeson -any, + bytestring -any, + optparse-applicative -any main-is: Main.hs other-modules: Paths_purescript buildable: True @@ -292,9 +388,15 @@ ghc-options: -Wall -O2 executable psc-hierarchy - build-depends: base >=4 && <5, purescript -any, optparse-applicative >= 0.12.1, - process -any, mtl -any, parsec -any, filepath -any, directory -any, - Glob -any + build-depends: base >=4 && <5, + purescript -any, + directory -any, + filepath -any, + Glob -any, + mtl -any, + optparse-applicative >= 0.12.1, + parsec -any, + process -any main-is: Main.hs other-modules: Paths_purescript buildable: True @@ -308,13 +410,13 @@ other-extensions: build-depends: base >=4 && <5, purescript -any, - filepath -any, directory -any, + filepath -any, + Glob -any, mtl -any, - transformers -any, - transformers-compat -any, optparse-applicative >= 0.12.1, - Glob -any + transformers -any, + transformers-compat -any ghc-options: -Wall -O2 hs-source-dirs: psc-bundle @@ -322,19 +424,19 @@ main-is: Main.hs other-modules: Paths_purescript other-extensions: - build-depends: base >=4 && <5 - , purescript -any - , directory -any - , filepath -any - , monad-logger -any - , mtl -any - , transformers -any - , transformers-compat -any - , network -any - , optparse-applicative >= 0.12.1 - , stm -any - , text -any - , base-compat >=0.6.0 + build-depends: base >=4 && <5, + purescript -any, + base-compat >=0.6.0, + directory -any, + filepath -any, + monad-logger -any, + mtl -any, + network -any, + optparse-applicative >= 0.12.1, + stm -any, + text -any, + transformers -any, + transformers-compat -any ghc-options: -Wall -O2 -threaded hs-source-dirs: psc-ide-server @@ -342,23 +444,43 @@ main-is: Main.hs other-modules: Paths_purescript other-extensions: - build-depends: base >=4 && <5 - , mtl -any - , text -any - , optparse-applicative >= 0.12.1 - , network -any - , base-compat >=0.6.0 + build-depends: base >=4 && <5, + base-compat >=0.6.0, + mtl -any, + network -any, + optparse-applicative >= 0.12.1, + text -any ghc-options: -Wall -O2 hs-source-dirs: psc-ide-client test-suite tests - build-depends: base >=4 && <5, containers -any, directory -any, - filepath -any, mtl -any, parsec -any, purescript -any, - transformers -any, process -any, transformers-compat -any, time -any, - Glob -any, aeson-better-errors -any, bytestring -any, aeson -any, - base-compat -any, haskeline >= 0.7.0.0, optparse-applicative -any, - boxes -any, HUnit -any, hspec -any, hspec-discover -any, stm -any, text -any, - vector -any, utf8-string -any + build-depends: base >=4 && <5, + purescript -any, + aeson -any, + aeson-better-errors -any, + base-compat -any, + boxes -any, + bytestring -any, + containers -any, + directory -any, + filepath -any, + Glob -any, + haskeline >= 0.7.0.0, + hspec -any, + hspec-discover -any, + HUnit -any, + mtl -any, + optparse-applicative -any, + parsec -any, + process -any, + silently -any, + stm -any, + text -any, + time -any, + transformers -any, + transformers-compat -any, + utf8-string -any, + vector -any ghc-options: -Wall type: exitcode-stdio-1.0 main-is: Main.hs @@ -377,9 +499,5 @@ Language.PureScript.Ide.RebuildSpec Language.PureScript.Ide.ReexportsSpec Language.PureScript.IdeSpec - PSCi.Completion - PSCi.Directive - PSCi.Module - PSCi.Types buildable: True - hs-source-dirs: tests psci + hs-source-dirs: tests diff --git a/src/Control/Monad/Logger.hs b/src/Control/Monad/Logger.hs --- a/src/Control/Monad/Logger.hs +++ b/src/Control/Monad/Logger.hs @@ -1,33 +1,20 @@ ------------------------------------------------------------------------------ --- --- Module : Control.Monad.Logger --- Author : Phil Freeman --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | A replacement for WriterT IO which uses mutable references. --- ------------------------------------------------------------------------------ - {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} +-- | +-- A replacement for WriterT IO which uses mutable references. +-- module Control.Monad.Logger where -import Prelude () import Prelude.Compat -import Data.IORef - import Control.Monad (ap) -import Control.Monad.IO.Class -import Control.Monad.Writer.Class import Control.Monad.Base (MonadBase(..)) +import Control.Monad.IO.Class import Control.Monad.Trans.Control (MonadBaseControl(..)) +import Control.Monad.Writer.Class + +import Data.IORef -- | A replacement for WriterT IO which uses mutable references. newtype Logger w a = Logger { runLogger :: IORef w -> IO a } diff --git a/src/Control/Monad/Supply.hs b/src/Control/Monad/Supply.hs --- a/src/Control/Monad/Supply.hs +++ b/src/Control/Monad/Supply.hs @@ -1,31 +1,18 @@ ------------------------------------------------------------------------------ --- --- Module : Control.Monad.Supply --- Copyright : (c) Phil Freeman 2014 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + -- | -- Fresh variable supply -- ------------------------------------------------------------------------------ - -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - module Control.Monad.Supply where -import Prelude () import Prelude.Compat -import Data.Functor.Identity - -import Control.Monad.State import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Reader +import Control.Monad.State import Control.Monad.Writer + +import Data.Functor.Identity newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a } deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r) diff --git a/src/Control/Monad/Supply/Class.hs b/src/Control/Monad/Supply/Class.hs --- a/src/Control/Monad/Supply/Class.hs +++ b/src/Control/Monad/Supply/Class.hs @@ -1,24 +1,24 @@ -{-# LANGUAGE MultiParamTypeClasses #-} - -- | -- A class for monads supporting a supply of fresh names -- module Control.Monad.Supply.Class where +import Prelude.Compat + import Control.Monad.Supply import Control.Monad.State -class (Monad m) => MonadSupply m where +class Monad m => MonadSupply m where fresh :: m Integer -instance (Monad m) => MonadSupply (SupplyT m) where +instance Monad m => MonadSupply (SupplyT m) where fresh = SupplyT $ do n <- get put (n + 1) return n -instance (MonadSupply m) => MonadSupply (StateT s m) where +instance MonadSupply m => MonadSupply (StateT s m) where fresh = lift fresh -freshName :: (MonadSupply m) => m String +freshName :: MonadSupply m => m String freshName = fmap (('$' :) . show) fresh diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs --- a/src/Language/PureScript.hs +++ b/src/Language/PureScript.hs @@ -1,33 +1,22 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript --- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- The main compiler module -- ------------------------------------------------------------------------------ - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - module Language.PureScript ( module P , version ) where + +import Control.Monad.Supply as P + import Data.Version (Version) import Language.PureScript.AST as P -import Language.PureScript.Crash as P import Language.PureScript.Comments as P +import Language.PureScript.Crash as P import Language.PureScript.Environment as P import Language.PureScript.Errors as P hiding (indent) +import Language.PureScript.Externs as P import Language.PureScript.Kinds as P import Language.PureScript.Linter as P import Language.PureScript.Make as P @@ -38,7 +27,6 @@ import Language.PureScript.Pretty as P import Language.PureScript.Renamer as P import Language.PureScript.Sugar as P -import Control.Monad.Supply as P import Language.PureScript.TypeChecker as P import Language.PureScript.Types as P diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs --- a/src/Language/PureScript/AST/Binders.hs +++ b/src/Language/PureScript/AST/Binders.hs @@ -3,6 +3,8 @@ -- module Language.PureScript.AST.Binders where +import Prelude.Compat + import Language.PureScript.AST.SourcePos import Language.PureScript.AST.Literals import Language.PureScript.Names @@ -33,7 +35,7 @@ -- A operator alias binder. During the rebracketing phase of desugaring, -- this data constructor will be removed. -- - | OpBinder (Qualified Ident) + | OpBinder (Qualified (OpName 'ValueOpName)) -- | -- Binary operator application. During the rebracketing phase of desugaring, -- this data constructor will be removed. diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -1,23 +1,17 @@ -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE LambdaCase #-} -- | -- Data types for modules and declarations -- module Language.PureScript.AST.Declarations where -import Prelude () import Prelude.Compat -import Data.Aeson.TH -import Data.List (nub, (\\)) -import Data.Maybe (mapMaybe) +import Control.Monad.Identity +import Data.Aeson.TH import qualified Data.Map as M -import Control.Monad.Identity - import Language.PureScript.AST.Binders import Language.PureScript.AST.Literals import Language.PureScript.AST.Operators @@ -47,9 +41,9 @@ addDefaultImport :: ModuleName -> Module -> Module addDefaultImport toImport m@(Module ss coms mn decls exps) = if isExistingImport `any` decls || mn == toImport then m - else Module ss coms mn (ImportDeclaration toImport Implicit Nothing False : decls) exps + else Module ss coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps where - isExistingImport (ImportDeclaration mn' _ _ _) | mn' == toImport = True + isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d isExistingImport _ = False @@ -64,16 +58,20 @@ -- | -- A type operator -- - | TypeOpRef Ident + | TypeOpRef (OpName 'TypeOpName) -- | -- A value -- | ValueRef Ident -- | + -- A value-level operator + -- + | ValueOpRef (OpName 'ValueOpName) + -- | -- A type class -- | TypeClassRef (ProperName 'ClassName) - -- | + -- | -- A type class instance, created during typeclass desugaring (name, class name, instance types) -- | TypeInstanceRef Ident @@ -82,10 +80,6 @@ -- | ModuleRef ModuleName -- | - -- An unspecified ProperName ref. This will be replaced with a TypeClassRef - -- or TypeRef during name desugaring. - | ProperRef String - -- | -- A declaration reference with source position information -- | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef @@ -95,42 +89,45 @@ (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors' (TypeOpRef name) == (TypeOpRef name') = name == name' (ValueRef name) == (ValueRef name') = name == name' + (ValueOpRef name) == (ValueOpRef name') = name == name' (TypeClassRef name) == (TypeClassRef name') = name == name' (TypeInstanceRef name) == (TypeInstanceRef name') = name == name' (ModuleRef name) == (ModuleRef name') = name == name' - (ProperRef name) == (ProperRef name') = name == name' (PositionedDeclarationRef _ _ r) == r' = r == r' r == (PositionedDeclarationRef _ _ r') = r == r' _ == _ = False +getTypeRef :: DeclarationRef -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName]) +getTypeRef (TypeRef name dctors) = Just (name, dctors) +getTypeRef (PositionedDeclarationRef _ _ r) = getTypeRef r +getTypeRef _ = Nothing + +getTypeOpRef :: DeclarationRef -> Maybe (OpName 'TypeOpName) +getTypeOpRef (TypeOpRef op) = Just op +getTypeOpRef (PositionedDeclarationRef _ _ r) = getTypeOpRef r +getTypeOpRef _ = Nothing + +getValueRef :: DeclarationRef -> Maybe Ident +getValueRef (ValueRef name) = Just name +getValueRef (PositionedDeclarationRef _ _ r) = getValueRef r +getValueRef _ = Nothing + +getValueOpRef :: DeclarationRef -> Maybe (OpName 'ValueOpName) +getValueOpRef (ValueOpRef op) = Just op +getValueOpRef (PositionedDeclarationRef _ _ r) = getValueOpRef r +getValueOpRef _ = Nothing + +getTypeClassRef :: DeclarationRef -> Maybe (ProperName 'ClassName) +getTypeClassRef (TypeClassRef name) = Just name +getTypeClassRef (PositionedDeclarationRef _ _ r) = getTypeClassRef r +getTypeClassRef _ = Nothing + isModuleRef :: DeclarationRef -> Bool isModuleRef (PositionedDeclarationRef _ _ r) = isModuleRef r isModuleRef (ModuleRef _) = True isModuleRef _ = False -- | --- Finds duplicate values in a list of declaration refs. The returned values --- are the duplicate refs with data constructors elided, and then a separate --- list of duplicate data constructors. --- -findDuplicateRefs :: [DeclarationRef] -> ([DeclarationRef], [ProperName 'ConstructorName]) -findDuplicateRefs refs = - let positionless = stripPosInfo `map` refs - simplified = simplifyTypeRefs `map` positionless - dupeRefs = nub $ simplified \\ nub simplified - dupeCtors = concat $ flip mapMaybe positionless $ \case - TypeRef _ (Just dctors) -> - let dupes = dctors \\ nub dctors - in if null dupes then Nothing else Just dupes - _ -> Nothing - in (dupeRefs, dupeCtors) - where - stripPosInfo (PositionedDeclarationRef _ _ ref) = stripPosInfo ref - stripPosInfo other = other - simplifyTypeRefs (TypeRef pn _) = TypeRef pn Nothing - simplifyTypeRefs other = other - --- | -- The data type which specifies type of import declaration -- data ImportDeclarationType @@ -193,14 +190,13 @@ -- | ExternDataDeclaration (ProperName 'TypeName) Kind -- | - -- A fixity declaration (fixity data, operator name, value the operator is an alias for) + -- A fixity declaration -- - | FixityDeclaration Fixity String (Maybe (Qualified FixityAlias)) + | FixityDeclaration (Either ValueFixity TypeFixity) -- | -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name) - -- TODO: also a boolean specifying whether the old `qualified` syntax was used, so a warning can be raised in desugaring (remove for 0.9) -- - | ImportDeclaration ModuleName ImportDeclarationType (Maybe ModuleName) Bool + | ImportDeclaration ModuleName ImportDeclarationType (Maybe ModuleName) -- | -- A type class declaration (name, argument, implies, member declarations) -- @@ -216,30 +212,14 @@ | PositionedDeclaration SourceSpan [Comment] Declaration deriving (Show, Read) -data FixityAlias - = AliasValue Ident - | AliasConstructor (ProperName 'ConstructorName) - | AliasType (ProperName 'TypeName) +data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'ConstructorName))) (OpName 'ValueOpName) deriving (Eq, Ord, Show, Read) -foldFixityAlias - :: (Ident -> a) - -> (ProperName 'ConstructorName -> a) - -> (ProperName 'TypeName -> a) - -> FixityAlias - -> a -foldFixityAlias f _ _ (AliasValue name) = f name -foldFixityAlias _ g _ (AliasConstructor name) = g name -foldFixityAlias _ _ h (AliasType name) = h name - -getValueAlias :: FixityAlias -> Maybe (Either Ident (ProperName 'ConstructorName)) -getValueAlias (AliasValue name) = Just $ Left name -getValueAlias (AliasConstructor name) = Just $ Right name -getValueAlias _ = Nothing +data TypeFixity = TypeFixity Fixity (Qualified (ProperName 'TypeName)) (OpName 'TypeOpName) + deriving (Eq, Ord, Show, Read) -getTypeAlias :: FixityAlias -> Maybe (ProperName 'TypeName) -getTypeAlias (AliasType name) = Just name -getTypeAlias _ = Nothing +pattern ValueFixityDeclaration fixity name op = FixityDeclaration (Left (ValueFixity fixity name op)) +pattern TypeFixityDeclaration fixity name op = FixityDeclaration (Right (TypeFixity fixity name op)) -- | The members of a type class instance declaration data TypeInstanceBody @@ -298,6 +278,11 @@ isFixityDecl (PositionedDeclaration _ _ d) = isFixityDecl d isFixityDecl _ = False +getFixityDecl :: Declaration -> Maybe (Either ValueFixity TypeFixity) +getFixityDecl (FixityDeclaration fixity) = Just fixity +getFixityDecl (PositionedDeclaration _ _ d) = getFixityDecl d +getFixityDecl _ = Nothing + -- | -- Test if a declaration is a foreign import -- @@ -361,12 +346,8 @@ -- | Parens Expr -- | - -- Operator section. This will be removed during desugaring and replaced with lambda. - -- - | OperatorSection Expr (Either Expr Expr) - -- | - -- An object property getter (e.g. `_.x`). This will be removed during - -- desugaring and expanded into a lambda that reads a property from an object. + -- A record property getter (e.g. `_.x`). This will be removed during + -- desugaring and expanded into a lambda that reads a property from a record. -- | ObjectGetter String -- | @@ -390,6 +371,11 @@ -- | Var (Qualified Ident) -- | + -- An operator. This will be desugared into a function during the "operators" + -- phase of desugaring. + -- + | Op (Qualified (OpName 'ValueOpName)) + -- | -- Conditional (if-then-else expression) -- | IfThenElse Expr Expr Expr @@ -487,4 +473,3 @@ $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType) -$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''FixityAlias) diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs --- a/src/Language/PureScript/AST/Exported.hs +++ b/src/Language/PureScript/AST/Exported.hs @@ -3,7 +3,10 @@ , isExported ) where +import Prelude.Compat + import Control.Category ((>>>)) + import Data.Maybe (mapMaybe) import Language.PureScript.AST.Declarations @@ -99,7 +102,7 @@ Left className : (concatMap fromConstraint constraints ++ concatMap fromType tys) where - fromConstraint (name, tys') = Left name : concatMap fromType tys' + fromConstraint c = Left (constraintClass c) : concatMap fromType (constraintArgs c) fromType = everythingOnTypes (++) go -- Note that type synonyms are disallowed in instance declarations, so @@ -124,21 +127,15 @@ isExported exps (PositionedDeclaration _ _ d) = isExported exps d isExported (Just exps) decl = any (matches decl) exps where - matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident' - matches (ValueDeclaration ident _ _ _) (ValueRef ident') = ident == ident' - matches (ExternDeclaration ident _) (ValueRef ident') = ident == ident' - matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident' - matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident' - matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident' + matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident' + matches (ValueDeclaration ident _ _ _) (ValueRef ident') = ident == ident' + matches (ExternDeclaration ident _) (ValueRef ident') = ident == ident' + matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident' + matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident' + matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident' matches (TypeClassDeclaration ident _ _ _) (TypeClassRef ident') = ident == ident' - - matches (DataDeclaration _ ident _ _) (ProperRef ident') = runProperName ident == ident' - matches (TypeClassDeclaration ident _ _ _) (ProperRef ident') = runProperName ident == ident' - - matches (FixityDeclaration _ name (Just (Qualified _ (AliasValue _)))) (ValueRef ident') = name == runIdent ident' - matches (FixityDeclaration _ name (Just (Qualified _ (AliasConstructor _)))) (ValueRef ident') = name == runIdent ident' - matches (FixityDeclaration _ name (Just (Qualified _ (AliasType _)))) (TypeOpRef ident') = name == runIdent ident' - + matches (ValueFixityDeclaration _ _ op) (ValueOpRef op') = op == op' + matches (TypeFixityDeclaration _ _ op) (TypeOpRef op') = op == op' matches (PositionedDeclaration _ _ d) r = d `matches` r matches d (PositionedDeclarationRef _ _ r) = d `matches` r matches _ _ = False diff --git a/src/Language/PureScript/AST/Literals.hs b/src/Language/PureScript/AST/Literals.hs --- a/src/Language/PureScript/AST/Literals.hs +++ b/src/Language/PureScript/AST/Literals.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE DeriveFunctor #-} - -- | -- The core functional representation for literal values. -- module Language.PureScript.AST.Literals where + +import Prelude.Compat -- | -- Data type for literal values. Parameterised so it can be used for Exprs and diff --git a/src/Language/PureScript/AST/Operators.hs b/src/Language/PureScript/AST/Operators.hs --- a/src/Language/PureScript/AST/Operators.hs +++ b/src/Language/PureScript/AST/Operators.hs @@ -5,6 +5,8 @@ -- module Language.PureScript.AST.Operators where +import Prelude.Compat + import Data.Aeson ((.=)) import qualified Data.Aeson as A diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} -- | @@ -7,7 +5,6 @@ -- module Language.PureScript.AST.SourcePos where -import Prelude () import Prelude.Compat import Data.Aeson ((.=), (.:)) diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -1,21 +1,18 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -- | -- AST traversal helpers -- module Language.PureScript.AST.Traversals where -import Prelude () import Prelude.Compat -import Data.Maybe (mapMaybe) -import Data.List (mapAccumL) -import Data.Foldable (fold) -import qualified Data.Set as S - import Control.Monad import Control.Arrow ((***), (+++)) +import Data.Foldable (fold) +import Data.List (mapAccumL) +import Data.Maybe (mapMaybe) +import qualified Data.Set as S + import Language.PureScript.AST.Binders import Language.PureScript.AST.Literals import Language.PureScript.AST.Declarations @@ -47,8 +44,6 @@ g' (UnaryMinus v) = g (UnaryMinus (g' v)) g' (BinaryNoParens op v1 v2) = g (BinaryNoParens (g' op) (g' v1) (g' v2)) g' (Parens v) = g (Parens (g' v)) - g' (OperatorSection op (Left v)) = g (OperatorSection (g' op) (Left $ g' v)) - g' (OperatorSection op (Right v)) = g (OperatorSection (g' op) (Right $ g' v)) g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v)) g' (Accessor prop v) = g (Accessor prop (g' v)) g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs)) @@ -116,8 +111,6 @@ g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g') g' (BinaryNoParens op v1 v2) = BinaryNoParens <$> (g op >>= g') <*> (g v1 >>= g') <*> (g v2 >>= g') g' (Parens v) = Parens <$> (g v >>= g') - g' (OperatorSection op (Left v)) = OperatorSection <$> (g op >>= g') <*> (Left <$> (g v >>= g')) - g' (OperatorSection op (Right v)) = OperatorSection <$> (g op >>= g') <*> (Right <$> (g v >>= g')) g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g') g' (Accessor prop v) = Accessor prop <$> (g v >>= g') g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs @@ -185,8 +178,6 @@ g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g g' (BinaryNoParens op v1 v2) = (BinaryNoParens <$> g' op <*> g' v1 <*> g' v2) >>= g g' (Parens v) = (Parens <$> g' v) >>= g - g' (OperatorSection op (Left v)) = (OperatorSection <$> g' op <*> (Left <$> g' v)) >>= g - g' (OperatorSection op (Right v)) = (OperatorSection <$> g' op <*> (Right <$> g' v)) >>= g g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= g @@ -259,8 +250,6 @@ g' v@(UnaryMinus v1) = g v <> g' v1 g' v@(BinaryNoParens op v1 v2) = g v <> g' op <> g' v1 <> g' v2 g' v@(Parens v1) = g v <> g' v1 - g' v@(OperatorSection op (Left v1)) = g v <> g' op <> g' v1 - g' v@(OperatorSection op (Right v1)) = g v <> g' op <> g' v1 g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1 g' v@(Accessor _ v1) = g v <> g' v1 g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs) @@ -338,8 +327,6 @@ g' s (UnaryMinus v1) = g'' s v1 g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2 g' s (Parens v1) = g'' s v1 - g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v - g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1 g' s (Accessor _ v1) = g'' s v1 g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs) @@ -419,8 +406,6 @@ g' s (UnaryMinus v) = UnaryMinus <$> g'' s v g' s (BinaryNoParens op v1 v2) = BinaryNoParens <$> g'' s op <*> g'' s v1 <*> g'' s v2 g' s (Parens v) = Parens <$> g'' s v - g' s (OperatorSection op (Left v)) = OperatorSection <$> g'' s op <*> (Left <$> g'' s v) - g' s (OperatorSection op (Right v)) = OperatorSection <$> g'' s op <*> (Right <$> g'' s v) g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v g' s (Accessor prop v) = Accessor prop <$> g'' s v g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> traverse (sndM (g'' s)) vs @@ -510,8 +495,6 @@ g' s (UnaryMinus v1) = g'' s v1 g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2 g' s (Parens v1) = g'' s v1 - g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v - g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1 g' s (Accessor _ v1) = g'' s v1 g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs @@ -593,13 +576,13 @@ where forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors) forDecls (ExternDeclaration _ ty) = f ty - forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . snd) implies) - forDecls (TypeInstanceDeclaration _ cs _ tys _) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys) + forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . constraintArgs) implies) + forDecls (TypeInstanceDeclaration _ cs _ tys _) = mconcat (concatMap (map f . constraintArgs) cs) `mappend` mconcat (map f tys) forDecls (TypeSynonymDeclaration _ _ ty) = f ty forDecls (TypeDeclaration _ ty) = f ty forDecls _ = mempty - forValues (TypeClassDictionary (_, cs) _) = mconcat (map f cs) + forValues (TypeClassDictionary c _) = mconcat (map f (constraintArgs c)) forValues (SuperClassDictionary _ tys) = mconcat (map f tys) forValues (TypedValue _ _ ty) = f ty forValues _ = mempty diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -1,48 +1,32 @@ ------------------------------------------------------------------------------ --- --- Module : psc-bundle --- Copyright : (c) Phil Freeman 2015 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | Bundles compiled PureScript modules for the browser. +-- | +-- Bundles compiled PureScript modules for the browser. -- -- This module takes as input the individual generated modules from 'Language.PureScript.Make' and -- performs dead code elimination, filters empty modules, -- and generates the final Javascript bundle. ------------------------------------------------------------------------------ - -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} - -module Language.PureScript.Bundle ( - bundle - , ModuleIdentifier(..) - , moduleName - , ModuleType(..) - , ErrorMessage(..) - , printErrorMessage - , getExportedIdentifiers -) where +module Language.PureScript.Bundle + ( bundle + , ModuleIdentifier(..) + , moduleName + , ModuleType(..) + , ErrorMessage(..) + , printErrorMessage + , getExportedIdentifiers + ) where -import Prelude () import Prelude.Compat -import Data.List (nub, stripPrefix) -import Data.Maybe (mapMaybe, catMaybes, fromMaybe) +import Control.Monad +import Control.Monad.Error.Class + +import Data.Char (chr, digitToInt) import Data.Generics (everything, everywhere, mkQ, mkT) import Data.Graph +import Data.List (nub, stripPrefix) +import Data.Maybe (mapMaybe, catMaybes) import Data.Version (showVersion) - import qualified Data.Set as S -import Control.Monad -import Control.Monad.Error.Class import Language.JavaScript.Parser import Language.JavaScript.Parser.AST @@ -134,13 +118,13 @@ name ++ " (" ++ showModuleType ty ++ ")" -- | Calculate the ModuleIdentifier which a require(...) statement imports. -checkImportPath :: Maybe FilePath -> String -> ModuleIdentifier -> S.Set String -> Either String ModuleIdentifier -checkImportPath _ "./foreign" m _ = +checkImportPath :: String -> ModuleIdentifier -> S.Set String -> Either String ModuleIdentifier +checkImportPath "./foreign" m _ = Right (ModuleIdentifier (moduleName m) Foreign) -checkImportPath requirePath name _ names - | Just name' <- stripPrefix (fromMaybe "../" requirePath) name +checkImportPath name _ names + | Just name' <- stripPrefix "../" name , name' `S.member` names = Right (ModuleIdentifier name' Regular) -checkImportPath _ name _ _ = Left name +checkImportPath name _ _ = Left name -- | Compute the dependencies of all elements in a module, and add them to the tree. -- @@ -203,11 +187,34 @@ -- String literals include the quote chars fromStringLiteral :: JSExpression -> Maybe String -fromStringLiteral (JSStringLiteral _ str) = Just $ trimStringQuotes str +fromStringLiteral (JSStringLiteral _ str) = Just $ strValue str fromStringLiteral _ = Nothing -trimStringQuotes :: String -> String -trimStringQuotes str = reverse $ drop 1 $ reverse $ drop 1 $ str +strValue :: String -> String +strValue str = go $ drop 1 str + where + go ('\\' : 'b' : xs) = '\b' : go xs + go ('\\' : 'f' : xs) = '\f' : go xs + go ('\\' : 'n' : xs) = '\n' : go xs + go ('\\' : 'r' : xs) = '\r' : go xs + go ('\\' : 't' : xs) = '\t' : go xs + go ('\\' : 'v' : xs) = '\v' : go xs + go ('\\' : '0' : xs) = '\0' : go xs + go ('\\' : 'x' : a : b : xs) = chr (a' + b') : go xs + where + a' = 16 * digitToInt a + b' = digitToInt b + go ('\\' : 'u' : a : b : c : d : xs) = chr (a' + b' + c' + d') : go xs + where + a' = 16 * 16 * 16 * digitToInt a + b' = 16 * 16 * digitToInt b + c' = 16 * digitToInt c + d' = digitToInt d + go ('\\' : x : xs) = x : go xs + go "\"" = "" + go "'" = "" + go (x : xs) = x : go xs + go "" = "" commaList :: JSCommaList a -> [a] commaList JSLNil = [] @@ -222,8 +229,8 @@ -- -- Each type of module element is matched using pattern guards, and everything else is bundled into the -- Other constructor. -toModule :: forall m. (MonadError ErrorMessage m) => Maybe FilePath -> S.Set String -> ModuleIdentifier -> JSAST -> m Module -toModule requirePath mids mid top +toModule :: forall m. (MonadError ErrorMessage m) => S.Set String -> ModuleIdentifier -> JSAST -> m Module +toModule mids mid top | JSAstProgram smts _ <- top = Module mid <$> traverse toModuleElement smts | otherwise = err InvalidTopLevel where @@ -231,7 +238,7 @@ toModuleElement :: JSStatement -> m ModuleElement toModuleElement stmt - | Just (importName, importPath) <- matchRequire requirePath mids mid stmt + | Just (importName, importPath) <- matchRequire mids mid stmt = pure (Require stmt importName importPath) toModuleElement stmt | Just (exported, name, decl) <- matchMember stmt @@ -291,12 +298,11 @@ -- Matches JS statements like this: -- var ModuleName = require("file"); -matchRequire :: Maybe FilePath - -> S.Set String +matchRequire :: S.Set String -> ModuleIdentifier -> JSStatement -> Maybe (String, Either String ModuleIdentifier) -matchRequire requirePath mids mid stmt +matchRequire mids mid stmt | JSVariable _ jsInit _ <- stmt , [JSVarInitExpression var varInit] <- commaList jsInit , JSIdentifier _ importName <- var @@ -304,7 +310,7 @@ , JSMemberExpression req _ argsE _ <- jsInitEx , JSIdentifier _ "require" <- req , [ Just importPath ] <- map fromStringLiteral (commaList argsE) - , importPath' <- checkImportPath requirePath importPath mid mids + , importPath' <- checkImportPath importPath mid mids = Just (importName, importPath') | otherwise = Nothing @@ -350,7 +356,7 @@ = Nothing extractLabel :: JSPropertyName -> Maybe String -extractLabel (JSPropertyString _ nm) = Just (trimStringQuotes nm) +extractLabel (JSPropertyString _ nm) = Just $ strValue nm extractLabel (JSPropertyIdent _ nm) = Just nm extractLabel _ = Nothing @@ -590,16 +596,15 @@ -> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination -> Maybe String -- ^ An optional main module. -> String -- ^ The namespace (e.g. PS). - -> Maybe FilePath -- ^ The require path prefix -> m String -bundle inputStrs entryPoints mainModule namespace requirePath = do +bundle inputStrs entryPoints mainModule namespace = do input <- forM inputStrs $ \(ident, js) -> do ast <- either (throwError . ErrorInModule ident . UnableToParseModule) pure $ parse js (moduleName ident) return (ident, ast) let mids = S.fromList (map (moduleName . fst) input) - modules <- traverse (fmap withDeps . uncurry (toModule requirePath mids)) input + modules <- traverse (fmap withDeps . uncurry (toModule mids)) input let compiled = compile modules entryPoints sorted = sortModules (filter (not . isModuleEmpty) compiled) diff --git a/src/Language/PureScript/CodeGen.hs b/src/Language/PureScript/CodeGen.hs --- a/src/Language/PureScript/CodeGen.hs +++ b/src/Language/PureScript/CodeGen.hs @@ -1,20 +1,8 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.CodeGen --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- A collection of modules related to code generation: --- --- [@Language.PureScript.CodeGen.JS@] Code generator for Javascript --- ------------------------------------------------------------------------------ - -module Language.PureScript.CodeGen (module C) where - -import Language.PureScript.CodeGen.JS as C +-- | +-- A collection of modules related to code generation: +-- +-- [@Language.PureScript.CodeGen.JS@] Code generator for Javascript +-- +module Language.PureScript.CodeGen (module C) where + +import Language.PureScript.CodeGen.JS as C diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - -- | -- This module generates code in the simplified Javascript intermediate representation from Purescript code -- @@ -12,29 +7,28 @@ , moduleToJs ) where -import Prelude () import Prelude.Compat -import Data.List ((\\), delete, intersect) -import Data.Maybe (isNothing, fromMaybe) -import qualified Data.Map as M -import qualified Data.Foldable as F -import qualified Data.Traversable as T - import Control.Arrow ((&&&)) import Control.Monad (replicateM, forM, void) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Supply.Class -import Language.PureScript.Crash +import Data.List ((\\), delete, intersect) +import Data.Maybe (isNothing, fromMaybe) +import qualified Data.Foldable as F +import qualified Data.Map as M +import qualified Data.Traversable as T + import Language.PureScript.AST.SourcePos import Language.PureScript.CodeGen.JS.AST as AST import Language.PureScript.CodeGen.JS.Common as Common +import Language.PureScript.CodeGen.JS.Optimizer import Language.PureScript.CoreFn -import Language.PureScript.Names +import Language.PureScript.Crash import Language.PureScript.Errors -import Language.PureScript.CodeGen.JS.Optimizer +import Language.PureScript.Names import Language.PureScript.Options import Language.PureScript.Traversals (sndM) import qualified Language.PureScript.Constants as C @@ -109,9 +103,8 @@ -- importToJs :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m JS importToJs mnLookup mn' = do - path <- asks optionsRequirePath let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup - let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (fromMaybe ".." path runModuleName mn')] + let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (".." runModuleName mn')] withPos ss $ JSVariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody) -- | @@ -180,7 +173,6 @@ -- accessor :: Ident -> JS -> JS accessor (Ident prop) = accessorString prop - accessor (Op op) = JSIndexer Nothing (JSStringLiteral Nothing op) accessor (GenIdent _ _) = internalError "GenIdent in accessor" accessorString :: String -> JS -> JS diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs --- a/src/Language/PureScript/CodeGen/JS/AST.hs +++ b/src/Language/PureScript/CodeGen/JS/AST.hs @@ -3,14 +3,13 @@ -- module Language.PureScript.CodeGen.JS.AST where -import Prelude () import Prelude.Compat import Control.Monad.Identity +import Language.PureScript.AST (SourceSpan(..)) import Language.PureScript.Comments import Language.PureScript.Traversals -import Language.PureScript.AST (SourceSpan(..)) -- | -- Built-in unary operators diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Common.hs @@ -3,6 +3,8 @@ -- module Language.PureScript.CodeGen.JS.Common where +import Prelude.Compat + import Data.Char import Data.List (intercalate) @@ -27,7 +29,6 @@ identToJs (Ident name) | nameIsJsReserved name || nameIsJsBuiltIn name = "$$" ++ name | otherwise = concatMap identCharToString name -identToJs (Op op) = concatMap identCharToString op identToJs (GenIdent _ _) = internalError "GenIdent in identToJs" -- | diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer.hs b/src/Language/PureScript/CodeGen/JS/Optimizer.hs --- a/src/Language/PureScript/CodeGen/JS/Optimizer.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} - -- | -- This module optimizes code in the simplified-Javascript intermediate representation. -- @@ -23,22 +21,20 @@ -- module Language.PureScript.CodeGen.JS.Optimizer (optimize) where -import Prelude () import Prelude.Compat import Control.Monad.Reader (MonadReader, ask, asks) import Control.Monad.Supply.Class (MonadSupply) import Language.PureScript.CodeGen.JS.AST -import Language.PureScript.Options -import qualified Language.PureScript.Constants as C - +import Language.PureScript.CodeGen.JS.Optimizer.Blocks import Language.PureScript.CodeGen.JS.Optimizer.Common -import Language.PureScript.CodeGen.JS.Optimizer.TCO -import Language.PureScript.CodeGen.JS.Optimizer.MagicDo import Language.PureScript.CodeGen.JS.Optimizer.Inliner +import Language.PureScript.CodeGen.JS.Optimizer.MagicDo +import Language.PureScript.CodeGen.JS.Optimizer.TCO import Language.PureScript.CodeGen.JS.Optimizer.Unused -import Language.PureScript.CodeGen.JS.Optimizer.Blocks +import Language.PureScript.Options +import qualified Language.PureScript.Constants as C -- | -- Apply a series of optimizer passes to simplified Javascript code diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs @@ -1,22 +1,12 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.CodeGen.JS.Optimizer.Blocks --- Copyright : (c) Phil Freeman 2013-14 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- Optimizer steps for simplifying Javascript blocks -- ------------------------------------------------------------------------------ - module Language.PureScript.CodeGen.JS.Optimizer.Blocks ( collapseNestedBlocks , collapseNestedIfs ) where + +import Prelude.Compat import Language.PureScript.CodeGen.JS.AST diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs @@ -3,6 +3,8 @@ -- module Language.PureScript.CodeGen.JS.Optimizer.Common where +import Prelude.Compat + import Data.Maybe (fromMaybe) import Language.PureScript.Crash @@ -66,12 +68,11 @@ removeFromBlock _ js = js 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 (moduleName, fnName) (JSAccessor _ x (JSVar _ y)) = + x == fnName && y == moduleName +isFn (moduleName, fnName) (JSIndexer _ (JSStringLiteral _ x) (JSVar _ y)) = + x == fnName && y == moduleName isFn _ _ = False - -isFn' :: [(String, String)] -> JS -> Bool -isFn' xs js = any (`isFn` js) xs isDict :: (String, String) -> JS -> Bool isDict (moduleName, dictName) (JSAccessor _ x (JSVar _ y)) = x == dictName && y == moduleName diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -12,15 +12,13 @@ , evaluateIifes ) where -import Prelude () import Prelude.Compat import Control.Monad.Supply.Class (MonadSupply, freshName) + import Data.Maybe (fromMaybe) import Language.PureScript.CodeGen.JS.AST -import Language.PureScript.CodeGen.JS.Common -import Language.PureScript.Names import Language.PureScript.CodeGen.JS.Optimizer.Common import qualified Language.PureScript.Constants as C @@ -82,24 +80,24 @@ where convert :: JS -> JS convert (JSApp ss fn [dict]) - | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnZero fn = JSNumericLiteral ss (Left 0) - | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnOne fn = JSNumericLiteral ss (Left 1) - | isDict' boundedBoolean dict && isFn' fnBottom fn = JSBooleanLiteral ss False - | isDict' boundedBoolean dict && isFn' fnTop fn = JSBooleanLiteral ss True + | isDict' [semiringNumber, semiringInt] dict && isFn fnZero fn = JSNumericLiteral ss (Left 0) + | isDict' [semiringNumber, semiringInt] dict && isFn fnOne fn = JSNumericLiteral ss (Left 1) + | isDict boundedBoolean dict && isFn fnBottom fn = JSBooleanLiteral ss False + | isDict boundedBoolean dict && isFn fnTop fn = JSBooleanLiteral ss True convert (JSApp ss (JSApp _ (JSApp _ fn [dict]) [x]) [y]) - | isDict' semiringInt dict && isFn' fnAdd fn = intOp ss Add x y - | isDict' semiringInt dict && isFn' fnMultiply fn = intOp ss Multiply x y - | isDict' moduloSemiringInt dict && isFn' fnDivide fn = intOp ss Divide x y - | isDict' ringInt dict && isFn' fnSubtract fn = intOp ss Subtract x y + | isDict semiringInt dict && isFn fnAdd fn = intOp ss Add x y + | isDict semiringInt dict && isFn fnMultiply fn = intOp ss Multiply x y + | isDict euclideanRingInt dict && isFn fnDivide fn = intOp ss Divide x y + | isDict ringInt dict && isFn fnSubtract fn = intOp ss Subtract x y convert other = other - fnZero = [(C.prelude, C.zero), (C.dataSemiring, C.zero)] - fnOne = [(C.prelude, C.one), (C.dataSemiring, C.one)] - fnBottom = [(C.prelude, C.bottom), (C.dataBounded, C.bottom)] - fnTop = [(C.prelude, C.top), (C.dataBounded, C.top)] - fnAdd = [(C.prelude, (C.+)), (C.prelude, C.add), (C.dataSemiring, (C.+)), (C.dataSemiring, C.add)] - fnDivide = [(C.prelude, (C./)), (C.prelude, C.div), (C.dataModuloSemiring, C.div)] - fnMultiply = [(C.prelude, (C.*)), (C.prelude, C.mul), (C.dataSemiring, (C.*)), (C.dataSemiring, C.mul)] - fnSubtract = [(C.prelude, (C.-)), (C.prelude, C.sub), (C.dataRing, C.sub)] + fnZero = (C.dataSemiring, C.zero) + fnOne = (C.dataSemiring, C.one) + fnBottom = (C.dataBounded, C.bottom) + fnTop = (C.dataBounded, C.top) + fnAdd = (C.dataSemiring, C.add) + fnDivide = (C.dataEuclideanRing, C.div) + fnMultiply = (C.dataSemiring, C.mul) + fnSubtract = (C.dataRing, C.sub) intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0)) inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS @@ -108,7 +106,6 @@ convert :: JS -> JS convert (JSApp _ (JSApp _ op' [x]) [y]) | isOp op' = f x y convert other = other - isOp (JSAccessor _ longForm (JSVar _ m')) = m == m' && longForm == identToJs (Op op) isOp (JSIndexer _ (JSStringLiteral _ op') (JSVar _ m')) = m == m' && op == op' isOp _ = False @@ -122,8 +119,8 @@ , binary ringInt opSub Subtract , unary ringInt opNegate Negate - , binary moduloSemiringNumber opDiv Divide - , binary moduloSemiringInt opMod Modulus + , binary euclideanRingNumber opDiv Divide + , binary euclideanRingInt opMod Modulus , binary eqNumber opEq EqualTo , binary eqNumber opNotEq NotEqualTo @@ -159,9 +156,9 @@ , binary semigroupString opAppend Add - , binary booleanAlgebraBoolean opConj And - , binary booleanAlgebraBoolean opDisj Or - , unary booleanAlgebraBoolean opNot Not + , binary heytingAlgebraBoolean opConj And + , binary heytingAlgebraBoolean opDisj Or + , unary heytingAlgebraBoolean opNot Not , binary' C.dataIntBits (C..|.) BitwiseOr , binary' C.dataIntBits (C..&.) BitwiseAnd @@ -173,11 +170,11 @@ ] ++ [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] where - binary :: [(String, String)] -> [(String, String)] -> BinaryOperator -> JS -> JS + binary :: (String, String) -> (String, String) -> BinaryOperator -> JS -> JS binary dict fns op = everywhereOnJS convert where convert :: JS -> JS - convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y]) | isDict' dict dict' && isFn' fns fn = JSBinary ss op x y + convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y]) | isDict dict dict' && isFn fns fn = JSBinary ss op x y convert other = other binary' :: String -> String -> BinaryOperator -> JS -> JS binary' moduleName opString op = everywhereOnJS convert @@ -185,11 +182,11 @@ convert :: JS -> JS convert (JSApp ss (JSApp _ fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary ss op x y convert other = other - unary :: [(String, String)] -> [(String, String)] -> UnaryOperator -> JS -> JS + unary :: (String, String) -> (String, String) -> UnaryOperator -> JS -> JS unary dicts fns op = everywhereOnJS convert where convert :: JS -> JS - convert (JSApp ss (JSApp _ fn [dict']) [x]) | isDict' dicts dict' && isFn' fns fn = JSUnary ss op x + convert (JSApp ss (JSApp _ fn [dict']) [x]) | isDict dicts dict' && isFn fns fn = JSUnary ss op x convert other = other unary' :: String -> String -> UnaryOperator -> JS -> JS unary' moduleName fnName op = everywhereOnJS convert @@ -251,118 +248,118 @@ return $ JSFunction ss Nothing [arg] (JSBlock ss [JSReturn Nothing $ JSApp Nothing y [JSApp Nothing x [JSVar Nothing arg]]]) convert other = return other isFnCompose :: JS -> JS -> Bool - isFnCompose dict' fn = isDict' semigroupoidFn dict' && isFn' fnCompose fn + isFnCompose dict' fn = isDict semigroupoidFn dict' && isFn fnCompose fn isFnComposeFlipped :: JS -> JS -> Bool - isFnComposeFlipped dict' fn = isDict' semigroupoidFn dict' && isFn' fnComposeFlipped fn - fnCompose :: [(String, String)] - fnCompose = [(C.prelude, C.compose), (C.prelude, (C.<<<)), (C.controlSemigroupoid, C.compose)] - fnComposeFlipped :: [(String, String)] - fnComposeFlipped = [(C.prelude, (C.>>>)), (C.controlSemigroupoid, C.composeFlipped)] + isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isFn fnComposeFlipped fn + fnCompose :: (String, String) + fnCompose = (C.controlSemigroupoid, C.compose) + fnComposeFlipped :: (String, String) + fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped) -semiringNumber :: [(String, String)] -semiringNumber = [(C.prelude, C.semiringNumber), (C.dataSemiring, C.semiringNumber)] +semiringNumber :: (String, String) +semiringNumber = (C.dataSemiring, C.semiringNumber) -semiringInt :: [(String, String)] -semiringInt = [(C.prelude, C.semiringInt), (C.dataSemiring, C.semiringInt)] +semiringInt :: (String, String) +semiringInt = (C.dataSemiring, C.semiringInt) -ringNumber :: [(String, String)] -ringNumber = [(C.prelude, C.ringNumber), (C.dataRing, C.ringNumber)] +ringNumber :: (String, String) +ringNumber = (C.dataRing, C.ringNumber) -ringInt :: [(String, String)] -ringInt = [(C.prelude, C.ringInt), (C.dataRing, C.ringInt)] +ringInt :: (String, String) +ringInt = (C.dataRing, C.ringInt) -moduloSemiringNumber :: [(String, String)] -moduloSemiringNumber = [(C.prelude, C.moduloSemiringNumber), (C.dataModuloSemiring, C.moduloSemiringNumber)] +euclideanRingNumber :: (String, String) +euclideanRingNumber = (C.dataEuclideanRing, C.euclideanRingNumber) -moduloSemiringInt :: [(String, String)] -moduloSemiringInt = [(C.prelude, C.moduloSemiringInt), (C.dataModuloSemiring, C.moduloSemiringInt)] +euclideanRingInt :: (String, String) +euclideanRingInt = (C.dataEuclideanRing, C.euclideanRingInt) -eqNumber :: [(String, String)] -eqNumber = [(C.prelude, C.eqNumber), (C.dataEq, C.eqNumber)] +eqNumber :: (String, String) +eqNumber = (C.dataEq, C.eqNumber) -eqInt :: [(String, String)] -eqInt = [(C.prelude, C.eqInt), (C.dataEq, C.eqInt)] +eqInt :: (String, String) +eqInt = (C.dataEq, C.eqInt) -eqString :: [(String, String)] -eqString = [(C.prelude, C.eqString), (C.dataEq, C.eqString)] +eqString :: (String, String) +eqString = (C.dataEq, C.eqString) -eqChar :: [(String, String)] -eqChar = [(C.prelude, C.eqChar), (C.dataEq, C.eqChar)] +eqChar :: (String, String) +eqChar = (C.dataEq, C.eqChar) -eqBoolean :: [(String, String)] -eqBoolean = [(C.prelude, C.eqBoolean), (C.dataEq, C.eqBoolean)] +eqBoolean :: (String, String) +eqBoolean = (C.dataEq, C.eqBoolean) -ordBoolean :: [(String, String)] -ordBoolean = [(C.prelude, C.ordBoolean), (C.dataOrd, C.ordBoolean)] +ordBoolean :: (String, String) +ordBoolean = (C.dataOrd, C.ordBoolean) -ordNumber :: [(String, String)] -ordNumber = [(C.prelude, C.ordNumber), (C.dataOrd, C.ordNumber)] +ordNumber :: (String, String) +ordNumber = (C.dataOrd, C.ordNumber) -ordInt :: [(String, String)] -ordInt = [(C.prelude, C.ordInt), (C.dataOrd, C.ordInt)] +ordInt :: (String, String) +ordInt = (C.dataOrd, C.ordInt) -ordString :: [(String, String)] -ordString = [(C.prelude, C.ordString), (C.dataOrd, C.ordString)] +ordString :: (String, String) +ordString = (C.dataOrd, C.ordString) -ordChar :: [(String, String)] -ordChar = [(C.prelude, C.ordChar), (C.dataOrd, C.ordChar)] +ordChar :: (String, String) +ordChar = (C.dataOrd, C.ordChar) -semigroupString :: [(String, String)] -semigroupString = [(C.prelude, C.semigroupString), (C.dataSemigroup, C.semigroupString)] +semigroupString :: (String, String) +semigroupString = (C.dataSemigroup, C.semigroupString) -boundedBoolean :: [(String, String)] -boundedBoolean = [(C.prelude, C.boundedBoolean), (C.dataBounded, C.boundedBoolean)] +boundedBoolean :: (String, String) +boundedBoolean = (C.dataBounded, C.boundedBoolean) -booleanAlgebraBoolean :: [(String, String)] -booleanAlgebraBoolean = [(C.prelude, C.booleanAlgebraBoolean), (C.dataBooleanAlgebra, C.booleanAlgebraBoolean)] +heytingAlgebraBoolean :: (String, String) +heytingAlgebraBoolean = (C.dataHeytingAlgebra, C.heytingAlgebraBoolean) -semigroupoidFn :: [(String, String)] -semigroupoidFn = [(C.prelude, C.semigroupoidFn), (C.controlSemigroupoid, C.semigroupoidFn)] +semigroupoidFn :: (String, String) +semigroupoidFn = (C.controlSemigroupoid, C.semigroupoidFn) -opAdd :: [(String, String)] -opAdd = [(C.prelude, (C.+)), (C.prelude, C.add), (C.dataSemiring, C.add)] +opAdd :: (String, String) +opAdd = (C.dataSemiring, C.add) -opMul :: [(String, String)] -opMul = [(C.prelude, (C.*)), (C.prelude, C.mul), (C.dataSemiring, C.mul)] +opMul :: (String, String) +opMul = (C.dataSemiring, C.mul) -opEq :: [(String, String)] -opEq = [(C.prelude, (C.==)), (C.prelude, C.eq), (C.dataEq, C.eq)] +opEq :: (String, String) +opEq = (C.dataEq, C.eq) -opNotEq :: [(String, String)] -opNotEq = [(C.prelude, (C./=)), (C.dataEq, C.notEq)] +opNotEq :: (String, String) +opNotEq = (C.dataEq, C.notEq) -opLessThan :: [(String, String)] -opLessThan = [(C.prelude, (C.<)), (C.dataOrd, C.lessThan)] +opLessThan :: (String, String) +opLessThan = (C.dataOrd, C.lessThan) -opLessThanOrEq :: [(String, String)] -opLessThanOrEq = [(C.prelude, (C.<=)), (C.dataOrd, C.lessThanOrEq)] +opLessThanOrEq :: (String, String) +opLessThanOrEq = (C.dataOrd, C.lessThanOrEq) -opGreaterThan :: [(String, String)] -opGreaterThan = [(C.prelude, (C.>)), (C.dataOrd, C.greaterThan)] +opGreaterThan :: (String, String) +opGreaterThan = (C.dataOrd, C.greaterThan) -opGreaterThanOrEq :: [(String, String)] -opGreaterThanOrEq = [(C.prelude, (C.>=)), (C.dataOrd, C.greaterThanOrEq)] +opGreaterThanOrEq :: (String, String) +opGreaterThanOrEq = (C.dataOrd, C.greaterThanOrEq) -opAppend :: [(String, String)] -opAppend = [(C.prelude, (C.<>)), (C.prelude, (C.++)), (C.prelude, C.append), (C.dataSemigroup, C.append)] +opAppend :: (String, String) +opAppend = (C.dataSemigroup, C.append) -opSub :: [(String, String)] -opSub = [(C.prelude, (C.-)), (C.prelude, C.sub), (C.dataRing, C.sub)] +opSub :: (String, String) +opSub = (C.dataRing, C.sub) -opNegate :: [(String, String)] -opNegate = [(C.prelude, C.negate), (C.dataRing, C.negate)] +opNegate :: (String, String) +opNegate = (C.dataRing, C.negate) -opDiv :: [(String, String)] -opDiv = [(C.prelude, (C./)), (C.prelude, C.div), (C.dataModuloSemiring, C.div)] +opDiv :: (String, String) +opDiv = (C.dataEuclideanRing, C.div) -opMod :: [(String, String)] -opMod = [(C.prelude, C.mod), (C.dataModuloSemiring, C.mod)] +opMod :: (String, String) +opMod = (C.dataEuclideanRing, C.mod) -opConj :: [(String, String)] -opConj = [(C.prelude, (C.&&)), (C.prelude, C.conj), (C.dataBooleanAlgebra, C.conj)] +opConj :: (String, String) +opConj = (C.dataHeytingAlgebra, C.conj) -opDisj :: [(String, String)] -opDisj = [(C.prelude, (C.||)), (C.prelude, C.disj), (C.dataBooleanAlgebra, C.disj)] +opDisj :: (String, String) +opDisj = (C.dataHeytingAlgebra, C.disj) -opNot :: [(String, String)] -opNot = [(C.prelude, C.not), (C.dataBooleanAlgebra, C.not)] +opNot :: (String, String) +opNot = (C.dataHeytingAlgebra, C.not) diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs --- a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs @@ -4,6 +4,8 @@ -- module Language.PureScript.CodeGen.JS.Optimizer.MagicDo (magicDo) where +import Prelude.Compat + import Data.List (nub) import Data.Maybe (fromJust, isJust) @@ -61,9 +63,9 @@ isPure (JSApp _ fn [dict]) | isDict (C.eff, C.applicativeEffDictionary) dict && isPurePoly fn = True isPure _ = False -- Check if an expression represents the polymorphic >>= function - isBindPoly = isFn' [(C.prelude, C.bind), (C.prelude, (C.>>=)), (C.controlBind, C.bind)] + isBindPoly = isFn (C.controlBind, C.bind) -- Check if an expression represents the polymorphic pure or return function - isPurePoly = isFn' [(C.prelude, C.pure'), (C.prelude, C.return), (C.controlApplicative, C.pure')] + isPurePoly = isFn (C.controlApplicative, C.pure') -- Check if an expression represents a function in the Eff module isEffFunc name (JSAccessor _ name' (JSVar _ eff)) = eff == C.eff && name == name' isEffFunc _ _ = False diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs --- a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs @@ -1,19 +1,9 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.CodeGen.JS.Optimizer.TCO --- Copyright : (c) Phil Freeman 2013-14 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- This module implements tail call elimination. -- ------------------------------------------------------------------------------ - module Language.PureScript.CodeGen.JS.Optimizer.TCO (tco) where + +import Prelude.Compat import Data.Monoid diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs @@ -1,27 +1,16 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.CodeGen.JS.Optimizer.Unused --- Copyright : (c) Phil Freeman 2013-14 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- Removes unused variables -- ------------------------------------------------------------------------------ - module Language.PureScript.CodeGen.JS.Optimizer.Unused ( removeCodeAfterReturnStatements , removeUnusedArg , removeUndefinedApp ) where +import Prelude.Compat + import Language.PureScript.CodeGen.JS.AST import Language.PureScript.CodeGen.JS.Optimizer.Common - import qualified Language.PureScript.Constants as C removeCodeAfterReturnStatements :: JS -> JS diff --git a/src/Language/PureScript/Comments.hs b/src/Language/PureScript/Comments.hs --- a/src/Language/PureScript/Comments.hs +++ b/src/Language/PureScript/Comments.hs @@ -5,6 +5,8 @@ -- module Language.PureScript.Comments where +import Prelude.Compat + import Data.Aeson.TH data Comment diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -1,8 +1,10 @@ --- | --- Various constants which refer to things in the Prelude --- +-- | Various constants which refer to things in the Prelude module Language.PureScript.Constants where +import Prelude.Compat + +import Language.PureScript.Names + -- Operators ($) :: String @@ -247,6 +249,12 @@ moduloSemiringInt :: String moduloSemiringInt = "moduloSemiringInt" +euclideanRingNumber :: String +euclideanRingNumber = "euclideanRingNumber" + +euclideanRingInt :: String +euclideanRingInt = "euclideanRingInt" + ordBoolean :: String ordBoolean = "ordBoolean" @@ -283,6 +291,9 @@ booleanAlgebraBoolean :: String booleanAlgebraBoolean = "booleanAlgebraBoolean" +heytingAlgebraBoolean :: String +heytingAlgebraBoolean = "heytingAlgebraBoolean" + semigroupString :: String semigroupString = "semigroupString" @@ -308,6 +319,17 @@ main :: String main = "main" +-- Prim + +partial :: String +partial = "Partial" + +pattern Partial :: Qualified (ProperName 'ClassName) +pattern Partial = Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Partial") + +pattern Fail :: Qualified (ProperName 'ClassName) +pattern Fail = Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Fail") + -- Code Generation __superclass_ :: String @@ -348,11 +370,8 @@ dataSemigroup :: String dataSemigroup = "Data_Semigroup" -dataModuloSemiring :: String -dataModuloSemiring = "Data_ModuloSemiring" - -dataBooleanAlgebra :: String -dataBooleanAlgebra = "Data_BooleanAlgebra" +dataHeytingAlgebra :: String +dataHeytingAlgebra = "Data_HeytingAlgebra" dataEq :: String dataEq = "Data_Eq" @@ -365,6 +384,9 @@ dataRing :: String dataRing = "Data_Ring" + +dataEuclideanRing :: String +dataEuclideanRing = "Data_EuclideanRing" dataFunction :: String dataFunction = "Data_Function" diff --git a/src/Language/PureScript/CoreFn.hs b/src/Language/PureScript/CoreFn.hs --- a/src/Language/PureScript/CoreFn.hs +++ b/src/Language/PureScript/CoreFn.hs @@ -5,11 +5,11 @@ module C ) where +import Language.PureScript.AST.Literals as C import Language.PureScript.CoreFn.Ann as C import Language.PureScript.CoreFn.Binders as C import Language.PureScript.CoreFn.Desugar as C import Language.PureScript.CoreFn.Expr as C -import Language.PureScript.AST.Literals as C import Language.PureScript.CoreFn.Meta as C import Language.PureScript.CoreFn.Module as C import Language.PureScript.CoreFn.Traversals as C diff --git a/src/Language/PureScript/CoreFn/Ann.hs b/src/Language/PureScript/CoreFn/Ann.hs --- a/src/Language/PureScript/CoreFn/Ann.hs +++ b/src/Language/PureScript/CoreFn/Ann.hs @@ -1,37 +1,25 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.CoreFn.Ann --- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors --- License : MIT --- --- Maintainer : Phil Freeman , Gary Burgess --- Stability : experimental --- Portability : --- --- | Type alias for basic annotations --- ------------------------------------------------------------------------------ - -module Language.PureScript.CoreFn.Ann where - -import Language.PureScript.AST.SourcePos -import Language.PureScript.CoreFn.Meta -import Language.PureScript.Types -import Language.PureScript.Comments - --- | --- Type alias for basic annotations --- -type Ann = (Maybe SourceSpan, [Comment], Maybe Type, Maybe Meta) - --- | --- Initial annotation with no metadata --- -nullAnn :: Ann -nullAnn = (Nothing, [], Nothing, Nothing) - --- | --- Remove the comments from an annotation --- -removeComments :: Ann -> Ann -removeComments (ss, _, ty, meta) = (ss, [], ty, meta) +module Language.PureScript.CoreFn.Ann where + +import Prelude.Compat + +import Language.PureScript.AST.SourcePos +import Language.PureScript.Comments +import Language.PureScript.CoreFn.Meta +import Language.PureScript.Types + +-- | +-- Type alias for basic annotations +-- +type Ann = (Maybe SourceSpan, [Comment], Maybe Type, Maybe Meta) + +-- | +-- Initial annotation with no metadata +-- +nullAnn :: Ann +nullAnn = (Nothing, [], Nothing, Nothing) + +-- | +-- Remove the comments from an annotation +-- +removeComments :: Ann -> Ann +removeComments (ss, _, ty, meta) = (ss, [], ty, meta) diff --git a/src/Language/PureScript/CoreFn/Binders.hs b/src/Language/PureScript/CoreFn/Binders.hs --- a/src/Language/PureScript/CoreFn/Binders.hs +++ b/src/Language/PureScript/CoreFn/Binders.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE DeriveFunctor #-} - -- | -- The core functional representation for binders -- module Language.PureScript.CoreFn.Binders where + +import Prelude.Compat import Language.PureScript.AST.Literals import Language.PureScript.Names diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -1,30 +1,28 @@ module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where -import Prelude () import Prelude.Compat +import Control.Arrow (second, (***)) import Data.Function (on) import Data.List (sort, sortBy, nub) import Data.Maybe (mapMaybe) import qualified Data.Map as M -import Control.Arrow (second, (***)) - -import Language.PureScript.Crash +import Language.PureScript.AST.Literals import Language.PureScript.AST.SourcePos import Language.PureScript.AST.Traversals +import Language.PureScript.Comments import Language.PureScript.CoreFn.Ann import Language.PureScript.CoreFn.Binders import Language.PureScript.CoreFn.Expr -import Language.PureScript.AST.Literals import Language.PureScript.CoreFn.Meta import Language.PureScript.CoreFn.Module +import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Names import Language.PureScript.Sugar.TypeClasses (typeClassMemberName, superClassDictionaryNames) import Language.PureScript.Types -import Language.PureScript.Comments import qualified Language.PureScript.AST as A -- | @@ -72,12 +70,6 @@ declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) = [NonRec (ssA ss) name (exprToCoreFn ss com Nothing e)] - declToCoreFn ss com (A.FixityDeclaration _ name (Just (Qualified mn' (A.AliasValue name')))) = - let meta = getValueMeta (Qualified mn' name') - in [NonRec (ssA ss) (Op name) (Var (ss, com, Nothing, meta) (Qualified mn' name'))] - declToCoreFn ss com (A.FixityDeclaration _ name (Just (Qualified mn' (A.AliasConstructor name')))) = - let meta = Just $ getConstructorMeta (Qualified mn' name') - in [NonRec (ssA ss) (Op name) (Var (ss, com, Nothing, meta) (Qualified mn' (properToIdent name')))] declToCoreFn ss _ (A.BindingGroupDeclaration ds) = [Rec $ map (\(name, _, e) -> ((ssA ss, name), exprToCoreFn ss [] Nothing e)) ds] declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) = @@ -206,31 +198,31 @@ findQualModules :: [A.Declaration] -> [(Ann, ModuleName)] findQualModules decls = let (f, _, _, _, _) = everythingOnValues (++) fqDecls fqValues fqBinders (const []) (const []) - in f `concatMap` decls + in map (nullAnn,) $ f `concatMap` decls where - fqDecls :: A.Declaration -> [(Ann, ModuleName)] - fqDecls (A.TypeInstanceDeclaration _ _ q _ _) = getQual q - fqDecls (A.FixityDeclaration _ _ (Just q)) = getQual q + fqDecls :: A.Declaration -> [ModuleName] + fqDecls (A.TypeInstanceDeclaration _ _ q _ _) = getQual' q + fqDecls (A.ValueFixityDeclaration _ q _) = getQual' q + fqDecls (A.TypeFixityDeclaration _ q _) = getQual' q fqDecls _ = [] - fqValues :: A.Expr -> [(Ann, ModuleName)] - fqValues (A.Var q) = getQual q - fqValues (A.Constructor q) = getQual q + fqValues :: A.Expr -> [ModuleName] + fqValues (A.Var q) = getQual' q + fqValues (A.Constructor q) = getQual' q fqValues _ = [] - fqBinders :: A.Binder -> [(Ann, ModuleName)] - fqBinders (A.ConstructorBinder q _) = getQual q + fqBinders :: A.Binder -> [ModuleName] + fqBinders (A.ConstructorBinder q _) = getQual' q fqBinders _ = [] - getQual :: Qualified a -> [(Ann, ModuleName)] - getQual (Qualified (Just mn) _) = [(nullAnn, mn)] - getQual _ = [] + getQual' :: Qualified a -> [ModuleName] + getQual' = maybe [] return . getQual -- | -- Desugars import declarations from AST to CoreFn representation. -- importToCoreFn :: A.Declaration -> Maybe (Ann, ModuleName) -importToCoreFn (A.ImportDeclaration name _ _ _) = Just (nullAnn, name) +importToCoreFn (A.ImportDeclaration name _ _) = Just (nullAnn, name) importToCoreFn (A.PositionedDeclaration ss _ d) = ((,) (Just ss, [], Nothing, Nothing) . snd) <$> importToCoreFn d importToCoreFn _ = Nothing diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs --- a/src/Language/PureScript/CoreFn/Expr.hs +++ b/src/Language/PureScript/CoreFn/Expr.hs @@ -1,14 +1,14 @@ -{-# LANGUAGE DeriveFunctor #-} - -- | -- The core functional representation -- module Language.PureScript.CoreFn.Expr where +import Prelude.Compat + import Control.Arrow ((***)) -import Language.PureScript.CoreFn.Binders import Language.PureScript.AST.Literals +import Language.PureScript.CoreFn.Binders import Language.PureScript.Names -- | diff --git a/src/Language/PureScript/CoreFn/Meta.hs b/src/Language/PureScript/CoreFn/Meta.hs --- a/src/Language/PureScript/CoreFn/Meta.hs +++ b/src/Language/PureScript/CoreFn/Meta.hs @@ -3,6 +3,8 @@ -- module Language.PureScript.CoreFn.Meta where +import Prelude.Compat + import Language.PureScript.Names -- | diff --git a/src/Language/PureScript/CoreFn/Module.hs b/src/Language/PureScript/CoreFn/Module.hs --- a/src/Language/PureScript/CoreFn/Module.hs +++ b/src/Language/PureScript/CoreFn/Module.hs @@ -1,24 +1,15 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.CoreFn.Module --- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors --- License : MIT --- --- Maintainer : Phil Freeman , Gary Burgess --- Stability : experimental --- Portability : --- --- | The CoreFn module representation --- ------------------------------------------------------------------------------ - module Language.PureScript.CoreFn.Module where +import Prelude.Compat + import Language.PureScript.Comments import Language.PureScript.CoreFn.Expr import Language.PureScript.Names import Language.PureScript.Types +-- | +-- The CoreFn module representation +-- data Module a = Module { moduleComments :: [Comment] , moduleName :: ModuleName diff --git a/src/Language/PureScript/CoreFn/Traversals.hs b/src/Language/PureScript/CoreFn/Traversals.hs --- a/src/Language/PureScript/CoreFn/Traversals.hs +++ b/src/Language/PureScript/CoreFn/Traversals.hs @@ -3,11 +3,13 @@ -- module Language.PureScript.CoreFn.Traversals where +import Prelude.Compat + import Control.Arrow (second, (***), (+++)) +import Language.PureScript.AST.Literals import Language.PureScript.CoreFn.Binders import Language.PureScript.CoreFn.Expr -import Language.PureScript.AST.Literals everywhereOnValues :: (Bind a -> Bind a) -> (Expr a -> Expr a) -> diff --git a/src/Language/PureScript/Crash.hs b/src/Language/PureScript/Crash.hs --- a/src/Language/PureScript/Crash.hs +++ b/src/Language/PureScript/Crash.hs @@ -1,9 +1,11 @@ -module Language.PureScript.Crash where - --- | Exit with an error message and a crash report link. -internalError :: String -> a -internalError = - error - . ("An internal error ocurred during compilation: " ++) - . (++ "\nPlease report this at https://github.com/purescript/purescript/issues") - . show +module Language.PureScript.Crash where + +import Prelude.Compat + +-- | Exit with an error message and a crash report link. +internalError :: String -> a +internalError = + error + . ("An internal error ocurred during compilation: " ++) + . (++ "\nPlease report this at https://github.com/purescript/purescript/issues") + . show diff --git a/src/Language/PureScript/Docs.hs b/src/Language/PureScript/Docs.hs --- a/src/Language/PureScript/Docs.hs +++ b/src/Language/PureScript/Docs.hs @@ -6,9 +6,9 @@ module Docs ) where -import Language.PureScript.Docs.Types as Docs -import Language.PureScript.Docs.RenderedCode.Types as Docs -import Language.PureScript.Docs.RenderedCode.Render as Docs import Language.PureScript.Docs.Convert as Docs -import Language.PureScript.Docs.Render as Docs import Language.PureScript.Docs.ParseAndBookmark as Docs +import Language.PureScript.Docs.Render as Docs +import Language.PureScript.Docs.RenderedCode.Render as Docs +import Language.PureScript.Docs.RenderedCode.Types as Docs +import Language.PureScript.Docs.Types as Docs diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE FlexibleContexts #-} - module Language.PureScript.Docs.AsMarkdown ( renderModulesAsMarkdown , Docs @@ -9,19 +6,18 @@ , codeToString ) where -import Prelude () import Prelude.Compat import Control.Monad (unless, zipWithM_) -import Control.Monad.Writer (Writer, tell, execWriter) import Control.Monad.Error.Class (MonadError) +import Control.Monad.Writer (Writer, tell, execWriter) + import Data.Foldable (for_) import Data.List (partition) -import qualified Language.PureScript as P - -import Language.PureScript.Docs.Types import Language.PureScript.Docs.RenderedCode +import Language.PureScript.Docs.Types +import qualified Language.PureScript as P import qualified Language.PureScript.Docs.Convert as Convert import qualified Language.PureScript.Docs.Render as Render @@ -63,8 +59,6 @@ zipWithM_ (\f c -> tell' (childToString f c)) (First : repeat NotFirst) children spacer - for_ declFixity (\fixity -> fixityAsMarkdown fixity >> spacer) - for_ declComments tell' unless (null instances) $ do @@ -86,19 +80,19 @@ elemAsMarkdown (Keyword x) = x elemAsMarkdown Space = " " -fixityAsMarkdown :: P.Fixity -> Docs -fixityAsMarkdown (P.Fixity associativity precedence) = - tell' $ concat [ "_" - , associativityStr - , " / precedence " - , show precedence - , "_" - ] - where - associativityStr = case associativity of - P.Infixl -> "left-associative" - P.Infixr -> "right-associative" - P.Infix -> "non-associative" +-- fixityAsMarkdown :: P.Fixity -> Docs +-- fixityAsMarkdown (P.Fixity associativity precedence) = +-- tell' $ concat [ "_" +-- , associativityStr +-- , " / precedence " +-- , show precedence +-- , "_" +-- ] +-- where +-- associativityStr = case associativity of +-- P.Infixl -> "left-associative" +-- P.Infixr -> "right-associative" +-- P.Infix -> "non-associative" childToString :: First -> ChildDeclaration -> String childToString f decl@ChildDeclaration{..} = diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -- | Functions for converting PureScript ASTs into values of the data types -- from Language.PureScript.Docs. @@ -11,25 +9,24 @@ , collectBookmarks ) where -import Prelude () import Prelude.Compat import Control.Arrow ((&&&), second) import Control.Category ((>>>)) import Control.Monad +import Control.Monad.Error.Class (MonadError) import Control.Monad.State (runStateT) import Control.Monad.Writer.Strict (runWriterT) -import Control.Monad.Error.Class (MonadError) import qualified Data.Map as Map -import Text.Parsec (eof) -import qualified Language.PureScript as P -import qualified Language.PureScript.Constants as C - import Language.PureScript.Docs.Convert.ReExports (updateReExports) import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks) import Language.PureScript.Docs.Types +import qualified Language.PureScript as P +import qualified Language.PureScript.Constants as C +import Text.Parsec (eof) + -- | -- Like convertModules, except that it takes a list of modules, together with -- their dependency status, and discards dependency modules in the resulting @@ -107,8 +104,9 @@ else pure convertedModules where - hasWildcards = - any ((==) (ValueDeclaration P.TypeWildcard) . declInfo) . modDeclarations + hasWildcards = any (isWild . declInfo) . modDeclarations + isWild (ValueDeclaration P.TypeWildcard{}) = True + isWild _ = False go = do checkEnv <- snd <$> typeCheck modules @@ -147,7 +145,7 @@ insertValueTypes env m = m { modDeclarations = map go (modDeclarations m) } where - go (d@Declaration { declInfo = ValueDeclaration P.TypeWildcard }) = + go (d@Declaration { declInfo = ValueDeclaration P.TypeWildcard{} }) = let ident = parseIdent (declTitle d) ty = lookupName ident @@ -187,8 +185,8 @@ where desugar' = traverse P.desugarDoModule - >=> P.desugarCasesModule - >=> P.desugarTypeDeclarationsModule + >=> traverse P.desugarCasesModule + >=> traverse P.desugarTypeDeclarationsModule >=> ignoreWarnings . P.desugarImportsWithEnv [] ignoreWarnings = fmap fst . runWriterT diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -1,29 +1,24 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE FlexibleContexts #-} - module Language.PureScript.Docs.Convert.ReExports ( updateReExports ) where -import Prelude () import Prelude.Compat +import Control.Arrow ((&&&), second) import Control.Monad -import Control.Monad.Trans.State.Strict (execState) +import Control.Monad.Reader.Class (MonadReader, ask) import Control.Monad.State.Class (MonadState, gets, modify) import Control.Monad.Trans.Reader (runReaderT) -import Control.Monad.Reader.Class (MonadReader, ask) -import Control.Arrow ((&&&), first, second) +import Control.Monad.Trans.State.Strict (execState) + import Data.Either -import Data.Maybe (mapMaybe) import Data.Map (Map) -import qualified Data.Map as Map +import Data.Maybe (mapMaybe) import Data.Monoid ((<>)) - -import qualified Language.PureScript as P +import qualified Data.Map as Map import Language.PureScript.Docs.Types +import qualified Language.PureScript as P -- | -- Given: @@ -40,8 +35,7 @@ [P.ModuleName] -> Map P.ModuleName Module -> Map P.ModuleName Module -updateReExports env order modules = - execState action modules +updateReExports env order = execState action where action = void (traverse go order) @@ -102,39 +96,50 @@ -- * Filters type class declarations to ensure that only re-exported type -- class members are listed. -- -collectDeclarations :: +collectDeclarations :: forall m. (MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m) => P.Imports -> P.Exports -> m [(P.ModuleName, [Declaration])] collectDeclarations imports exports = do - valsAndMembers <- collect lookupValueDeclaration impVals expVals - typeClasses <- collect lookupTypeClassDeclaration impTCs expTCs - types <- collect lookupTypeDeclaration impTypes expTypes - typeOps <- collect lookupTypeOpDeclaration impTypeOps expTypeOps + valsAndMembers <- collect lookupValueDeclaration impVals expVals + valOps <- collect lookupValueOpDeclaration impValOps expValOps + typeClasses <- collect lookupTypeClassDeclaration impTCs expTCs + types <- collect lookupTypeDeclaration impTypes expTypes + typeOps <- collect lookupTypeOpDeclaration impTypeOps expTypeOps (vals, classes) <- handleTypeClassMembers valsAndMembers typeClasses let filteredTypes = filterDataConstructors expCtors types - let filteredClasses = filterTypeClassMembers (map fst expVals) classes + let filteredClasses = filterTypeClassMembers (Map.keys expVals) classes - pure (Map.toList (Map.unionsWith (<>) [filteredTypes, typeOps, filteredClasses, vals])) + pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals, valOps, typeOps])) where + + collect + :: (Eq a, Show a) + => (P.ModuleName -> a -> m (P.ModuleName, [b])) + -> [P.ImportRecord a] + -> Map a P.ModuleName + -> m (Map P.ModuleName [b]) collect lookup' imps exps = do - imps' <- traverse (findImport imps) exps + imps' <- traverse (findImport imps) $ Map.toList exps Map.fromListWith (<>) <$> traverse (uncurry lookup') imps' expVals = P.exportedValues exports impVals = concat (Map.elems (P.importedValues imports)) - expTypes = map (first fst) (P.exportedTypes exports) + expValOps = P.exportedValueOps exports + impValOps = concat (Map.elems (P.importedValueOps imports)) + + expTypes = Map.map snd (P.exportedTypes exports) impTypes = concat (Map.elems (P.importedTypes imports)) expTypeOps = P.exportedTypeOps exports impTypeOps = concat (Map.elems (P.importedTypeOps imports)) - expCtors = concatMap (snd . fst) (P.exportedTypes exports) + expCtors = concatMap fst (Map.elems (P.exportedTypes exports)) expTCs = P.exportedTypeClasses exports impTCs = concat (Map.elems (P.importedTypeClasses imports)) @@ -226,6 +231,20 @@ thd :: (a, b, c) -> c thd (_, _, x) = x +lookupValueOpDeclaration + :: (MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m) + => P.ModuleName + -> P.OpName 'P.ValueOpName + -> m (P.ModuleName, [Declaration]) +lookupValueOpDeclaration importedFrom op = do + decls <- lookupModuleDeclarations "lookupValueOpDeclaration" importedFrom + case filter (\d -> declTitle d == P.showOp op && isValueAlias d) decls of + [d] -> + pure (importedFrom, [d]) + other -> + internalErrorInModule + ("lookupValueOpDeclaration: unexpected result for: " ++ show other) + -- | -- Extract a particular type declaration. For data declarations, constructors -- are only included in the output if they are listed in the arguments. @@ -247,16 +266,15 @@ internalErrorInModule ("lookupTypeDeclaration: unexpected result: " ++ show other) -lookupTypeOpDeclaration :: - (MonadState (Map P.ModuleName Module) m, - MonadReader P.ModuleName m) => - P.ModuleName -> - P.Ident -> - m (P.ModuleName, [Declaration]) +lookupTypeOpDeclaration + :: (MonadState (Map P.ModuleName Module) m,MonadReader P.ModuleName m) + => P.ModuleName + -> P.OpName 'P.TypeOpName + -> m (P.ModuleName, [Declaration]) lookupTypeOpDeclaration importedFrom tyOp = do decls <- lookupModuleDeclarations "lookupTypeOpDeclaration" importedFrom let - ds = filter (\d -> declTitle d == ("type " ++ P.showIdent tyOp) && isTypeAlias d) decls + ds = filter (\d -> declTitle d == ("type " ++ P.showOp tyOp) && isTypeAlias d) decls case ds of [d] -> pure (importedFrom, [d]) @@ -264,12 +282,11 @@ internalErrorInModule ("lookupTypeOpDeclaration: unexpected result: " ++ show other) -lookupTypeClassDeclaration :: - (MonadState (Map P.ModuleName Module) m, - MonadReader P.ModuleName m) => - P.ModuleName -> - P.ProperName 'P.ClassName -> - m (P.ModuleName, [Declaration]) +lookupTypeClassDeclaration + :: (MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m) + => P.ModuleName + -> P.ProperName 'P.ClassName + -> m (P.ModuleName, [Declaration]) lookupTypeClassDeclaration importedFrom tyClass = do decls <- lookupModuleDeclarations "lookupTypeClassDeclaration" importedFrom let @@ -374,10 +391,10 @@ -- -- Returns a tuple of (values, type classes). -- -handleEnv :: - (MonadReader P.ModuleName m) => - TypeClassEnv -> - m ([Declaration], [Declaration]) +handleEnv + :: (MonadReader P.ModuleName m) + => TypeClassEnv + -> m ([Declaration], [Declaration]) handleEnv TypeClassEnv{..} = envUnhandledMembers |> foldM go (envValues, mkMap envTypeClasses) @@ -405,7 +422,6 @@ , declComments = cdeclComments , declSourceSpan = cdeclSourceSpan , declChildren = [] - , declFixity = Nothing , declInfo = ValueDeclaration (addConstraint constraint typ) } _ -> @@ -426,10 +442,10 @@ -- Given a list of exported constructor names, remove any data constructor -- names in the provided Map of declarations which are not in the list. -- -filterDataConstructors :: - [P.ProperName 'P.ConstructorName] -> - Map P.ModuleName [Declaration] -> - Map P.ModuleName [Declaration] +filterDataConstructors + :: [P.ProperName 'P.ConstructorName] + -> Map P.ModuleName [Declaration] + -> Map P.ModuleName [Declaration] filterDataConstructors = filterExportedChildren isDataConstructor P.runProperName @@ -438,27 +454,25 @@ -- type class member names in the provided Map of declarations which are not in -- the list. -- -filterTypeClassMembers :: - [P.Ident] -> - Map P.ModuleName [Declaration] -> - Map P.ModuleName [Declaration] +filterTypeClassMembers + :: [P.Ident] + -> Map P.ModuleName [Declaration] + -> Map P.ModuleName [Declaration] filterTypeClassMembers = filterExportedChildren isTypeClassMember P.showIdent -filterExportedChildren :: - (Functor f) => - (ChildDeclaration -> Bool) -> - (name -> String) -> - [name] -> - f [Declaration] -> - f [Declaration] -filterExportedChildren isTargetedKind runName expNames = - fmap filterDecls +filterExportedChildren + :: (Functor f) + => (ChildDeclaration -> Bool) + -> (name -> String) + -> [name] + -> f [Declaration] + -> f [Declaration] +filterExportedChildren isTargetedKind runName expNames = fmap filterDecls where filterDecls = - map (filterChildren (\c -> not (isTargetedKind c) || - cdeclTitle c `elem` expNames')) - + map $ filterChildren $ \c -> + not (isTargetedKind c) || cdeclTitle c `elem` expNames' expNames' = map runName expNames allDeclarations :: Module -> [Declaration] @@ -471,10 +485,10 @@ internalError :: String -> a internalError = P.internalError . ("Docs.Convert.ReExports: " ++) -internalErrorInModule :: - (MonadReader P.ModuleName m) => - String -> - m a +internalErrorInModule + :: (MonadReader P.ModuleName m) + => String + -> m a internalErrorInModule msg = do mn <- ask internalError @@ -489,7 +503,7 @@ typeClassConstraintFor Declaration{..} = case declInfo of TypeClassDeclaration tyArgs _ -> - Just (P.Qualified Nothing (P.ProperName declTitle), mkConstraint tyArgs) + Just (P.Constraint (P.Qualified Nothing (P.ProperName declTitle)) (mkConstraint tyArgs) Nothing) _ -> Nothing where diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -1,26 +1,19 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE FlexibleContexts #-} - module Language.PureScript.Docs.Convert.Single ( convertSingleModule , collectBookmarks ) where -import Prelude () import Prelude.Compat -import Data.Maybe (mapMaybe, isNothing) -import Control.Monad import Control.Category ((>>>)) -import Data.Either -import Data.List (nub, isPrefixOf, isSuffixOf) +import Control.Monad -import qualified Language.PureScript as P +import Data.Either +import Data.List (nub) +import Data.Maybe (mapMaybe) import Language.PureScript.Docs.Types +import qualified Language.PureScript as P -- | -- Convert a single Module, but ignore re-exports; any re-exported types or @@ -35,7 +28,6 @@ P.exportedDeclarations >>> mapMaybe (\d -> getDeclarationTitle d >>= convertDeclaration d) >>> augmentDeclarations - >>> map addDefaultFixity -- | The data type for an intermediate stage which we go through during -- converting. @@ -65,12 +57,8 @@ -- since they appear at the top level in the AST, and since they might need to -- appear as children in two places (for example, if a data type defined in a -- module is an instance of a type class also defined in that module). --- --- The AugmentFixity constructor allows us to augment operator definitions --- with their associativity and precedence. data DeclarationAugment = AugmentChild ChildDeclaration - | AugmentFixity P.Fixity -- | Augment top-level declarations; the second pass. See the comments under -- the type synonym IntermediateDeclaration for more information. @@ -84,28 +72,8 @@ then augmentWith a d else d) ds - augmentWith a d = - case a of - AugmentChild child -> - d { declChildren = declChildren d ++ [child] } - AugmentFixity fixity -> - d { declFixity = Just fixity } - --- | Add the default operator fixity for operators which do not have associated --- fixity declarations. --- --- TODO: This may no longer be necessary after issue 806 is resolved, hopefully --- in 0.9. -addDefaultFixity :: Declaration -> Declaration -addDefaultFixity decl@Declaration{..} - | isOp declTitle && isNothing declFixity = - decl { declFixity = Just defaultFixity } - | otherwise = - decl - where - isOp :: String -> Bool - isOp str = "(" `isPrefixOf` str && ")" `isSuffixOf` str - defaultFixity = P.Fixity P.Infixl (-1) + augmentWith (AugmentChild child) d = + d { declChildren = declChildren d ++ [child] } getDeclarationTitle :: P.Declaration -> Maybe String getDeclarationTitle (P.ValueDeclaration name _ _ _) = Just (P.showIdent name) @@ -115,8 +83,8 @@ getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name) getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (P.runProperName name) getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name) -getDeclarationTitle (P.FixityDeclaration _ name (Just (P.Qualified _ P.AliasType{}))) = Just ("type (" ++ name ++ ")") -getDeclarationTitle (P.FixityDeclaration _ name _) = Just ("(" ++ name ++ ")") +getDeclarationTitle (P.TypeFixityDeclaration _ _ op) = Just ("type " ++ P.showOp op) +getDeclarationTitle (P.ValueFixityDeclaration _ _ op) = Just (P.showOp op) getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d getDeclarationTitle _ = Nothing @@ -127,7 +95,6 @@ , declComments = Nothing , declSourceSpan = Nothing , declChildren = [] - , declFixity = Nothing , declInfo = info } @@ -137,10 +104,10 @@ convertDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration convertDeclaration (P.ValueDeclaration _ _ _ (Right (P.TypedValue _ _ ty))) title = basicDeclaration title (ValueDeclaration ty) -convertDeclaration (P.ValueDeclaration {}) title = +convertDeclaration P.ValueDeclaration{} title = -- If no explicit type declaration was provided, insert a wildcard, so that -- the actual type will be added during type checking. - basicDeclaration title (ValueDeclaration P.TypeWildcard) + basicDeclaration title (ValueDeclaration P.TypeWildcard{}) convertDeclaration (P.ExternDeclaration _ ty) title = basicDeclaration title (ValueDeclaration ty) convertDeclaration (P.DataDeclaration dtype _ args ctors) title = @@ -177,10 +144,10 @@ childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp) classApp = foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName className)) tys -convertDeclaration (P.FixityDeclaration fixity _ Nothing) title = - Just (Left ([title], AugmentFixity fixity)) -convertDeclaration (P.FixityDeclaration fixity _ (Just alias)) title = - Just $ Right $ (mkDeclaration title (AliasDeclaration alias fixity)) { declFixity = Just fixity } +convertDeclaration (P.ValueFixityDeclaration fixity (P.Qualified mn alias) _) title = + Just $ Right $ mkDeclaration title (AliasDeclaration fixity (P.Qualified mn (Right alias))) +convertDeclaration (P.TypeFixityDeclaration fixity (P.Qualified mn alias) _) title = + Just $ Right $ mkDeclaration title (AliasDeclaration fixity (P.Qualified mn (Left alias))) convertDeclaration (P.PositionedDeclaration srcSpan com d') title = fmap (addComments . addSourceSpan) (convertDeclaration d' title) where @@ -196,10 +163,7 @@ Left (withAugmentChild (\d -> d { cdeclSourceSpan = Just srcSpan }) augment) - withAugmentChild f (t, a) = - case a of - AugmentChild d -> (t, AugmentChild (f d)) - _ -> (t, a) + withAugmentChild f (t, AugmentChild d) = (t, AugmentChild (f d)) convertDeclaration _ _ = Nothing convertComments :: [P.Comment] -> Maybe String diff --git a/src/Language/PureScript/Docs/ParseAndBookmark.hs b/src/Language/PureScript/Docs/ParseAndBookmark.hs --- a/src/Language/PureScript/Docs/ParseAndBookmark.hs +++ b/src/Language/PureScript/Docs/ParseAndBookmark.hs @@ -1,26 +1,22 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} - module Language.PureScript.Docs.ParseAndBookmark ( parseAndBookmark ) where -import Prelude () import Prelude.Compat -import qualified Data.Map as M import Control.Arrow (first) - import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) -import Web.Bower.PackageMeta (PackageName) +import qualified Data.Map as M +import Language.PureScript.Docs.Convert (collectBookmarks) +import Language.PureScript.Docs.Types +import qualified Language.PureScript as P + import System.IO.UTF8 (readUTF8File) -import qualified Language.PureScript as P -import Language.PureScript.Docs.Types -import Language.PureScript.Docs.Convert (collectBookmarks) +import Web.Bower.PackageMeta (PackageName) -- | -- Given: diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE RecordWildCards #-} - --- | Functions for creating `RenderedCode` values from data types in +-- | +-- Functions for creating `RenderedCode` values from data types in -- Language.PureScript.Docs.Types. -- -- These functions are the ones that are used in markdown/html documentation @@ -10,13 +9,15 @@ module Language.PureScript.Docs.Render where +import Prelude.Compat + import Data.Maybe (maybeToList) import Data.Monoid ((<>)) -import qualified Language.PureScript as P -import Language.PureScript.Docs.Types import Language.PureScript.Docs.RenderedCode +import Language.PureScript.Docs.Types import Language.PureScript.Docs.Utils.MonoidExtras +import qualified Language.PureScript as P renderDeclaration :: Declaration -> RenderedCode renderDeclaration = renderDeclarationWithOptions defaultRenderTypeOptions @@ -58,27 +59,33 @@ syntax "(" <> mintersperse (syntax "," <> sp) (map renderConstraint implies) <> syntax ")" <> sp <> syntax "<=" - AliasDeclaration for@(P.Qualified _ alias) (P.Fixity associativity precedence) -> + + AliasDeclaration (P.Fixity associativity precedence) for@(P.Qualified _ alias) -> [ keywordFixity associativity , syntax $ show precedence - , ident $ renderAlias for + , ident $ renderQualAlias for , keyword "as" , ident $ adjustAliasName alias declTitle ] where + renderType' :: P.Type -> RenderedCode renderType' = renderTypeWithOptions opts - renderAlias (P.Qualified mn alias) - | mn == currentModule opts = - P.foldFixityAlias P.runIdent P.runProperName (("type " ++) . P.runProperName) alias - | otherwise = - P.foldFixityAlias - (P.showQualified P.runIdent . P.Qualified mn) - (P.showQualified P.runProperName . P.Qualified mn) - (("type " ++) . P.showQualified P.runProperName . P.Qualified mn) - alias - adjustAliasName (P.AliasType{}) title = drop 6 (init title) + renderQualAlias :: FixityAlias -> String + renderQualAlias (P.Qualified mn alias) + | mn == currentModule opts = renderAlias id alias + | otherwise = renderAlias (\f -> P.showQualified f . P.Qualified mn) alias + + renderAlias + :: (forall a. (a -> String) -> a -> String) + -> Either (P.ProperName 'P.TypeName) (Either P.Ident (P.ProperName 'P.ConstructorName)) + -> String + renderAlias f + = either (("type " ++) . f P.runProperName) + $ either (f P.runIdent) (f P.runProperName) + + -- adjustAliasName (P.AliasType{}) title = drop 6 (init title) adjustAliasName _ title = tail (init title) renderChildDeclaration :: ChildDeclaration -> RenderedCode @@ -107,7 +114,7 @@ renderConstraint = renderConstraintWithOptions defaultRenderTypeOptions renderConstraintWithOptions :: RenderTypeOptions -> P.Constraint -> RenderedCode -renderConstraintWithOptions opts (pn, tys) = +renderConstraintWithOptions opts (P.Constraint pn tys _) = renderTypeWithOptions opts $ foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName pn)) tys renderConstraints :: [P.Constraint] -> Maybe RenderedCode diff --git a/src/Language/PureScript/Docs/RenderedCode.hs b/src/Language/PureScript/Docs/RenderedCode.hs --- a/src/Language/PureScript/Docs/RenderedCode.hs +++ b/src/Language/PureScript/Docs/RenderedCode.hs @@ -1,11 +1,8 @@ - --- | Data types and functions for representing a simplified form of PureScript --- code, intended for use in e.g. HTML documentation. - -module Language.PureScript.Docs.RenderedCode ( - module RenderedCode -) where - -import Language.PureScript.Docs.RenderedCode.Types as RenderedCode -import Language.PureScript.Docs.RenderedCode.Render as RenderedCode - + +-- | Data types and functions for representing a simplified form of PureScript +-- code, intended for use in e.g. HTML documentation. + +module Language.PureScript.Docs.RenderedCode (module RenderedCode) where + +import Language.PureScript.Docs.RenderedCode.Types as RenderedCode +import Language.PureScript.Docs.RenderedCode.Render as RenderedCode diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/Render.hs --- a/src/Language/PureScript/Docs/RenderedCode/Render.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Render.hs @@ -1,38 +1,36 @@ -- | Functions for producing RenderedCode values from PureScript Type values. -module Language.PureScript.Docs.RenderedCode.Render ( - renderType, - renderTypeAtom, - renderRow, - renderKind, - RenderTypeOptions(..), - defaultRenderTypeOptions, - renderTypeWithOptions -) where +module Language.PureScript.Docs.RenderedCode.Render + ( renderType + , renderTypeAtom + , renderRow + , renderKind + , RenderTypeOptions(..) + , defaultRenderTypeOptions + , renderTypeWithOptions + ) where -import Prelude () import Prelude.Compat -import Data.Monoid ((<>)) import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) import Control.Arrow ((<+>)) -import Control.PatternArrows +import Control.PatternArrows as PA import Language.PureScript.Crash -import Language.PureScript.Names -import Language.PureScript.Types -import Language.PureScript.Kinds -import Language.PureScript.Pretty.Kinds -import Language.PureScript.Environment - import Language.PureScript.Docs.RenderedCode.Types import Language.PureScript.Docs.Utils.MonoidExtras +import Language.PureScript.Environment +import Language.PureScript.Kinds +import Language.PureScript.Names +import Language.PureScript.Pretty.Kinds +import Language.PureScript.Types typeLiterals :: Pattern () Type RenderedCode typeLiterals = mkPattern match where - match TypeWildcard = + match TypeWildcard{} = Just (syntax "_") match (TypeVar var) = Just (ident var) @@ -51,12 +49,12 @@ match (BinaryNoParensType op l r) = Just $ renderTypeAtom l <> sp <> renderTypeAtom op <> sp <> renderTypeAtom r match (TypeOp (Qualified mn op)) = - Just (ident' (runIdent op) (maybeToContainingModule mn)) + Just (ident' (runOpName op) (maybeToContainingModule mn)) match _ = Nothing renderConstraint :: Constraint -> RenderedCode -renderConstraint (pn, tys) = +renderConstraint (Constraint pn tys _) = let instApp = foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys in renderType instApp @@ -161,7 +159,7 @@ convert :: RenderTypeOptions -> Type -> Type convert _ (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret -convert opts (TypeApp o r) | o == tyObject && prettyPrintObjects opts = PrettyPrintObject r +convert opts (TypeApp o r) | o == tyRecord && prettyPrintObjects opts = PrettyPrintObject r convert _ other = other convertForAlls :: Type -> Type @@ -184,9 +182,10 @@ -- Render code representing a Type, as it should appear inside parentheses -- renderTypeAtom :: Type -> RenderedCode -renderTypeAtom = - fromMaybe (internalError "Incomplete pattern") . pattern matchTypeAtom () . preprocessType defaultRenderTypeOptions - +renderTypeAtom + = fromMaybe (internalError "Incomplete pattern") + . PA.pattern matchTypeAtom () + . preprocessType defaultRenderTypeOptions -- | -- Render code representing a Type @@ -207,5 +206,7 @@ } renderTypeWithOptions :: RenderTypeOptions -> Type -> RenderedCode -renderTypeWithOptions opts = - fromMaybe (internalError "Incomplete pattern") . pattern matchType () . preprocessType opts +renderTypeWithOptions opts + = fromMaybe (internalError "Incomplete pattern") + . PA.pattern matchType () + . preprocessType opts diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs --- a/src/Language/PureScript/Docs/RenderedCode/Types.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs @@ -32,12 +32,12 @@ , keywordFixity ) where -import Prelude () import Prelude.Compat -import qualified Data.Aeson as A -import Data.Aeson.BetterErrors import Control.Monad.Error.Class (MonadError(..)) + +import Data.Aeson.BetterErrors +import qualified Data.Aeson as A import qualified Language.PureScript as P diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE RankNTypes #-} module Language.PureScript.Docs.Types ( module Language.PureScript.Docs.Types @@ -9,25 +6,27 @@ ) where -import Prelude () import Prelude.Compat import Control.Arrow (first, (***)) import Control.Monad (when) -import Data.Maybe (mapMaybe) -import Data.Version + import Data.Aeson ((.=)) -import qualified Data.Aeson as A import Data.Aeson.BetterErrors -import Text.ParserCombinators.ReadP (readP_to_S) -import Data.Text (Text) import Data.ByteString.Lazy (ByteString) +import Data.Either (isLeft, isRight) +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import Data.Version +import qualified Data.Aeson as A import qualified Data.Text as T -import Web.Bower.PackageMeta hiding (Version, displayError) - import qualified Language.PureScript as P +import Text.ParserCombinators.ReadP (readP_to_S) + +import Web.Bower.PackageMeta hiding (Version, displayError) + import Language.PureScript.Docs.RenderedCode as ReExports (RenderedCode, asRenderedCode, ContainingModule(..), asContainingModule, @@ -86,7 +85,6 @@ , declComments :: Maybe String , declSourceSpan :: Maybe P.SourceSpan , declChildren :: [ChildDeclaration] - , declFixity :: Maybe P.Fixity -- TODO: remove in 0.9 , declInfo :: DeclarationInfo } deriving (Show, Eq, Ord) @@ -133,9 +131,11 @@ -- An operator alias declaration, with the member the alias is for and the -- operator's fixity. -- - | AliasDeclaration (P.Qualified P.FixityAlias) P.Fixity + | AliasDeclaration P.Fixity FixityAlias deriving (Show, Eq, Ord) +type FixityAlias = P.Qualified (Either (P.ProperName 'P.TypeName) (Either P.Ident (P.ProperName 'P.ConstructorName))) + declInfoToString :: DeclarationInfo -> String declInfoToString (ValueDeclaration _) = "value" declInfoToString (DataDeclaration _ _) = "data" @@ -167,14 +167,13 @@ isValueAlias :: Declaration -> Bool isValueAlias Declaration{..} = case declInfo of - (AliasDeclaration (P.Qualified _ P.AliasConstructor{}) _) -> True - (AliasDeclaration (P.Qualified _ P.AliasValue{}) _) -> True + AliasDeclaration _ (P.Qualified _ d) -> isRight d _ -> False isTypeAlias :: Declaration -> Bool isTypeAlias Declaration{..} = case declInfo of - (AliasDeclaration (P.Qualified _ P.AliasType{}) _) -> True + AliasDeclaration _ (P.Qualified _ d) -> isLeft d _ -> False -- | Discard any children which do not satisfy the given predicate. @@ -364,7 +363,6 @@ <*> key "comments" (perhaps asString) <*> key "sourceSpan" (perhaps asSourceSpan) <*> key "children" (eachInArray asChildDeclaration) - <*> key "fixity" (perhaps asFixity) <*> key "info" asDeclarationInfo asReExport :: Parse PackageError (P.ModuleName, [Declaration]) @@ -385,6 +383,9 @@ P.Fixity <$> key "associativity" asAssociativity <*> key "precedence" asIntegral +asFixityAlias :: Parse PackageError FixityAlias +asFixityAlias = fromAesonParser + parseAssociativity :: String -> Maybe P.Associativity parseAssociativity str = case str of "infix" -> Just P.Infix @@ -413,14 +414,11 @@ TypeClassDeclaration <$> key "arguments" asTypeArguments <*> key "superclasses" (eachInArray asConstraint) "alias" -> - AliasDeclaration <$> key "for" asAliasFor - <*> key "fixity" asFixity + AliasDeclaration <$> key "fixity" asFixity + <*> key "alias" asFixityAlias other -> throwCustomError (InvalidDeclarationType other) -asAliasFor :: Parse e (P.Qualified P.FixityAlias) -asAliasFor = fromAesonParser - asTypeArguments :: Parse PackageError [(String, Maybe P.Kind)] asTypeArguments = eachInArray asTypeArgument where @@ -465,8 +463,9 @@ <*> nth 1 asIntegral asConstraint :: Parse PackageError P.Constraint -asConstraint = (,) <$> nth 0 asQualifiedProperName - <*> nth 1 (eachInArray asType) +asConstraint = P.Constraint <$> key "constraintClass" asQualifiedProperName + <*> key "constraintArgs" (eachInArray asType) + <*> pure Nothing asQualifiedProperName :: Parse e (P.Qualified (P.ProperName a)) asQualifiedProperName = fromAesonParser @@ -538,7 +537,6 @@ , "comments" .= declComments , "sourceSpan" .= declSourceSpan , "children" .= declChildren - , "fixity" .= declFixity , "info" .= declInfo ] @@ -559,7 +557,7 @@ ExternDataDeclaration kind -> ["kind" .= kind] TypeSynonymDeclaration args ty -> ["arguments" .= args, "type" .= ty] TypeClassDeclaration args super -> ["arguments" .= args, "superclasses" .= super] - AliasDeclaration for fixity -> ["for" .= for, "fixity" .= fixity] + AliasDeclaration fixity alias -> ["fixity" .= fixity, "alias" .= alias] instance A.ToJSON ChildDeclarationInfo where toJSON info = A.object $ "declType" .= childDeclInfoToString info : props diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -3,11 +3,13 @@ module Language.PureScript.Environment where -import Data.Maybe (fromMaybe) +import Prelude.Compat + import Data.Aeson.TH +import Data.Maybe (fromMaybe) +import qualified Data.Aeson as A import qualified Data.Map as M import qualified Data.Text as T -import qualified Data.Aeson as A import Language.PureScript.Crash import Language.PureScript.Kinds @@ -194,16 +196,16 @@ tyArray = primTy "Array" -- | --- Type constructor for objects +-- Type constructor for records -- -tyObject :: Type -tyObject = primTy "Object" +tyRecord :: Type +tyRecord = primTy "Record" -- | --- Check whether a type is an object +-- Check whether a type is a record -- isObject :: Type -> Bool -isObject = isTypeOrApplied tyObject +isObject = isTypeOrApplied tyRecord -- | -- Check whether a type is a function @@ -230,14 +232,15 @@ primTypes = M.fromList [ (primName "Function", (FunKind Star (FunKind Star Star), ExternData)) - , (primName "Array", (FunKind Star Star, ExternData)) - , (primName "Object", (FunKind (Row Star) Star, ExternData)) - , (primName "String", (Star, ExternData)) - , (primName "Char", (Star, ExternData)) - , (primName "Number", (Star, ExternData)) - , (primName "Int", (Star, ExternData)) - , (primName "Boolean", (Star, ExternData)) - , (primName "Partial", (Star, ExternData)) + , (primName "Array", (FunKind Star Star, ExternData)) + , (primName "Record", (FunKind (Row Star) Star, ExternData)) + , (primName "String", (Star, ExternData)) + , (primName "Char", (Star, ExternData)) + , (primName "Number", (Star, ExternData)) + , (primName "Int", (Star, ExternData)) + , (primName "Boolean", (Star, ExternData)) + , (primName "Partial", (Star, ExternData)) + , (primName "Fail", (FunKind Symbol Star, ExternData)) ] -- | @@ -247,7 +250,9 @@ primClasses :: M.Map (Qualified (ProperName 'ClassName)) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint]) primClasses = M.fromList - [ (primName "Partial", ([], [], [])) ] + [ (primName "Partial", ([], [], [])) + , (primName "Fail", ([("message", Just Symbol)], [], [])) + ] -- | -- Finds information about data constructors from the current environment. diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -1,40 +1,40 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} module Language.PureScript.Errors where -import Prelude () import Prelude.Compat -import Data.Ord (comparing) +import Control.Arrow ((&&&)) +import Control.Monad +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Trans.State.Lazy +import Control.Monad.Writer + import Data.Char (isSpace) import Data.Either (lefts, rights) -import Data.List (intercalate, transpose, nub, nubBy, sortBy, partition) import Data.Foldable (fold) +import Data.List (intercalate, transpose, nub, nubBy, sortBy, partition) import Data.Maybe (maybeToList) - +import Data.Ord (comparing) import qualified Data.Map as M -import Control.Monad -import Control.Monad.Writer -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Trans.State.Lazy -import Control.Arrow ((&&&)) - -import Language.PureScript.Crash import Language.PureScript.AST +import Language.PureScript.Crash +import Language.PureScript.Kinds +import Language.PureScript.Names import Language.PureScript.Pretty -import Language.PureScript.Pretty.Common (before) +import Language.PureScript.Traversals import Language.PureScript.Types -import Language.PureScript.Names -import Language.PureScript.Kinds +import Language.PureScript.Pretty.Common (endWith) import qualified Language.PureScript.Bundle as Bundle +import qualified Language.PureScript.Constants as C -import qualified Text.PrettyPrint.Boxes as Box +import qualified System.Console.ANSI as ANSI import qualified Text.Parsec as P import qualified Text.Parsec.Error as PE +import qualified Text.PrettyPrint.Boxes as Box import Text.Parsec.Error (Message(..)) -- | A type of error messages @@ -52,42 +52,22 @@ | CannotWriteFile FilePath | InfiniteType Type | InfiniteKind Kind - | MultipleFixities Ident + | MultipleValueOpFixities (OpName 'ValueOpName) + | MultipleTypeOpFixities (OpName 'TypeOpName) | OrphanTypeDeclaration Ident - | OrphanFixityDeclaration String | RedefinedModule ModuleName [SourceSpan] | RedefinedIdent Ident | OverlappingNamesInLet - | UnknownModule ModuleName - | UnknownType (Qualified (ProperName 'TypeName)) - | UnknownTypeOp (Qualified Ident) - | UnknownTypeClass (Qualified (ProperName 'ClassName)) - | UnknownValue (Qualified Ident) - | UnknownDataConstructor (Qualified (ProperName 'ConstructorName)) (Maybe (Qualified (ProperName 'ConstructorName))) - | UnknownTypeConstructor (Qualified (ProperName 'TypeName)) - | UnknownImportType ModuleName (ProperName 'TypeName) - | UnknownExportType (ProperName 'TypeName) - | UnknownImportTypeOp ModuleName Ident - | UnknownExportTypeOp Ident - | UnknownImportTypeClass ModuleName (ProperName 'ClassName) - | UnknownExportTypeClass (ProperName 'ClassName) - | UnknownImportValue ModuleName Ident - | UnknownExportValue Ident - | UnknownExportModule ModuleName + | UnknownName (Qualified Name) + | UnknownImport ModuleName Name | UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName) + | UnknownExport Name | UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName) - | ScopeConflict String [ModuleName] - | ScopeShadowing String (Maybe ModuleName) [ModuleName] - | ConflictingTypeDecls (ProperName 'TypeName) - | ConflictingCtorDecls (ProperName 'ConstructorName) - | TypeConflictsWithClass (ProperName 'TypeName) - | CtorConflictsWithClass (ProperName 'ConstructorName) - | ClassConflictsWithType (ProperName 'ClassName) - | ClassConflictsWithCtor (ProperName 'ClassName) + | ScopeConflict Name [ModuleName] + | ScopeShadowing Name (Maybe ModuleName) [ModuleName] + | DeclConflict Name Name + | ExportConflict (Qualified Name) (Qualified Name) | DuplicateModuleName ModuleName - | DuplicateClassExport (ProperName 'ClassName) - | DuplicateValueExport Ident - | DuplicateTypeOpExport Ident | DuplicateTypeArgument String | InvalidDoBind | InvalidDoLet @@ -102,7 +82,7 @@ | KindsDoNotUnify Kind Kind | ConstrainedTypeUnified Type Type | OverlappingInstances (Qualified (ProperName 'ClassName)) [Type] [Qualified Ident] - | NoInstanceFound (Qualified (ProperName 'ClassName)) [Type] + | NoInstanceFound Constraint | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type] | CannotDerive (Qualified (ProperName 'ClassName)) [Type] | CannotFindDerivingType (ProperName 'TypeName) @@ -128,35 +108,27 @@ | ShadowedTypeVar String | UnusedTypeVar String | WildcardInferredType Type - | HoleInferredType String Type + | HoleInferredType String Type [(Ident, Type)] | MissingTypeDeclaration Ident Type - | NotExhaustivePattern [[Binder]] Bool | OverlappingPattern [[Binder]] Bool | IncompleteExhaustivityCheck - | ClassOperator (ProperName 'ClassName) Ident | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName) | ImportHidingModule ModuleName | UnusedImport ModuleName | UnusedExplicitImport ModuleName [String] (Maybe ModuleName) [DeclarationRef] | UnusedDctorImport (ProperName 'TypeName) | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName] - | DeprecatedOperatorDecl String - | DeprecatedOperatorSection Expr (Either Expr Expr) - | DeprecatedQualifiedSyntax ModuleName ModuleName - | DeprecatedClassImport ModuleName (ProperName 'ClassName) - | DeprecatedClassExport (ProperName 'ClassName) | DuplicateSelectiveImport ModuleName | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName) - | DuplicateImportRef String - | DuplicateExportRef String + | DuplicateImportRef Name + | DuplicateExportRef Name | IntOutOfRange Integer String Integer Integer - | RedundantEmptyHidingImport ModuleName | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef] | ImplicitImport ModuleName [DeclarationRef] | HidingImport ModuleName [DeclarationRef] | CaseBinderLengthDiffers Int [Binder] | IncorrectAnonymousArgument - | InvalidOperatorInBinder Ident Ident + | InvalidOperatorInBinder (Qualified (OpName 'ValueOpName)) (Qualified Ident) | DeprecatedRequirePath | CannotGeneralizeRecursiveFunction Ident Type deriving (Show) @@ -241,42 +213,22 @@ CannotWriteFile{} -> "CannotWriteFile" InfiniteType{} -> "InfiniteType" InfiniteKind{} -> "InfiniteKind" - MultipleFixities{} -> "MultipleFixities" + MultipleValueOpFixities{} -> "MultipleValueOpFixities" + MultipleTypeOpFixities{} -> "MultipleTypeOpFixities" OrphanTypeDeclaration{} -> "OrphanTypeDeclaration" - OrphanFixityDeclaration{} -> "OrphanFixityDeclaration" RedefinedModule{} -> "RedefinedModule" RedefinedIdent{} -> "RedefinedIdent" OverlappingNamesInLet -> "OverlappingNamesInLet" - UnknownModule{} -> "UnknownModule" - UnknownType{} -> "UnknownType" - UnknownTypeOp{} -> "UnknownTypeOp" - UnknownTypeClass{} -> "UnknownTypeClass" - UnknownValue{} -> "UnknownValue" - UnknownDataConstructor{} -> "UnknownDataConstructor" - UnknownTypeConstructor{} -> "UnknownTypeConstructor" - UnknownImportType{} -> "UnknownImportType" - UnknownImportTypeOp{} -> "UnknownImportTypeOp" - UnknownExportType{} -> "UnknownExportType" - UnknownExportTypeOp{} -> "UnknownExportTypeOp" - UnknownImportTypeClass{} -> "UnknownImportTypeClass" - UnknownExportTypeClass{} -> "UnknownExportTypeClass" - UnknownImportValue{} -> "UnknownImportValue" - UnknownExportValue{} -> "UnknownExportValue" - UnknownExportModule{} -> "UnknownExportModule" + UnknownName{} -> "UnknownName" + UnknownImport{} -> "UnknownImport" UnknownImportDataConstructor{} -> "UnknownImportDataConstructor" + UnknownExport{} -> "UnknownExport" UnknownExportDataConstructor{} -> "UnknownExportDataConstructor" ScopeConflict{} -> "ScopeConflict" ScopeShadowing{} -> "ScopeShadowing" - ConflictingTypeDecls{} -> "ConflictingTypeDecls" - ConflictingCtorDecls{} -> "ConflictingCtorDecls" - TypeConflictsWithClass{} -> "TypeConflictsWithClass" - CtorConflictsWithClass{} -> "CtorConflictsWithClass" - ClassConflictsWithType{} -> "ClassConflictsWithType" - ClassConflictsWithCtor{} -> "ClassConflictsWithCtor" + DeclConflict{} -> "DeclConflict" + ExportConflict{} -> "ExportConflict" DuplicateModuleName{} -> "DuplicateModuleName" - DuplicateClassExport{} -> "DuplicateClassExport" - DuplicateValueExport{} -> "DuplicateValueExport" - DuplicateTypeOpExport{} -> "DuplicateTypeOpExport" DuplicateTypeArgument{} -> "DuplicateTypeArgument" InvalidDoBind -> "InvalidDoBind" InvalidDoLet -> "InvalidDoLet" @@ -319,27 +271,19 @@ WildcardInferredType{} -> "WildcardInferredType" HoleInferredType{} -> "HoleInferredType" MissingTypeDeclaration{} -> "MissingTypeDeclaration" - NotExhaustivePattern{} -> "NotExhaustivePattern" OverlappingPattern{} -> "OverlappingPattern" IncompleteExhaustivityCheck{} -> "IncompleteExhaustivityCheck" - ClassOperator{} -> "ClassOperator" MisleadingEmptyTypeImport{} -> "MisleadingEmptyTypeImport" ImportHidingModule{} -> "ImportHidingModule" UnusedImport{} -> "UnusedImport" UnusedExplicitImport{} -> "UnusedExplicitImport" UnusedDctorImport{} -> "UnusedDctorImport" UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport" - DeprecatedOperatorDecl{} -> "DeprecatedOperatorDecl" - DeprecatedOperatorSection{} -> "DeprecatedOperatorSection" - DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax" - DeprecatedClassImport{} -> "DeprecatedClassImport" - DeprecatedClassExport{} -> "DeprecatedClassExport" DuplicateSelectiveImport{} -> "DuplicateSelectiveImport" DuplicateImport{} -> "DuplicateImport" DuplicateImportRef{} -> "DuplicateImportRef" DuplicateExportRef{} -> "DuplicateExportRef" IntOutOfRange{} -> "IntOutOfRange" - RedundantEmptyHidingImport{} -> "RedundantEmptyHidingImport" ImplicitQualifiedImport{} -> "ImplicitQualifiedImport" ImplicitImport{} -> "ImplicitImport" HidingImport{} -> "HidingImport" @@ -381,14 +325,17 @@ -- | A map from rigid type variable name/unknown variable pairs to new variables. data TypeMap = TypeMap - { umSkolemMap :: M.Map Int (String, Int, Maybe SourceSpan) - , umNextSkolem :: Int - , umUnknownMap :: M.Map Int Int - , umNextUnknown :: Int + { umSkolemMap :: M.Map Int (String, Int, Maybe SourceSpan) + -- ^ a map from skolems to their new names, including source and naming info + , umUnknownMap :: M.Map Int Int + -- ^ a map from unification variables to their new names + , umNextIndex :: Int + -- ^ unknowns and skolems share a source of names during renaming, to + -- avoid overlaps in error messages. This is the next label for either case. } deriving Show defaultUnknownMap :: TypeMap -defaultUnknownMap = TypeMap M.empty 0 M.empty 0 +defaultUnknownMap = TypeMap M.empty M.empty 0 -- | How critical the issue is data Level = Error | Warning deriving Show @@ -407,16 +354,16 @@ m <- get case M.lookup u (umUnknownMap m) of Nothing -> do - let u' = umNextUnknown m - put $ m { umUnknownMap = M.insert u u' (umUnknownMap m), umNextUnknown = u' + 1 } + let u' = umNextIndex m + put $ m { umUnknownMap = M.insert u u' (umUnknownMap m), umNextIndex = u' + 1 } return (TUnknown u') Just u' -> return (TUnknown u') replaceTypes (Skolem name s sko ss) = do m <- get case M.lookup s (umSkolemMap m) of Nothing -> do - let s' = umNextSkolem m - put $ m { umSkolemMap = M.insert s (name, s', ss) (umSkolemMap m), umNextSkolem = s' + 1 } + let s' = umNextIndex m + put $ m { umSkolemMap = M.insert s (name, s', ss) (umSkolemMap m), umNextIndex = s' + 1 } return (Skolem name s' sko ss) Just (_, s', _) -> return (Skolem name s' sko ss) replaceTypes other = return other @@ -430,14 +377,14 @@ gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t - gSimple (NoInstanceFound cl ts) = NoInstanceFound cl <$> traverse f ts + gSimple (NoInstanceFound con) = NoInstanceFound <$> overConstraintArgs (traverse f) con gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts gSimple (WildcardInferredType ty) = WildcardInferredType <$> f ty - gSimple (HoleInferredType name ty) = HoleInferredType name <$> f ty + gSimple (HoleInferredType name ty env) = HoleInferredType name <$> f ty <*> traverse (sndM f) env gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty gSimple (CannotGeneralizeRecursiveFunction nm ty) = CannotGeneralizeRecursiveFunction nm <$> f ty @@ -457,18 +404,16 @@ -- TODO Other possible suggestions: -- WildcardInferredType - source span not small enough -- DuplicateSelectiveImport - would require 2 ranges to remove and 1 insert --- DeprecatedClassExport, DeprecatedClassImport, DeprecatedOperatorSection, would want to replace smaller span? errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion errorSuggestion err = case err of UnusedImport{} -> emptySuggestion - RedundantEmptyHidingImport{} -> emptySuggestion DuplicateImport{} -> emptySuggestion - DeprecatedQualifiedSyntax name qualName -> suggest $ - "import " ++ runModuleName name ++ " as " ++ runModuleName qualName UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule) HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing + MissingTypeDeclaration ident ty -> suggest $ showIdent ident ++ " :: " ++ prettyPrintType ty + WildcardInferredType ty -> suggest $ prettyPrintType ty _ -> Nothing where @@ -483,20 +428,81 @@ qstr (Just mn) = " as " ++ runModuleName mn qstr Nothing = "" +suggestionSpan :: ErrorMessage -> Maybe SourceSpan +suggestionSpan e = + getSpan (unwrapErrorMessage e) <$> errorSpan e + where + startOnly SourceSpan{spanName, spanStart} = SourceSpan {spanName, spanStart, spanEnd = spanStart} + + getSpan simple ss = + case simple of + MissingTypeDeclaration{} -> startOnly ss + _ -> ss + showSuggestion :: SimpleErrorMessage -> String showSuggestion suggestion = case errorSuggestion suggestion of Just (ErrorSuggestion x) -> x _ -> "" +ansiColor :: (ANSI.ColorIntensity, ANSI.Color) -> String +ansiColor (intesity, color) = + ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground intesity color] + +ansiColorReset :: String +ansiColorReset = + ANSI.setSGRCode [ANSI.Reset] + +colorCode :: Maybe (ANSI.ColorIntensity, ANSI.Color) -> String -> String +colorCode codeColor code = case codeColor of + Nothing -> code + Just cc -> concat [ansiColor cc, code, ansiColorReset] + +colorCodeBox :: Maybe (ANSI.ColorIntensity, ANSI.Color) -> Box.Box -> Box.Box +colorCodeBox codeColor b = case codeColor of + Nothing -> b + Just cc + | Box.rows b == 1 -> + Box.text (ansiColor cc) Box.<> b `endWith` Box.text ansiColorReset + + | otherwise -> Box.hcat Box.left -- making two boxes, one for each side of the box so that it will set each row it's own color and will reset it afterwards + [ Box.vcat Box.top $ replicate (Box.rows b) $ Box.text $ ansiColor cc + , b + , Box.vcat Box.top $ replicate (Box.rows b) $ Box.text ansiColorReset + ] + + +-- | Default color intesity and color for code +defaultCodeColor :: (ANSI.ColorIntensity, ANSI.Color) +defaultCodeColor = (ANSI.Dull, ANSI.Yellow) + +-- | `prettyPrintSingleError` Options +data PPEOptions = PPEOptions + { ppeCodeColor :: Maybe (ANSI.ColorIntensity, ANSI.Color) -- ^ Color code with this color... or not + , ppeFull :: Bool -- ^ Should write a full error message? + , ppeLevel :: Level -- ^ Should this report an error or a warning? + , ppeShowWiki :: Bool -- ^ Should show a link to error message's wiki page? + } + +-- | Default options for PPEOptions +defaultPPEOptions :: PPEOptions +defaultPPEOptions = PPEOptions + { ppeCodeColor = Just defaultCodeColor + , ppeFull = False + , ppeLevel = Error + , ppeShowWiki = True + } + + -- | -- Pretty print a single error, simplifying if necessary -- -prettyPrintSingleError :: Bool -> Level -> Bool -> ErrorMessage -> Box.Box -prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap $ do +prettyPrintSingleError :: PPEOptions -> ErrorMessage -> Box.Box +prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalState defaultUnknownMap $ do em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e) um <- get return (prettyPrintErrorMessage um em) where + (markCode, markCodeBox) = (colorCode &&& colorCodeBox) codeColor -- Pretty print an ErrorMessage prettyPrintErrorMessage :: TypeMap -> ErrorMessage -> Box.Box @@ -505,9 +511,10 @@ [ foldr renderHint (indent (renderSimpleErrorMessage simple)) hints ] ++ maybe [] (return . Box.moveDown 1) typeInformation ++ - [ Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri e ++ " for more information, " - , line $ "or to contribute content related to this " ++ levelText ++ "." - ] + [ Box.moveDown 1 $ paras + [ line $ "See " ++ wikiUri e ++ " for more information, " + , line $ "or to contribute content related to this " ++ levelText ++ "." + ] | showWiki ] where @@ -522,11 +529,11 @@ skolemInfo :: (String, Int, Maybe SourceSpan) -> Box.Box skolemInfo (name, s, ss) = paras $ - line (name ++ show s ++ " is a rigid type variable") + line (markCode (name ++ show s) ++ " is a rigid type variable") : foldMap (return . line . (" bound at " ++) . displayStartEndPos) ss unknownInfo :: Int -> Box.Box - unknownInfo u = line $ "_" ++ show u ++ " is an unknown type" + unknownInfo u = line $ markCode ("t" ++ show u) ++ " is an unknown type" renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box renderSimpleErrorMessage (CannotGetFileInfo path) = @@ -545,35 +552,35 @@ paras $ [ line "Unable to parse foreign module:" , indent . line $ path ] ++ - (map (indent . line) (concatMap Bundle.printErrorMessage (maybeToList extra))) + map (indent . line) (concatMap Bundle.printErrorMessage (maybeToList extra)) renderSimpleErrorMessage (ErrorParsingModule err) = paras [ line "Unable to parse module: " , prettyPrintParseError err ] renderSimpleErrorMessage (MissingFFIModule mn) = - line $ "The foreign module implementation for module " ++ runModuleName mn ++ " is missing." + line $ "The foreign module implementation for module " ++ markCode (runModuleName mn) ++ " is missing." renderSimpleErrorMessage (UnnecessaryFFIModule mn path) = - paras [ line $ "An unnecessary foreign module implementation was provided for module " ++ runModuleName mn ++ ": " + paras [ line $ "An unnecessary foreign module implementation was provided for module " ++ markCode (runModuleName mn) ++ ": " , indent . line $ path - , line $ "Module " ++ runModuleName mn ++ " does not contain any foreign import declarations, so a foreign module is not necessary." + , line $ "Module " ++ markCode (runModuleName mn) ++ " does not contain any foreign import declarations, so a foreign module is not necessary." ] renderSimpleErrorMessage (MissingFFIImplementations mn idents) = - paras [ line $ "The following values are not defined in the foreign module for module " ++ runModuleName mn ++ ": " + paras [ line $ "The following values are not defined in the foreign module for module " ++ markCode (runModuleName mn) ++ ": " , indent . paras $ map (line . runIdent) idents ] renderSimpleErrorMessage (UnusedFFIImplementations mn idents) = - paras [ line $ "The following definitions in the foreign module for module " ++ runModuleName mn ++ " are unused: " + paras [ line $ "The following definitions in the foreign module for module " ++ markCode (runModuleName mn) ++ " are unused: " , indent . paras $ map (line . runIdent) idents ] renderSimpleErrorMessage (InvalidFFIIdentifier mn ident) = - paras [ line $ "In the FFI module for " ++ runModuleName mn ++ ":" + paras [ line $ "In the FFI module for " ++ markCode (runModuleName mn) ++ ":" , indent . paras $ - [ line $ "The identifier `" ++ ident ++ "` is not valid in PureScript." + [ line $ "The identifier " ++ markCode ident ++ " is not valid in PureScript." , line "Note that exported identifiers in FFI modules must be valid PureScript identifiers." ] ] renderSimpleErrorMessage (MultipleFFIModules mn paths) = - paras [ line $ "Multiple foreign module implementations have been provided for module " ++ runModuleName mn ++ ": " + paras [ line $ "Multiple foreign module implementations have been provided for module " ++ markCode (runModuleName mn) ++ ": " , indent . paras $ map line paths ] renderSimpleErrorMessage InvalidDoBind = @@ -584,126 +591,78 @@ line "The same name was used more than once in a let binding." renderSimpleErrorMessage (InfiniteType ty) = paras [ line "An infinite type was inferred for an expression: " - , indent $ typeAsBox ty + , markCodeBox $ indent $ typeAsBox ty ] renderSimpleErrorMessage (InfiniteKind ki) = paras [ line "An infinite kind was inferred for a type: " - , indent $ line $ prettyPrintKind ki + , indent $ line $ markCode $ prettyPrintKind ki ] - renderSimpleErrorMessage (MultipleFixities name) = - line $ "There are multiple fixity/precedence declarations for " ++ showIdent name + renderSimpleErrorMessage (MultipleValueOpFixities op) = + line $ "There are multiple fixity/precedence declarations for operator " ++ markCode (showOp op) + renderSimpleErrorMessage (MultipleTypeOpFixities op) = + line $ "There are multiple fixity/precedence declarations for type operator " ++ markCode (showOp op) renderSimpleErrorMessage (OrphanTypeDeclaration nm) = - line $ "The type declaration for " ++ showIdent nm ++ " should be followed by its definition." - renderSimpleErrorMessage (OrphanFixityDeclaration op) = - line $ "The fixity/precedence declaration for " ++ show op ++ " should appear in the same module as its definition." + line $ "The type declaration for " ++ markCode (showIdent nm) ++ " should be followed by its definition." renderSimpleErrorMessage (RedefinedModule name filenames) = - paras [ line ("The module " ++ runModuleName name ++ " has been defined multiple times:") + paras [ line ("The module " ++ markCode (runModuleName name) ++ " has been defined multiple times:") , indent . paras $ map (line . displaySourceSpan) filenames ] renderSimpleErrorMessage (RedefinedIdent name) = - line $ "The value " ++ showIdent name ++ " has been defined multiple times" - renderSimpleErrorMessage (UnknownModule mn) = - line $ "Unknown module " ++ runModuleName mn - renderSimpleErrorMessage (UnknownType name) = - line $ "Unknown type " ++ showQualified runProperName name - renderSimpleErrorMessage (UnknownTypeOp name) = - line $ "Unknown type operator " ++ showQualified showIdent name - renderSimpleErrorMessage (UnknownTypeClass name) = - line $ "Unknown type class " ++ showQualified runProperName name - renderSimpleErrorMessage (UnknownValue name) = - line $ "Unknown value " ++ showQualified showIdent name - renderSimpleErrorMessage (UnknownTypeConstructor name) = - line $ "Unknown type constructor " ++ showQualified runProperName name - renderSimpleErrorMessage (UnknownDataConstructor dc tc) = - line $ "Unknown data constructor " ++ showQualified runProperName dc ++ foldMap ((" for type constructor " ++) . showQualified runProperName) tc - renderSimpleErrorMessage (UnknownImportType mn name) = - paras [ line $ "Cannot import type " ++ runProperName name ++ " from module " ++ runModuleName mn - , line "It either does not exist or the module does not export it." - ] - renderSimpleErrorMessage (UnknownExportType name) = - line $ "Cannot export unknown type " ++ runProperName name - renderSimpleErrorMessage (UnknownImportTypeOp mn name) = - paras [ line $ "Cannot import type operator " ++ showIdent name ++ " from module " ++ runModuleName mn - , line "It either does not exist or the module does not export it." - ] - renderSimpleErrorMessage (UnknownExportTypeOp name) = - line $ "Cannot export unknown type operator " ++ showIdent name - renderSimpleErrorMessage (UnknownImportTypeClass mn name) = - paras [ line $ "Cannot import type class " ++ runProperName name ++ " from module " ++ runModuleName mn - , line "It either does not exist or the module does not export it." - ] - renderSimpleErrorMessage (UnknownExportTypeClass name) = - line $ "Cannot export unknown type class " ++ runProperName name - renderSimpleErrorMessage (UnknownImportValue mn name) = - paras [ line $ "Cannot import value " ++ showIdent name ++ " from module " ++ runModuleName mn + line $ "The value " ++ markCode (showIdent name) ++ " has been defined multiple times" + renderSimpleErrorMessage (UnknownName name) = + line $ "Unknown " ++ printName name + renderSimpleErrorMessage (UnknownImport mn name) = + paras [ line $ "Cannot import " ++ printName (Qualified Nothing name) ++ " from module " ++ markCode (runModuleName mn) , line "It either does not exist or the module does not export it." ] - renderSimpleErrorMessage (UnknownExportValue name) = - line $ "Cannot export unknown value " ++ showIdent name - renderSimpleErrorMessage (UnknownExportModule name) = - paras [ line $ "Cannot export unknown module " ++ runModuleName name - , line "It either does not exist or has not been imported by the current module." - ] renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) = - line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon + line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ markCode (runProperName dcon) ++ " for type " ++ markCode (runProperName tcon) + renderSimpleErrorMessage (UnknownExport name) = + line $ "Cannot export unknown " ++ printName (Qualified Nothing name) renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) = - line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ ", as it has not been declared." + line $ "Cannot export data constructor " ++ markCode (runProperName dcon) ++ " for type " ++ markCode (runProperName tcon) ++ ", as it has not been declared." renderSimpleErrorMessage (ScopeConflict nm ms) = - paras [ line $ "Conflicting definitions are in scope for " ++ nm ++ " from the following modules:" - , indent $ paras $ map (line . runModuleName) ms + paras [ line $ "Conflicting definitions are in scope for " ++ printName (Qualified Nothing nm) ++ " from the following modules:" + , indent $ paras $ map (line . markCode . runModuleName) ms ] renderSimpleErrorMessage (ScopeShadowing nm exmn ms) = - paras [ line $ "Shadowed definitions are in scope for " ++ nm ++ " from the following open imports:" - , indent $ paras $ map (line . ("import " ++) . runModuleName) ms + paras [ line $ "Shadowed definitions are in scope for " ++ printName (Qualified Nothing nm) ++ " from the following open imports:" + , indent $ paras $ map (line . markCode . ("import " ++) . runModuleName) ms , line $ "These will be ignored and the " ++ case exmn of - Just exmn' -> "declaration from " ++ runModuleName exmn' ++ " will be used." + Just exmn' -> "declaration from " ++ markCode (runModuleName exmn') ++ " will be used." Nothing -> "local declaration will be used." ] - renderSimpleErrorMessage (ConflictingTypeDecls nm) = - line $ "Conflicting type declarations for " ++ runProperName nm - renderSimpleErrorMessage (ConflictingCtorDecls nm) = - line $ "Conflicting data constructor declarations for " ++ runProperName nm - renderSimpleErrorMessage (TypeConflictsWithClass nm) = - line $ "Type " ++ runProperName nm ++ " conflicts with a type class declaration with the same name." - renderSimpleErrorMessage (CtorConflictsWithClass nm) = - line $ "Data constructor " ++ runProperName nm ++ " conflicts with a type class declaration with the same name." - renderSimpleErrorMessage (ClassConflictsWithType nm) = - line $ "Type class " ++ runProperName nm ++ " conflicts with a type declaration with the same name." - renderSimpleErrorMessage (ClassConflictsWithCtor nm) = - line $ "Type class " ++ runProperName nm ++ " conflicts with a data constructor declaration with the same name." + renderSimpleErrorMessage (DeclConflict new existing) = + line $ "Declaration for " ++ printName (Qualified Nothing new) ++ " conflicts with an existing " ++ nameType existing ++ " of the same name." + renderSimpleErrorMessage (ExportConflict new existing) = + line $ "Export for " ++ printName new ++ " conflicts with " ++ runName existing renderSimpleErrorMessage (DuplicateModuleName mn) = - line $ "Module " ++ runModuleName mn ++ " has been defined multiple times." - renderSimpleErrorMessage (DuplicateClassExport nm) = - line $ "Duplicate export declaration for type class " ++ runProperName nm - renderSimpleErrorMessage (DuplicateValueExport nm) = - line $ "Duplicate export declaration for value " ++ showIdent nm - renderSimpleErrorMessage (DuplicateTypeOpExport nm) = - line $ "Duplicate export declaration for type operator " ++ showIdent nm + line $ "Module " ++ markCode (runModuleName mn) ++ " has been defined multiple times." renderSimpleErrorMessage (CycleInDeclaration nm) = - line $ "The value of " ++ showIdent nm ++ " is undefined here, so this reference is not allowed." + line $ "The value of " ++ markCode (showIdent nm) ++ " is undefined here, so this reference is not allowed." renderSimpleErrorMessage (CycleInModules mns) = paras [ line "There is a cycle in module dependencies in these modules: " - , indent $ paras (map (line . runModuleName) mns) + , indent $ paras (map (line . markCode . runModuleName) mns) ] renderSimpleErrorMessage (CycleInTypeSynonym name) = paras [ line $ case name of - Just pn -> "A cycle appears in the definition of type synonym " ++ runProperName pn + Just pn -> "A cycle appears in the definition of type synonym " ++ markCode (runProperName pn) Nothing -> "A cycle appears in a set of type synonym definitions." , line "Cycles are disallowed because they can lead to loops in the type checker." , line "Consider using a 'newtype' instead." ] renderSimpleErrorMessage (NameIsUndefined ident) = - line $ "Value " ++ showIdent ident ++ " is undefined." + line $ "Value " ++ markCode (showIdent ident) ++ " is undefined." renderSimpleErrorMessage (UndefinedTypeVariable name) = - line $ "Type variable " ++ runProperName name ++ " is undefined." + line $ "Type variable " ++ markCode (runProperName name) ++ " is undefined." renderSimpleErrorMessage (PartiallyAppliedSynonym name) = - paras [ line $ "Type synonym " ++ showQualified runProperName name ++ " is partially applied." + paras [ line $ "Type synonym " ++ markCode (showQualified runProperName name) ++ " is partially applied." , line "Type synonyms must be applied to all of their type arguments." ] renderSimpleErrorMessage (EscapedSkolem binding) = paras $ [ line "A type variable has escaped its scope." ] <> foldMap (\expr -> [ line "Relevant expression: " - , indent $ prettyPrintValue valueDepth expr + , markCodeBox $ indent $ prettyPrintValue valueDepth expr ]) binding renderSimpleErrorMessage (TypesDoNotUnify u1 u2) = let (sorted1, sorted2) = sortRows u1 u2 @@ -725,39 +684,56 @@ , rowFromList (sortBy (comparing fst) sd2 ++ map (fst &&& snd . snd) common, r2) ) in paras [ line "Could not match type" - , indent $ typeAsBox sorted1 + , markCodeBox $ indent $ typeAsBox sorted1 , line "with type" - , indent $ typeAsBox sorted2 + , markCodeBox $ indent $ typeAsBox sorted2 ] renderSimpleErrorMessage (KindsDoNotUnify k1 k2) = paras [ line "Could not match kind" - , indent $ line $ prettyPrintKind k1 + , indent $ line $ markCode $ prettyPrintKind k1 , line "with kind" - , indent $ line $ prettyPrintKind k2 + , indent $ line $ markCode $ prettyPrintKind k2 ] renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) = paras [ line "Could not match constrained type" - , indent $ typeAsBox t1 + , markCodeBox $ indent $ typeAsBox t1 , line "with type" - , indent $ typeAsBox t2 + , markCodeBox $ indent $ typeAsBox t2 ] renderSimpleErrorMessage (OverlappingInstances nm ts (d : ds)) = paras [ line "Overlapping type class instances found for" - , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) - , Box.vcat Box.left (map typeAtomAsBox ts) - ] + , markCodeBox $ indent $ Box.hsep 1 Box.left + [ line (showQualified runProperName nm) + , Box.vcat Box.left (map typeAtomAsBox ts) + ] , line "The following instances were found:" , indent $ paras (line (showQualified showIdent d ++ " (chosen)") : map (line . showQualified showIdent) ds) , line "Overlapping type class instances can lead to different behavior based on the order of module imports, and for that reason are not recommended." , line "They may be disallowed completely in a future version of the compiler." ] renderSimpleErrorMessage OverlappingInstances{} = internalError "OverlappingInstances: empty instance list" - renderSimpleErrorMessage (NoInstanceFound nm ts) = + renderSimpleErrorMessage (NoInstanceFound (Constraint C.Fail [ TypeLevelString message ] _)) = + paras [ line "A custom type error occurred while solving type class constraints:" + , indent . paras . map line . lines $ message + ] + renderSimpleErrorMessage (NoInstanceFound (Constraint C.Partial + _ + (Just (PartialConstraintData bs b)))) = + paras [ line "A case expression could not be determined to cover all inputs." + , line "The following additional cases are required to cover all inputs:\n" + , indent $ paras $ + Box.hsep 1 Box.left + (map (paras . map (line . markCode)) (transpose bs)) + : [line "..." | not b] + , line "Alternatively, add a Partial constraint to the type of the enclosing value." + ] + renderSimpleErrorMessage (NoInstanceFound (Constraint nm ts _)) = paras [ line "No type class instance was found for" - , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) - , Box.vcat Box.left (map typeAtomAsBox ts) - ] + , markCodeBox $ indent $ Box.hsep 1 Box.left + [ line (showQualified runProperName nm) + , Box.vcat Box.left (map typeAtomAsBox ts) + ] , paras [ line "The instance head contains unknown type variables. Consider adding a type annotation." | any containsUnknowns ts ] @@ -770,130 +746,128 @@ go _ = False renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) = paras [ line "Type class instance for" - , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) - , Box.vcat Box.left (map typeAtomAsBox ts) - ] + , markCodeBox $ indent $ Box.hsep 1 Box.left + [ line (showQualified runProperName nm) + , Box.vcat Box.left (map typeAtomAsBox ts) + ] , line "is possibly infinite." ] renderSimpleErrorMessage (CannotDerive nm ts) = paras [ line "Cannot derive a type class instance for" - , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) - , Box.vcat Box.left (map typeAtomAsBox ts) - ] + , markCodeBox $ indent $ Box.hsep 1 Box.left + [ line (showQualified runProperName nm) + , Box.vcat Box.left (map typeAtomAsBox ts) + ] ] renderSimpleErrorMessage (CannotFindDerivingType nm) = - line $ "Cannot derive a type class instance, because the type declaration for " ++ runProperName nm ++ " could not be found." + line $ "Cannot derive a type class instance, because the type declaration for " ++ markCode (runProperName nm) ++ " could not be found." renderSimpleErrorMessage (DuplicateLabel l expr) = - paras $ [ line $ "Label " ++ show l ++ " appears more than once in a row type." ] + paras $ [ line $ "Label " ++ markCode l ++ " appears more than once in a row type." ] <> foldMap (\expr' -> [ line "Relevant expression: " - , indent $ prettyPrintValue valueDepth expr' + , markCodeBox $ indent $ prettyPrintValue valueDepth expr' ]) expr renderSimpleErrorMessage (DuplicateTypeArgument name) = - line $ "Type argument " ++ show name ++ " appears more than once." + line $ "Type argument " ++ markCode name ++ " appears more than once." renderSimpleErrorMessage (DuplicateValueDeclaration nm) = - line $ "Multiple value declarations exist for " ++ showIdent nm ++ "." + line $ "Multiple value declarations exist for " ++ markCode (showIdent nm) ++ "." renderSimpleErrorMessage (ArgListLengthsDiffer ident) = - line $ "Argument list lengths differ in declaration " ++ showIdent ident + line $ "Argument list lengths differ in declaration " ++ markCode (showIdent ident) renderSimpleErrorMessage (OverlappingArgNames ident) = line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration " ++) . showIdent) ident renderSimpleErrorMessage (MissingClassMember ident) = - line $ "Type class member " ++ showIdent ident ++ " has not been implemented." + line $ "Type class member " ++ markCode (showIdent ident) ++ " has not been implemented." renderSimpleErrorMessage (ExtraneousClassMember ident className) = - line $ showIdent ident ++ " is not a member of type class " ++ showQualified runProperName className + line $ "" ++ markCode (showIdent ident) ++ " is not a member of type class " ++ markCode (showQualified runProperName className) renderSimpleErrorMessage (ExpectedType ty kind) = - paras [ line "In a type-annotated expression x :: t, the type t must have kind *." + paras [ line $ "In a type-annotated expression " ++ markCode "x :: t" ++ ", the type " ++ markCode "t" ++ " must have kind " ++ markCode "*" ++ "." , line "The error arises from the type" - , indent $ typeAsBox ty + , markCodeBox $ indent $ typeAsBox ty , line "having the kind" - , indent $ line $ prettyPrintKind kind + , indent $ line $ markCode $ prettyPrintKind kind , line "instead." ] renderSimpleErrorMessage (IncorrectConstructorArity nm) = - line $ "Data constructor " ++ showQualified runProperName nm ++ " was given the wrong number of arguments in a case expression." + line $ "Data constructor " ++ markCode (showQualified runProperName nm) ++ " was given the wrong number of arguments in a case expression." renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) = paras [ line "Expression" - , indent $ prettyPrintValue valueDepth expr + , markCodeBox $ indent $ prettyPrintValue valueDepth expr , line "does not have type" - , indent $ typeAsBox ty + , markCodeBox $ indent $ typeAsBox ty ] renderSimpleErrorMessage (PropertyIsMissing prop) = - line $ "Type of expression lacks required label " ++ show prop ++ "." + line $ "Type of expression lacks required label " ++ markCode prop ++ "." renderSimpleErrorMessage (AdditionalProperty prop) = - line $ "Type of expression contains additional label " ++ show prop ++ "." + line $ "Type of expression contains additional label " ++ markCode prop ++ "." renderSimpleErrorMessage (CannotApplyFunction fn arg) = paras [ line "A function of type" - , indent $ typeAsBox fn + , markCodeBox $ indent $ typeAsBox fn , line "can not be applied to the argument" - , indent $ prettyPrintValue valueDepth arg + , markCodeBox $ indent $ prettyPrintValue valueDepth arg ] renderSimpleErrorMessage TypeSynonymInstance = line "Type class instances for type synonyms are disallowed." renderSimpleErrorMessage (OrphanInstance nm cnm ts) = - paras [ line $ "Type class instance " ++ showIdent nm ++ " for " - , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cnm) - , Box.vcat Box.left (map typeAtomAsBox ts) - ] + paras [ line $ "Type class instance " ++ markCode (showIdent nm) ++ " for " + , markCodeBox $ indent $ Box.hsep 1 Box.left + [ line (showQualified runProperName cnm) + , Box.vcat Box.left (map typeAtomAsBox ts) + ] , line "is an orphan instance." , line "An orphan instance is an instance which is defined in neither the class module nor the data type module." , line "Consider moving the instance, if possible, or using a newtype wrapper." ] renderSimpleErrorMessage (InvalidNewtype name) = - paras [ line $ "Newtype " ++ runProperName name ++ " is invalid." + paras [ line $ "Newtype " ++ markCode (runProperName name) ++ " is invalid." , line "Newtypes must define a single constructor with a single argument." ] renderSimpleErrorMessage (InvalidInstanceHead ty) = paras [ line "Type class instance head is invalid due to use of type" - , indent $ typeAsBox ty + , markCodeBox $ indent $ typeAsBox ty , line "All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form." ] renderSimpleErrorMessage (TransitiveExportError x ys) = - paras [ line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: " - , indent $ paras $ map (line . prettyPrintExport) ys + paras [ line $ "An export for " ++ markCode (prettyPrintExport x) ++ " requires the following to also be exported: " + , indent $ paras $ map (line . markCode . prettyPrintExport) ys ] renderSimpleErrorMessage (TransitiveDctorExportError x ctor) = - paras [ line $ "An export for " ++ prettyPrintExport x ++ " requires the following data constructor to also be exported: " - , indent $ line $ runProperName ctor + paras [ line $ "An export for " ++ markCode (prettyPrintExport x) ++ " requires the following data constructor to also be exported: " + , indent $ line $ markCode $ runProperName ctor ] renderSimpleErrorMessage (ShadowedName nm) = - line $ "Name '" ++ showIdent nm ++ "' was shadowed." + line $ "Name " ++ markCode (showIdent nm) ++ " was shadowed." renderSimpleErrorMessage (ShadowedTypeVar tv) = - line $ "Type variable '" ++ tv ++ "' was shadowed." + line $ "Type variable " ++ markCode tv ++ " was shadowed." renderSimpleErrorMessage (UnusedTypeVar tv) = - line $ "Type variable '" ++ tv ++ "' was declared but not used." - renderSimpleErrorMessage (ClassOperator className opName) = - paras [ line $ "Type class '" ++ runProperName className ++ "' declares operator " ++ showIdent opName ++ "." - , line "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:" - , indent . line $ showIdent opName ++ " = someMember" - ] + line $ "Type variable " ++ markCode tv ++ " was declared but not used." renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) = - line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors." + line $ "Importing type " ++ markCode (runProperName name ++ "(..)") ++ " from " ++ markCode (runModuleName mn) ++ " is misleading as it has no exported data constructors." renderSimpleErrorMessage (ImportHidingModule name) = - paras [ line "'hiding' imports cannot be used to hide modules." - , line $ "An attempt was made to hide the import of " ++ runModuleName name + paras [ line "hiding imports cannot be used to hide modules." + , line $ "An attempt was made to hide the import of " ++ markCode (runModuleName name) ] renderSimpleErrorMessage (WildcardInferredType ty) = paras [ line "Wildcard type definition has the inferred type " - , indent $ typeAsBox ty - ] - renderSimpleErrorMessage (HoleInferredType name ty) = - paras [ line $ "Hole '" ++ name ++ "' has the inferred type " - , indent $ typeAsBox ty + , markCodeBox $ indent $ typeAsBox ty ] + renderSimpleErrorMessage (HoleInferredType name ty env) = + paras $ [ line $ "Hole '" ++ markCode name ++ "' has the inferred type " + , markCodeBox $ indent $ typeAsBox ty + ] ++ if null env then [] else envInfo + where + envInfo :: [Box.Box] + envInfo = [ line "in the following context:" + , indent $ paras + [ Box.hcat Box.left [ Box.text (showIdent ident <> " :: ") + , markCodeBox $ typeAsBox ty' + ] + | (ident, ty') <- take 5 env + ] + ] renderSimpleErrorMessage (MissingTypeDeclaration ident ty) = - paras [ line $ "No type declaration was provided for the top-level declaration of " ++ showIdent ident ++ "." + paras [ line $ "No type declaration was provided for the top-level declaration of " ++ markCode (showIdent ident) ++ "." , line "It is good practice to provide type declarations as a form of documentation." - , line $ "The inferred type of " ++ showIdent ident ++ " was:" - , indent $ typeAsBox ty - ] - renderSimpleErrorMessage (NotExhaustivePattern bs b) = - paras [ line "A case expression could not be determined to cover all inputs." - , line "The following additional cases are required to cover all inputs:\n" - , indent $ paras $ - Box.hsep 1 Box.left - (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) - : [line "..." | not b] - , line "Or alternatively, add a Partial constraint to the type of the enclosing value." - , line "Non-exhaustive patterns for values without a `Partial` constraint will be disallowed in PureScript 0.9." + , line $ "The inferred type of " ++ markCode (showIdent ident) ++ " was:" + , markCodeBox $ indent $ typeAsBox ty ] renderSimpleErrorMessage (OverlappingPattern bs b) = paras $ [ line "A case expression contains unreachable cases:\n" @@ -905,109 +879,51 @@ , line "You may want to decompose your data types into smaller types." ] renderSimpleErrorMessage (UnusedImport name) = - line $ "The import of module " ++ runModuleName name ++ " is redundant" + line $ "The import of module " ++ markCode (runModuleName name) ++ " is redundant" renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) = - paras [ line $ "The import of module " ++ runModuleName mn ++ " contains the following unused references:" + paras [ line $ "The import of module " ++ markCode (runModuleName mn) ++ " contains the following unused references:" , indent $ paras $ map line names , line "It could be replaced with:" - , indent $ line $ showSuggestion msg ] + , indent $ line $ markCode $ showSuggestion msg ] renderSimpleErrorMessage (UnusedDctorImport name) = - line $ "The import of type " ++ runProperName name ++ " includes data constructors but only the type is used" + line $ "The import of type " ++ markCode (runProperName name) ++ " includes data constructors but only the type is used" renderSimpleErrorMessage (UnusedDctorExplicitImport name names) = - paras [ line $ "The import of type " ++ runProperName name ++ " includes the following unused data constructors:" - , indent $ paras $ map (line .runProperName) names ] - - renderSimpleErrorMessage (DeprecatedOperatorDecl name) = - paras [ line $ "The operator (" ++ name ++ ") was declared as a value rather than an alias for a named function." - , line "Operator aliases are declared by using a fixity declaration, for example:" - , indent $ line $ "infixl 9 someFunction as " ++ name - , line "Support for value-declared operators will be removed in PureScript 0.9." - ] - - renderSimpleErrorMessage (DeprecatedOperatorSection op val) = - paras [ line "An operator section uses legacy syntax. Operator sections are now written using anonymous function syntax:" - , indent $ foldr1 before $ - case val of - Left l -> - [ line "(" - , prettyPrintValue valueDepth l - , line " " - , renderOperator op - , line " _)" - ] - Right r -> - [ line "(_ " - , renderOperator op - , line " " - , prettyPrintValue valueDepth r - , line ")" - ] - , line "Support for legacy operator sections will be removed in PureScript 0.9." - ] - where - renderOperator (PositionedValue _ _ ex) = renderOperator ex - renderOperator (Var (Qualified _ (Op ident))) = line ident - renderOperator other = Box.hcat Box.top [ line "`", prettyPrintValue valueDepth other, line "`" ] - renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) = - paras [ line "Import uses the deprecated 'qualified' syntax:" - , indent $ line $ "import qualified " ++ runModuleName name ++ " as " ++ runModuleName qualName - , line "Should instead use the form:" - , indent $ line $ "import " ++ runModuleName name ++ " as " ++ runModuleName qualName - , line "The deprecated syntax will be removed in PureScript 0.9." - ] - - renderSimpleErrorMessage (DeprecatedClassImport mn name) = - paras [ line $ "Class import from " ++ runModuleName mn ++ " uses deprecated syntax that omits the 'class' keyword:" - , indent $ line $ runProperName name - , line "Should instead use the form:" - , indent $ line $ "class " ++ runProperName name - , line "The deprecated syntax will be removed in PureScript 0.9." - ] - - renderSimpleErrorMessage (DeprecatedClassExport name) = - paras [ line "Class export uses deprecated syntax that omits the 'class' keyword:" - , indent $ line $ runProperName name - , line "Should instead use the form:" - , indent $ line $ "class " ++ runProperName name - , line "The deprecated syntax will be removed in PureScript 0.9." - ] + paras [ line $ "The import of type " ++ markCode (runProperName name) ++ " includes the following unused data constructors:" + , indent $ paras $ map (line . markCode . runProperName) names ] renderSimpleErrorMessage (DuplicateSelectiveImport name) = - line $ "There is an existing import of " ++ runModuleName name ++ ", consider merging the import lists" + line $ "There is an existing import of " ++ markCode (runModuleName name) ++ ", consider merging the import lists" renderSimpleErrorMessage (DuplicateImport name imp qual) = - line $ "Duplicate import of " ++ prettyPrintImport name imp qual + line $ "Duplicate import of " ++ markCode (prettyPrintImport name imp qual) - renderSimpleErrorMessage (DuplicateImportRef ref) = - line $ "Import list contains multiple references to " ++ ref + renderSimpleErrorMessage (DuplicateImportRef name) = + line $ "Import list contains multiple references to " ++ printName (Qualified Nothing name) - renderSimpleErrorMessage (DuplicateExportRef ref) = - line $ "Export list contains multiple references to " ++ ref + renderSimpleErrorMessage (DuplicateExportRef name) = + line $ "Export list contains multiple references to " ++ printName (Qualified Nothing name) renderSimpleErrorMessage (IntOutOfRange value backend lo hi) = - paras [ line $ "Integer value " ++ show value ++ " is out of range for the " ++ backend ++ " backend." - , line $ "Acceptable values fall within the range " ++ show lo ++ " to " ++ show hi ++ " (inclusive)." ] - - renderSimpleErrorMessage (RedundantEmptyHidingImport mn) = - line $ "The import for module " ++ runModuleName mn ++ " is redundant as all members have been explicitly hidden." + paras [ line $ "Integer value " ++ markCode (show value) ++ " is out of range for the " ++ backend ++ " backend." + , line $ "Acceptable values fall within the range " ++ markCode (show lo) ++ " to " ++ markCode (show hi) ++ " (inclusive)." ] renderSimpleErrorMessage msg@(ImplicitQualifiedImport importedModule asModule _) = - paras [ line $ "Module " ++ runModuleName importedModule ++ " was imported as " ++ runModuleName asModule ++ " with unspecified imports." - , line $ "As there are multiple modules being imported as " ++ runModuleName asModule ++ ", consider using the explicit form:" - , indent $ line $ showSuggestion msg + paras [ line $ "Module " ++ markCode (runModuleName importedModule) ++ " was imported as " ++ markCode (runModuleName asModule) ++ " with unspecified imports." + , line $ "As there are multiple modules being imported as " ++ markCode (runModuleName asModule) ++ ", consider using the explicit form:" + , indent $ line $ markCode $ showSuggestion msg ] renderSimpleErrorMessage msg@(ImplicitImport mn _) = - paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the explicit form: " - , indent $ line $ showSuggestion msg + paras [ line $ "Module " ++ markCode (runModuleName mn) ++ " has unspecified imports, consider using the explicit form: " + , indent $ line $ markCode $ showSuggestion msg ] renderSimpleErrorMessage msg@(HidingImport mn _) = - paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the inclusive form: " - , indent $ line $ showSuggestion msg + paras [ line $ "Module " ++ markCode (runModuleName mn) ++ " has unspecified imports, consider using the inclusive form: " + , indent $ line $ markCode $ showSuggestion msg ] renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) = @@ -1020,7 +936,7 @@ line "An anonymous function argument appears in an invalid context." renderSimpleErrorMessage (InvalidOperatorInBinder op fn) = - paras [ line $ "Operator " ++ showIdent op ++ " cannot be used in a pattern as it is an alias for function " ++ showIdent fn ++ "." + paras [ line $ "Operator " ++ markCode (showQualified showOp op) ++ " cannot be used in a pattern as it is an alias for function " ++ showQualified showIdent fn ++ "." , line "Only aliases for data constructors may be used in patterns." ] @@ -1028,9 +944,9 @@ line "The require-path option is deprecated and will be removed in PureScript 0.9." renderSimpleErrorMessage (CannotGeneralizeRecursiveFunction ident ty) = - paras [ line $ "Unable to generalize the type of the recursive function " ++ showIdent ident ++ "." - , line $ "The inferred type of " ++ showIdent ident ++ " was:" - , indent $ typeAsBox ty + paras [ line $ "Unable to generalize the type of the recursive function " ++ markCode (showIdent ident) ++ "." + , line $ "The inferred type of " ++ markCode (showIdent ident) ++ " was:" + , markCodeBox $ indent $ typeAsBox ty , line "Try adding a type signature." ] @@ -1038,42 +954,43 @@ renderHint (ErrorUnifyingTypes t1 t2) detail = paras [ detail , Box.hsep 1 Box.top [ line "while trying to match type" - , typeAsBox t1 + , markCodeBox $ typeAsBox t1 ] , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "with type" - , typeAsBox t2 + , markCodeBox $ typeAsBox t2 ] ] renderHint (ErrorInExpression expr) detail = paras [ detail , Box.hsep 1 Box.top [ Box.text "in the expression" - , prettyPrintValue valueDepth expr + , markCodeBox $ markCodeBox $ prettyPrintValue valueDepth expr ] ] renderHint (ErrorInModule mn) detail = - paras [ line $ "in module " ++ runModuleName mn + paras [ line $ "in module " ++ markCode (runModuleName mn) , detail ] renderHint (ErrorInSubsumption t1 t2) detail = paras [ detail , Box.hsep 1 Box.top [ line "while checking that type" - , typeAsBox t1 + , markCodeBox $ typeAsBox t1 ] , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "is at least as general as type" - , typeAsBox t2 + , markCodeBox $ typeAsBox t2 ] ] renderHint (ErrorInInstance nm ts) detail = paras [ detail - , Box.hsep 1 Box.top [ line "in type class instance" - , line (showQualified runProperName nm) - , Box.vcat Box.left (map typeAtomAsBox ts) - ] + , line "in type class instance" + , markCodeBox $ indent $ Box.hsep 1 Box.top + [ line $ showQualified runProperName nm + , Box.vcat Box.left (map typeAtomAsBox ts) + ] ] renderHint (ErrorCheckingKind ty) detail = paras [ detail , Box.hsep 1 Box.top [ line "while checking the kind of" - , typeAsBox ty + , markCodeBox $ typeAsBox ty ] ] renderHint ErrorCheckingGuard detail = @@ -1083,43 +1000,43 @@ renderHint (ErrorInferringType expr) detail = paras [ detail , Box.hsep 1 Box.top [ line "while inferring the type of" - , prettyPrintValue valueDepth expr + , markCodeBox $ prettyPrintValue valueDepth expr ] ] renderHint (ErrorCheckingType expr ty) detail = paras [ detail , Box.hsep 1 Box.top [ line "while checking that expression" - , prettyPrintValue valueDepth expr + , markCodeBox $ prettyPrintValue valueDepth expr ] , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "has type" - , typeAsBox ty + , markCodeBox $ typeAsBox ty ] ] renderHint (ErrorCheckingAccessor expr prop) detail = paras [ detail , Box.hsep 1 Box.top [ line "while checking type of property accessor" - , prettyPrintValue valueDepth (Accessor prop expr) + , markCodeBox $ prettyPrintValue valueDepth (Accessor prop expr) ] ] renderHint (ErrorInApplication f t a) detail = paras [ detail , Box.hsep 1 Box.top [ line "while applying a function" - , prettyPrintValue valueDepth f + , markCodeBox $ prettyPrintValue valueDepth f ] , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "of type" - , typeAsBox t + , markCodeBox $ typeAsBox t ] , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "to argument" - , prettyPrintValue valueDepth a + , markCodeBox $ prettyPrintValue valueDepth a ] ] renderHint (ErrorInDataConstructor nm) detail = paras [ detail - , line $ "in data constructor " ++ runProperName nm + , line $ "in data constructor " ++ markCode (runProperName nm) ] renderHint (ErrorInTypeConstructor nm) detail = paras [ detail - , line $ "in type constructor " ++ runProperName nm + , line $ "in type constructor " ++ markCode (runProperName nm) ] renderHint (ErrorInBindingGroup nms) detail = paras [ detail @@ -1131,25 +1048,55 @@ ] renderHint (ErrorInTypeSynonym name) detail = paras [ detail - , line $ "in type synonym " ++ runProperName name + , line $ "in type synonym " ++ markCode (runProperName name) ] renderHint (ErrorInValueDeclaration n) detail = paras [ detail - , line $ "in value declaration " ++ showIdent n + , line $ "in value declaration " ++ markCode (showIdent n) ] renderHint (ErrorInTypeDeclaration n) detail = paras [ detail - , line $ "in type declaration for " ++ showIdent n + , line $ "in type declaration for " ++ markCode (showIdent n) ] renderHint (ErrorInForeignImport nm) detail = paras [ detail - , line $ "in foreign import " ++ showIdent nm + , line $ "in foreign import " ++ markCode (showIdent nm) ] renderHint (PositionedError srcSpan) detail = paras [ line $ "at " ++ displaySourceSpan srcSpan , detail ] + printName :: Qualified Name -> String + printName qn = nameType (disqualify qn) ++ " " ++ markCode (runName qn) + + nameType :: Name -> String + nameType (IdentName _) = "value" + nameType (ValOpName _) = "operator" + nameType (TyName _) = "type" + nameType (TyOpName _) = "type operator" + nameType (DctorName _) = "data constructor" + nameType (TyClassName _) = "type class" + nameType (ModName _) = "module" + + runName :: Qualified Name -> String + runName (Qualified mn (IdentName name)) = + showQualified showIdent (Qualified mn name) + runName (Qualified mn (ValOpName op)) = + showQualified showOp (Qualified mn op) + runName (Qualified mn (TyName name)) = + showQualified runProperName (Qualified mn name) + runName (Qualified mn (TyOpName op)) = + showQualified showOp (Qualified mn op) + runName (Qualified mn (DctorName name)) = + showQualified runProperName (Qualified mn name) + runName (Qualified mn (TyClassName name)) = + showQualified runProperName (Qualified mn name) + runName (Qualified Nothing (ModName name)) = + runModuleName name + runName (Qualified _ ModName{}) = + internalError "qualified ModName in runName" + valueDepth :: Int valueDepth | full = 1000 | otherwise = 3 @@ -1230,10 +1177,10 @@ prettyPrintRef (TypeRef pn Nothing) = runProperName pn ++ "(..)" prettyPrintRef (TypeRef pn (Just [])) = runProperName pn prettyPrintRef (TypeRef pn (Just dctors)) = runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")" -prettyPrintRef (TypeOpRef ident) = "type " ++ showIdent ident +prettyPrintRef (TypeOpRef op) = "type " ++ showOp op prettyPrintRef (ValueRef ident) = showIdent ident +prettyPrintRef (ValueOpRef op) = showOp op prettyPrintRef (TypeClassRef pn) = "class " ++ runProperName pn -prettyPrintRef (ProperRef name) = name prettyPrintRef (TypeInstanceRef ident) = showIdent ident prettyPrintRef (ModuleRef name) = "module " ++ runModuleName name prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref @@ -1241,32 +1188,32 @@ -- | -- Pretty print multiple errors -- -prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String -prettyPrintMultipleErrors full = unlines . map renderBox . prettyPrintMultipleErrorsBox full +prettyPrintMultipleErrors :: PPEOptions -> MultipleErrors -> String +prettyPrintMultipleErrors ppeOptions = unlines . map renderBox . prettyPrintMultipleErrorsBox ppeOptions -- | -- Pretty print multiple warnings -- -prettyPrintMultipleWarnings :: Bool -> MultipleErrors -> String -prettyPrintMultipleWarnings full = unlines . map renderBox . prettyPrintMultipleWarningsBox full +prettyPrintMultipleWarnings :: PPEOptions -> MultipleErrors -> String +prettyPrintMultipleWarnings ppeOptions = unlines . map renderBox . prettyPrintMultipleWarningsBox ppeOptions -- | Pretty print warnings as a Box -prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> [Box.Box] -prettyPrintMultipleWarningsBox = prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" +prettyPrintMultipleWarningsBox :: PPEOptions -> MultipleErrors -> [Box.Box] +prettyPrintMultipleWarningsBox ppeOptions = prettyPrintMultipleErrorsWith (ppeOptions { ppeLevel = Warning }) "Warning found:" "Warning" -- | Pretty print errors as a Box -prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> [Box.Box] -prettyPrintMultipleErrorsBox = prettyPrintMultipleErrorsWith Error "Error found:" "Error" +prettyPrintMultipleErrorsBox :: PPEOptions -> MultipleErrors -> [Box.Box] +prettyPrintMultipleErrorsBox ppeOptions = prettyPrintMultipleErrorsWith (ppeOptions { ppeLevel = Error }) "Error found:" "Error" -prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> [Box.Box] -prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = - let result = prettyPrintSingleError full level True e +prettyPrintMultipleErrorsWith :: PPEOptions -> String -> String -> MultipleErrors -> [Box.Box] +prettyPrintMultipleErrorsWith ppeOptions intro _ (MultipleErrors [e]) = + let result = prettyPrintSingleError ppeOptions e in [ Box.vcat Box.left [ Box.text intro , result ] ] -prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = - let result = map (prettyPrintSingleError full level True) es +prettyPrintMultipleErrorsWith ppeOptions _ intro (MultipleErrors es) = + let result = map (prettyPrintSingleError ppeOptions) es in concat $ zipWith withIntro [1 :: Int ..] result where withIntro i err = [ Box.text (intro ++ " " ++ show i ++ " of " ++ show (length es) ++ ":") diff --git a/src/Language/PureScript/Errors/JSON.hs b/src/Language/PureScript/Errors/JSON.hs --- a/src/Language/PureScript/Errors/JSON.hs +++ b/src/Language/PureScript/Errors/JSON.hs @@ -1,22 +1,7 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Errors.JSON --- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - {-# LANGUAGE TemplateHaskell #-} module Language.PureScript.Errors.JSON where -import Prelude () import Prelude.Compat import qualified Data.Aeson.TH as A @@ -30,7 +15,10 @@ , endColumn :: Int } deriving (Show, Eq, Ord) -data ErrorSuggestion = ErrorSuggestion { replacement :: String } deriving (Show, Eq) +data ErrorSuggestion = ErrorSuggestion + { replacement :: String + , replaceRange :: Maybe ErrorPosition + } deriving (Show, Eq) data JSONError = JSONError { position :: Maybe ErrorPosition @@ -40,7 +28,7 @@ , filename :: Maybe String , moduleName :: Maybe String , suggestion :: Maybe ErrorSuggestion - } deriving (Show, Eq) + } deriving (Show, Eq) data JSONResult = JSONResult { warnings :: [JSONError] @@ -59,12 +47,12 @@ toJSONError :: Bool -> P.Level -> P.ErrorMessage -> JSONError toJSONError verbose level e = JSONError (toErrorPosition <$> sspan) - (P.renderBox (P.prettyPrintSingleError verbose level False (P.stripModuleAndSpan e))) + (P.renderBox (P.prettyPrintSingleError (P.PPEOptions Nothing verbose level False) (P.stripModuleAndSpan e))) (P.errorCode e) (P.wikiUri e) (P.spanName <$> sspan) (P.runModuleName <$> P.errorModule e) - (toSuggestion <$> P.errorSuggestion (P.unwrapErrorMessage e)) + (toSuggestion e) where sspan :: Maybe P.SourceSpan sspan = P.errorSpan e @@ -75,6 +63,11 @@ (P.sourcePosColumn (P.spanStart ss)) (P.sourcePosLine (P.spanEnd ss)) (P.sourcePosColumn (P.spanEnd ss)) - toSuggestion :: P.ErrorSuggestion -> ErrorSuggestion --- TODO: Adding a newline because source spans chomp everything up to the next character - toSuggestion (P.ErrorSuggestion s) = ErrorSuggestion $ if null s then s else s ++ "\n" + toSuggestion :: P.ErrorMessage -> Maybe ErrorSuggestion + toSuggestion em = + case P.errorSuggestion $ P.unwrapErrorMessage em of + Nothing -> Nothing + Just s -> Just $ ErrorSuggestion (suggestionText s) (toErrorPosition <$> P.suggestionSpan em) + + -- TODO: Adding a newline because source spans chomp everything up to the next character + suggestionText (P.ErrorSuggestion s) = if null s then s else s ++ "\n" diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -1,37 +1,35 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE PatternGuards #-} {-# LANGUAGE TemplateHaskell #-} -- | --- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations. +-- This module generates code for \"externs\" files, i.e. files containing only +-- foreign import declarations. -- module Language.PureScript.Externs ( ExternsFile(..) , ExternsImport(..) , ExternsFixity(..) + , ExternsTypeFixity(..) , ExternsDeclaration(..) , moduleToExternsFile , applyExternsFileToEnvironment ) where -import Prelude () import Prelude.Compat +import Data.Aeson.TH +import Data.Foldable (fold) import Data.List (find, foldl') import Data.Maybe (mapMaybe, maybeToList, fromMaybe) -import Data.Foldable (fold) import Data.Version (showVersion) -import Data.Aeson.TH - import qualified Data.Map as M -import Language.PureScript.Crash import Language.PureScript.AST +import Language.PureScript.Crash import Language.PureScript.Environment -import Language.PureScript.Names -import Language.PureScript.Types import Language.PureScript.Kinds +import Language.PureScript.Names import Language.PureScript.TypeClassDictionaries +import Language.PureScript.Types import Paths_purescript as Paths @@ -48,6 +46,8 @@ , efImports :: [ExternsImport] -- | List of operators and their fixities , efFixities :: [ExternsFixity] + -- | List of type operators and their fixities + , efTypeFixities :: [ExternsTypeFixity] -- | List of type and value declaration , efDeclarations :: [ExternsDeclaration] } deriving (Show, Read) @@ -71,11 +71,24 @@ -- | The precedence level of the operator , efPrecedence :: Precedence -- | The operator symbol - , efOperator :: String + , efOperator :: OpName 'ValueOpName -- | The value the operator is an alias for - , efAlias :: Maybe (Qualified FixityAlias) + , efAlias :: Qualified (Either Ident (ProperName 'ConstructorName)) } deriving (Show, Read) +-- | A type fixity declaration in an externs file +data ExternsTypeFixity = ExternsTypeFixity + { + -- | The associativity of the operator + efTypeAssociativity :: Associativity + -- | The precedence level of the operator + , efTypePrecedence :: Precedence + -- | The operator symbol + , efTypeOperator :: OpName 'TypeOpName + -- | The value the operator is an alias for + , efTypeAlias :: Qualified (ProperName 'TypeName) + } deriving (Show, Read) + -- | A type or value declaration appearing in an externs file data ExternsDeclaration = -- | A type declaration @@ -150,22 +163,26 @@ efExports = exps efImports = mapMaybe importDecl ds efFixities = mapMaybe fixityDecl ds + efTypeFixities = mapMaybe typeFixityDecl ds efDeclarations = concatMap toExternsDeclaration efExports fixityDecl :: Declaration -> Maybe ExternsFixity - fixityDecl (FixityDeclaration (Fixity assoc prec) op alias) = - fmap (const (ExternsFixity assoc prec op alias)) (find exportsOp exps) - where - exportsOp :: DeclarationRef -> Bool - exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r - exportsOp (ValueRef ident') = ident' == Op op - exportsOp (TypeOpRef ident') = ident' == Op op - exportsOp _ = False + fixityDecl (ValueFixityDeclaration (Fixity assoc prec) name op) = + fmap (const (ExternsFixity assoc prec op name)) (find (findOp getValueOpRef op) exps) fixityDecl (PositionedDeclaration _ _ d) = fixityDecl d fixityDecl _ = Nothing + typeFixityDecl :: Declaration -> Maybe ExternsTypeFixity + typeFixityDecl (TypeFixityDeclaration (Fixity assoc prec) name op) = + fmap (const (ExternsTypeFixity assoc prec op name)) (find (findOp getTypeOpRef op) exps) + typeFixityDecl (PositionedDeclaration _ _ d) = typeFixityDecl d + typeFixityDecl _ = Nothing + + findOp :: (DeclarationRef -> Maybe (OpName a)) -> OpName a -> DeclarationRef -> Bool + findOp get op = maybe False (== op) . get + importDecl :: Declaration -> Maybe ExternsImport - importDecl (ImportDeclaration m mt qmn _) = Just (ExternsImport m mt qmn) + importDecl (ImportDeclaration m mt qmn) = Just (ExternsImport m mt qmn) importDecl (PositionedDeclaration _ _ d) = importDecl d importDecl _ = Nothing @@ -204,5 +221,6 @@ $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsImport) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFixity) +$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsTypeFixity) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsDeclaration) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFile) diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -12,13 +12,9 @@ -- Interface for the psc-ide-server ----------------------------------------------------------------------------- -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} module Language.PureScript.Ide ( handleCommand @@ -40,6 +36,7 @@ import Data.Monoid import Data.Text (Text) import qualified Data.Text as T +import qualified Language.PureScript as P import qualified Language.PureScript.Ide.CaseSplit as CS import Language.PureScript.Ide.Command import Language.PureScript.Ide.Completion @@ -64,10 +61,10 @@ handleCommand (Load [] []) = loadAllModules handleCommand (Load modules deps) = loadModulesAndDeps modules deps -handleCommand (Type search filters) = - findType search filters -handleCommand (Complete filters matcher) = - findCompletions filters matcher +handleCommand (Type search filters currentModule) = + findType search filters currentModule +handleCommand (Complete filters matcher currentModule) = + findCompletions filters matcher currentModule handleCommand (Pursuit query Package) = findPursuitPackages query handleCommand (Pursuit query Identifier) = @@ -94,17 +91,20 @@ rebuildFile file handleCommand Cwd = TextResult . T.pack <$> liftIO getCurrentDirectory +handleCommand Reset = resetPscIdeState *> pure (TextResult "State has been reset.") handleCommand Quit = liftIO exitSuccess findCompletions :: (PscIde m, MonadLogger m) => - [Filter] -> Matcher -> m Success -findCompletions filters matcher = - CompletionResult . mapMaybe completionFromMatch . getCompletions filters matcher <$> getAllModulesWithReexports + [Filter] -> Matcher -> Maybe P.ModuleName -> m Success +findCompletions filters matcher currentModule = do + modules <- getAllModulesWithReexportsAndCache currentModule + pure . CompletionResult . mapMaybe completionFromMatch . getCompletions filters matcher $ modules findType :: (PscIde m, MonadLogger m) => - DeclIdent -> [Filter] -> m Success -findType search filters = - CompletionResult . mapMaybe completionFromMatch . getExactMatches search filters <$> getAllModulesWithReexports + DeclIdent -> [Filter] -> Maybe P.ModuleName -> m Success +findType search filters currentModule = do + modules <- getAllModulesWithReexportsAndCache currentModule + pure . CompletionResult . mapMaybe completionFromMatch . getExactMatches search filters $ modules findPursuitCompletions :: (MonadIO m, MonadLogger m) => PursuitQuery -> m Success @@ -116,14 +116,14 @@ findPursuitPackages (PursuitQuery q) = PursuitResult <$> liftIO (findPackagesForModuleIdent q) -loadExtern ::(PscIde m, MonadLogger m, MonadError PscIdeError m) => +loadExtern :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => FilePath -> m () loadExtern fp = do m <- readExternFile fp insertModule m printModules :: (PscIde m) => m Success -printModules = printModules' <$> getPscIdeState +printModules = printModules' . pscIdeStateModules <$> getPscIdeState printModules' :: M.Map ModuleIdent [ExternDecl] -> Success printModules' = ModuleList . M.keys diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -12,14 +12,8 @@ -- Casesplitting and adding function clauses ----------------------------------------------------------------------------- -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} -{-# LANGUAGE RecordWildCards #-} module Language.PureScript.Ide.CaseSplit ( WildcardAnnotations() diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -12,9 +12,7 @@ -- Datatypes for the commands psc-ide accepts ----------------------------------------------------------------------------- -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} module Language.PureScript.Ide.Command where @@ -23,10 +21,8 @@ import Control.Monad import Data.Aeson -import Data.Maybe import Data.Text (Text) -import Language.PureScript (ModuleName, - moduleNameFromString) +import qualified Language.PureScript as P import Language.PureScript.Ide.CaseSplit import Language.PureScript.Ide.Filter import Language.PureScript.Ide.Matcher @@ -38,12 +34,14 @@ , loadDependencies :: [ModuleIdent] } | Type - { typeSearch :: DeclIdent - , typeFilters :: [Filter] + { typeSearch :: DeclIdent + , typeFilters :: [Filter] + , typeCurrentModule :: Maybe P.ModuleName } | Complete - { completeFilters :: [Filter] - , completeMatcher :: Matcher + { completeFilters :: [Filter] + , completeMatcher :: Matcher + , completeCurrentModule :: Maybe P.ModuleName } | Pursuit { pursuitQuery :: PursuitQuery @@ -65,10 +63,11 @@ | List { listType :: ListType } | Rebuild FilePath -- ^ Rebuild the specified file using the loaded externs | Cwd + | Reset | Quit data ImportCommand - = AddImplicitImport ModuleName + = AddImplicitImport P.ModuleName | AddImportForIdentifier DeclIdent deriving (Show, Eq) @@ -76,12 +75,10 @@ parseJSON = withObject "ImportCommand" $ \o -> do (command :: String) <- o .: "importCommand" case command of - "addImplicitImport" -> do - mn <- o .: "module" - pure (AddImplicitImport (moduleNameFromString mn)) - "addImport" -> do - ident <- o .: "identifier" - pure (AddImportForIdentifier ident) + "addImplicitImport" -> + AddImplicitImport <$> (P.moduleNameFromString <$> o .: "module") + "addImport" -> + AddImportForIdentifier <$> o .: "identifier" _ -> mzero data ListType = LoadedModules | Imports FilePath | AvailableModules @@ -90,68 +87,69 @@ parseJSON = withObject "ListType" $ \o -> do (listType' :: String) <- o .: "type" case listType' of - "import" -> do - fp <- o .: "file" - return (Imports fp) - "loadedModules" -> return LoadedModules - "availableModules" -> return AvailableModules + "import" -> Imports <$> o .: "file" + "loadedModules" -> pure LoadedModules + "availableModules" -> pure AvailableModules _ -> mzero instance FromJSON Command where parseJSON = withObject "command" $ \o -> do (command :: String) <- o .: "command" case command of - "list" -> do - listType' <- o .:? "params" - return $ List (fromMaybe LoadedModules listType') - "cwd" -> return Cwd - "quit" -> return Quit - "load" -> - maybe (pure (Load [] [])) (\params -> do - mods <- params .:? "modules" - deps <- params .:? "dependencies" - pure $ Load (fromMaybe [] mods) (fromMaybe [] deps)) =<< o .:? "params" + "list" -> List <$> o .:? "params" .!= LoadedModules + "cwd" -> pure Cwd + "quit" -> pure Quit + "reset" -> pure Reset + "load" -> do + params' <- o .:? "params" + case params' of + Nothing -> pure (Load [] []) + Just params -> + Load + <$> params .:? "modules" .!= [] + <*> params .:? "dependencies" .!= [] "type" -> do params <- o .: "params" - search <- params .: "search" - filters <- params .: "filters" - return $ Type search filters + Type + <$> params .: "search" + <*> params .: "filters" + <*> (fmap P.moduleNameFromString <$> params .:? "currentModule") "complete" -> do params <- o .: "params" - filters <- params .:? "filters" - matcher <- params .:? "matcher" - return $ Complete (fromMaybe [] filters) (fromMaybe mempty matcher) + Complete + <$> params .:? "filters" .!= [] + <*> params .:? "matcher" .!= mempty + <*> (fmap P.moduleNameFromString <$> params .:? "currentModule") "pursuit" -> do params <- o .: "params" - query <- params .: "query" - queryType <- params .: "type" - return $ Pursuit query queryType + Pursuit + <$> params .: "query" + <*> params .: "type" "caseSplit" -> do params <- o .: "params" - line <- params .: "line" - begin <- params .: "begin" - end <- params .: "end" - annotations <- params .: "annotations" - type' <- params .: "type" - return $ CaseSplit line begin end (if annotations - then explicitAnnotations - else noAnnotations) type' + CaseSplit + <$> params .: "line" + <*> params .: "begin" + <*> params .: "end" + <*> (mkAnnotations <$> params .: "annotations") + <*> params .: "type" "addClause" -> do params <- o .: "params" - line <- params .: "line" - annotations <- params .: "annotations" - return $ AddClause line (if annotations - then explicitAnnotations - else noAnnotations) + AddClause + <$> params .: "line" + <*> (mkAnnotations <$> params .: "annotations") "import" -> do params <- o .: "params" - fp <- params .: "file" - out <- params .:? "outfile" - filters <- params .:? "filters" - importCommand <- params .: "importCommand" - pure $ Import fp out (fromMaybe [] filters) importCommand + Import + <$> params .: "file" + <*> params .:? "outfile" + <*> params .:? "filters" .!= [] + <*> params .: "importCommand" "rebuild" -> do params <- o .: "params" - filePath <- params .: "file" - return $ Rebuild filePath + Rebuild + <$> params .: "file" _ -> mzero + where + mkAnnotations True = explicitAnnotations + mkAnnotations False = noAnnotations diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -17,6 +17,7 @@ (ErrorMsg, PscIdeError(..), textError) where +import Prelude.Compat import Data.Aeson import Data.Monoid import Data.Text (Text, pack) diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -12,11 +12,7 @@ -- Handles externs files for psc-ide ----------------------------------------------------------------------------- -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} module Language.PureScript.Ide.Externs ( ExternDecl(..), @@ -45,10 +41,9 @@ import Language.PureScript.Ide.Util import qualified Language.PureScript as P -import qualified Language.PureScript.Externs as PE readExternFile :: (MonadIO m, MonadError PscIdeError m) => - FilePath -> m PE.ExternsFile + FilePath -> m P.ExternsFile readExternFile fp = do parseResult <- liftIO (decodeStrict <$> BS.readFile fp) case parseResult of @@ -61,15 +56,15 @@ identToText :: P.Ident -> Text identToText = T.pack . P.runIdent -convertExterns :: PE.ExternsFile -> Module -convertExterns ef = (moduleName, exportDecls ++ importDecls ++ decls) +convertExterns :: P.ExternsFile -> Module +convertExterns ef = (moduleName, exportDecls ++ importDecls ++ decls ++ operatorDecls ++ tyOperatorDecls) where - moduleName = moduleNameToText (PE.efModuleName ef) - importDecls = convertImport <$> PE.efImports ef - exportDecls = mapMaybe (convertExport . unwrapPositionedRef) (PE.efExports ef) - -- Ignoring operator fixities for now since we're not using them - -- operatorDecls = convertOperator <$> PE.efFixities ef - otherDecls = mapMaybe convertDecl (PE.efDeclarations ef) + moduleName = moduleNameToText (P.efModuleName ef) + importDecls = convertImport <$> P.efImports ef + exportDecls = mapMaybe (convertExport . unwrapPositionedRef) (P.efExports ef) + operatorDecls = convertOperator <$> P.efFixities ef + tyOperatorDecls = convertTypeOperator <$> P.efTypeFixities ef + otherDecls = mapMaybe convertDecl (P.efDeclarations ef) typeClassFilter = foldMap removeTypeDeclarationsForClass (filter isTypeClassDeclaration otherDecls) decls = nub $ appEndo typeClassFilter otherDecls @@ -85,26 +80,42 @@ isTypeClassDeclaration TypeClassDeclaration{} = True isTypeClassDeclaration _ = False -convertImport :: PE.ExternsImport -> ExternDecl +convertImport :: P.ExternsImport -> ExternDecl convertImport ei = Dependency - (moduleNameToText (PE.eiModule ei)) + (moduleNameToText (P.eiModule ei)) [] - (moduleNameToText <$> PE.eiImportedAs ei) + (moduleNameToText <$> P.eiImportedAs ei) convertExport :: P.DeclarationRef -> Maybe ExternDecl convertExport (P.ModuleRef mn) = Just (Export (moduleNameToText mn)) convertExport _ = Nothing -convertDecl :: PE.ExternsDeclaration -> Maybe ExternDecl -convertDecl PE.EDType{..} = Just $ TypeDeclaration edTypeName edTypeKind -convertDecl PE.EDTypeSynonym{..} = Just $ +convertDecl :: P.ExternsDeclaration -> Maybe ExternDecl +convertDecl P.EDType{..} = Just $ TypeDeclaration edTypeName edTypeKind +convertDecl P.EDTypeSynonym{..} = Just $ TypeSynonymDeclaration edTypeSynonymName edTypeSynonymType -convertDecl PE.EDDataConstructor{..} = Just $ +convertDecl P.EDDataConstructor{..} = Just $ DataConstructor (runProperNameT edDataCtorName) edDataCtorTypeCtor edDataCtorType -convertDecl PE.EDValue{..} = Just $ +convertDecl P.EDValue{..} = Just $ ValueDeclaration (identToText edValueName) edValueType -convertDecl PE.EDClass{..} = Just $ TypeClassDeclaration edClassName -convertDecl PE.EDInstance{} = Nothing +convertDecl P.EDClass{..} = Just $ TypeClassDeclaration edClassName +convertDecl P.EDInstance{} = Nothing + +convertOperator :: P.ExternsFixity -> ExternDecl +convertOperator P.ExternsFixity{..} = + ValueOperator + efOperator + (T.pack (P.showQualified (either P.runIdent P.runProperName) efAlias)) + efPrecedence + efAssociativity + +convertTypeOperator :: P.ExternsTypeFixity -> ExternDecl +convertTypeOperator P.ExternsTypeFixity{..} = + TypeOperator + efTypeOperator + (T.pack (P.showQualified P.runProperName efTypeAlias)) + efTypePrecedence + efTypeAssociativity unwrapPositioned :: P.Declaration -> P.Declaration unwrapPositioned (P.PositionedDeclaration _ _ x) = x diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -14,7 +14,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} module Language.PureScript.Ide.Filter ( Filter diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -12,10 +12,6 @@ -- Provides functionality to manage imports ----------------------------------------------------------------------------- -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} @@ -34,6 +30,7 @@ ) where +import Prelude.Compat import Control.Applicative ((<|>)) import Control.Monad.Error.Class import Control.Monad.IO.Class @@ -95,9 +92,9 @@ (P.Module _ _ mn decls _) <- moduleParse ls pure (mn, concatMap mkImport (unwrapPositioned <$> decls)) where - mkImport (P.ImportDeclaration mn (P.Explicit refs) qual _) = + mkImport (P.ImportDeclaration mn (P.Explicit refs) qual) = [Import mn (P.Explicit (unwrapPositionedRef <$> refs)) qual] - mkImport (P.ImportDeclaration mn it qual _) = [Import mn it qual] + mkImport (P.ImportDeclaration mn it qual) = [Import mn it qual] mkImport _ = [] sliceImportSection :: [Text] -> Either String (P.ModuleName, [Text], [Import], [Text]) @@ -212,15 +209,18 @@ then imports else updateAtFirstOrPrepend matches (insertDeclIntoImport decl) freshImport imports where - refFromDeclaration (TypeClassDeclaration n) = P.TypeClassRef n + refFromDeclaration (TypeClassDeclaration n) = + P.TypeClassRef n refFromDeclaration (DataConstructor n tn _) = P.TypeRef tn (Just [P.ProperName (T.unpack n)]) - refFromDeclaration (TypeDeclaration n _) = P.TypeRef n (Just []) + refFromDeclaration (TypeDeclaration n _) = + P.TypeRef n (Just []) + refFromDeclaration (ValueOperator op _ _ _) = + P.ValueOpRef op + refFromDeclaration (TypeOperator op _ _ _) = + P.TypeOpRef op refFromDeclaration d = - let - ident = T.unpack (identifierFromExternDecl d) - in - P.ValueRef ((if all P.isSymbolChar ident then P.Op else P.Ident) ident) + P.ValueRef $ P.Ident $ T.unpack (identifierFromExternDecl d) -- | Adds a declaration to an import: -- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe) @@ -233,10 +233,8 @@ insertDeclIntoRefs (DataConstructor dtor tn _) refs = let dtor' = P.ProperName (T.unpack dtor) - -- TODO: Get rid of this once typeclasses can't be imported like types - refs' = properRefToTypeRef <$> refs in - updateAtFirstOrPrepend (matchType tn) (insertDtor dtor') (P.TypeRef tn (Just [dtor'])) refs' + updateAtFirstOrPrepend (matchType tn) (insertDtor dtor') (P.TypeRef tn (Just [dtor'])) refs insertDeclIntoRefs dr refs = List.nubBy ((==) `on` P.prettyPrintRef) (refFromDeclaration dr : refs) insertDtor dtor (P.TypeRef tn' dtors) = @@ -247,11 +245,6 @@ Nothing -> P.TypeRef tn' Nothing insertDtor _ refs = refs - - -- TODO: Get rid of this once typeclasses can't be imported like types - properRefToTypeRef (P.ProperRef n) = P.TypeRef (P.ProperName n) (Just []) - properRefToTypeRef r = r - matchType :: P.ProperName 'P.TypeName -> P.DeclarationRef -> Bool matchType tn (P.TypeRef n _) = tn == n matchType _ _ = False @@ -348,8 +341,7 @@ parseImport t = case P.lex "" (T.unpack t) >>= P.runTokenParser "" P.parseImportDeclaration' of - Right (mn, P.Explicit refs, mmn, _) -> + Right (mn, P.Explicit refs, mmn) -> Just (Import mn (P.Explicit (unwrapPositionedRef <$> refs)) mmn) - Right (mn, idt, mmn, _) -> Just (Import mn idt mmn) + Right (mn, idt, mmn) -> Just (Import mn idt mmn) Left _ -> Nothing - diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs --- a/src/Language/PureScript/Ide/Matcher.hs +++ b/src/Language/PureScript/Ide/Matcher.hs @@ -14,7 +14,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} module Language.PureScript.Ide.Matcher ( Matcher diff --git a/src/Language/PureScript/Ide/Pursuit.hs b/src/Language/PureScript/Ide/Pursuit.hs --- a/src/Language/PureScript/Ide/Pursuit.hs +++ b/src/Language/PureScript/Ide/Pursuit.hs @@ -13,7 +13,6 @@ ----------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} module Language.PureScript.Ide.Pursuit where diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -1,74 +1,151 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} -module Language.PureScript.Ide.Rebuild where - -import Language.PureScript.Ide.Error -import Language.PureScript.Ide.State -import Language.PureScript.Ide.Types +module Language.PureScript.Ide.Rebuild + ( rebuildFile + ) where import Control.Monad.Error.Class import Control.Monad.IO.Class import "monad-logger" Control.Monad.Logger -import Control.Monad.Reader.Class +import Control.Monad.Reader import Control.Monad.Trans.Except import qualified Data.Map.Lazy as M import Data.Maybe (fromJust, mapMaybe) +import Data.Monoid ((<>)) import qualified Data.Set as S import qualified Language.PureScript as P import Language.PureScript.Errors.JSON -import qualified Language.PureScript.Externs as P -import System.FilePath (replaceExtension) -import System.Directory (doesFileExist) -import System.IO.UTF8 (readUTF8File) +import Language.PureScript.Ide.Error +import Language.PureScript.Ide.State +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Util +import Prelude.Compat +import System.IO.UTF8 (readUTF8File) +-- | Given a filepath performs the following steps: +-- +-- * Reads and parses a PureScript module from the filepath. +-- +-- * Builds a dependency graph for the parsed module from the already loaded +-- ExternsFiles. +-- +-- * Attempts to find an FFI definition file for the module by looking +-- for a file with the same filepath except for a .js extension. +-- +-- * Passes all the created artifacts to @rebuildModule@. +-- +-- * If the rebuilding succeeds, returns a @RebuildSuccess@ with the generated +-- warnings, and if rebuilding fails, returns a @RebuildError@ with the +-- generated errors. rebuildFile :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => FilePath -> m Success rebuildFile path = do - input <- liftIO $ readUTF8File path + input <- liftIO (readUTF8File path) - m <- case map snd <$> P.parseModulesFromFiles id [(path, input)] of - Left parseError -> - throwError . RebuildError . toJSONErrors False P.Error $ parseError - Right [m] -> pure m - Right _ -> throwError . GeneralError $ "Please define exactly one module." + m <- case snd <$> P.parseModuleFromFile id (path, input) of + Left parseError -> throwError + . RebuildError + . toJSONErrors False P.Error + $ P.MultipleErrors [P.toPositionedError parseError] + Right m -> pure m - externs <- sortExterns m . M.delete (P.getModuleName m) =<< getExternFiles + -- Externs files must be sorted ahead of time, so that they get applied + -- correctly to the 'Environment'. + externs <- sortExterns m =<< getExternFiles outputDirectory <- confOutputPath . envConfiguration <$> ask - let foreignModule = replaceExtension path "js" - foreignExists <- liftIO (doesFileExist foreignModule) + -- For rebuilding, we want to 'RebuildAlways', but for inferring foreign + -- modules using their file paths, we need to specify the path in the 'Map'. + let filePathMap = M.singleton (P.getModuleName m) (Left P.RebuildAlways) + foreigns <- P.inferForeignModules (M.singleton (P.getModuleName m) (Right path)) - let ma = P.buildMakeActions outputDirectory - (M.singleton (P.getModuleName m) (Left P.RebuildAlways)) - (if foreignExists - then M.singleton (P.getModuleName m) foreignModule - else M.empty) - False + let makeEnv = MakeActionsEnv outputDirectory filePathMap foreigns False + -- Rebuild the single module using the cached externs (result, warnings) <- liftIO - . P.runMake P.defaultOptions - . P.rebuildModule (ma { P.progress = const (pure ()) }) externs - $ P.addDefaultImport (P.ModuleName [P.ProperName "Prim"]) m + . P.runMake P.defaultOptions + . P.rebuildModule (buildMakeActions + >>= shushProgress $ makeEnv) externs $ m case result of - Left errors -> throwError . RebuildError $ toJSONErrors False P.Error errors - Right _ -> pure . RebuildSuccess $ toJSONErrors False P.Warning warnings + Left errors -> throwError (RebuildError (toJSONErrors False P.Error errors)) + Right _ -> do + rebuildModuleOpen makeEnv externs m + pure (RebuildSuccess (toJSONErrors False P.Warning warnings)) +-- | Rebuilds a module but opens up its export list first and stores the result +-- inside the rebuild cache +rebuildModuleOpen + :: (PscIde m, MonadLogger m, MonadError PscIdeError m) + => MakeActionsEnv + -> [P.ExternsFile] + -> P.Module + -> m () +rebuildModuleOpen makeEnv externs m = do + (openResult, _) <- liftIO + . P.runMake P.defaultOptions + . P.rebuildModule (buildMakeActions + >>= shushProgress + >>= shushCodegen + $ makeEnv) externs $ openModuleExports m + case openResult of + Left _ -> + throwError (GeneralError "Failed when rebuilding with open exports") + Right result -> do + $(logDebug) + ("Setting Rebuild cache: " <> runModuleNameT (P.efModuleName result)) + setCachedRebuild result + +-- | Parameters we can access while building our @MakeActions@ +data MakeActionsEnv = + MakeActionsEnv + { maeOutputDirectory :: FilePath + , maeFilePathMap :: M.Map P.ModuleName (Either P.RebuildPolicy FilePath) + , maeForeignPathMap :: M.Map P.ModuleName FilePath + , maePrefixComment :: Bool + } + +-- | Builds the default @MakeActions@ from a @MakeActionsEnv@ +buildMakeActions :: MakeActionsEnv -> P.MakeActions P.Make +buildMakeActions MakeActionsEnv{..} = + P.buildMakeActions + maeOutputDirectory + maeFilePathMap + maeForeignPathMap + maePrefixComment + +-- | Shuts the compiler up about progress messages +shushProgress :: P.MakeActions P.Make -> MakeActionsEnv -> P.MakeActions P.Make +shushProgress ma _ = + ma { P.progress = \_ -> pure () } + +-- | Stops any kind of codegen (also silences errors about missing or unused FFI +-- files though) +shushCodegen :: P.MakeActions P.Make -> MakeActionsEnv -> P.MakeActions P.Make +shushCodegen ma MakeActionsEnv{..} = + ma { P.codegen = \_ _ _ -> pure () } + +-- | Returns a topologically sorted list of dependent ExternsFiles for the given +-- module. Throws an error if there is a cyclic dependency within the +-- ExternsFiles sortExterns :: (PscIde m, MonadError PscIdeError m) => P.Module -> M.Map P.ModuleName P.ExternsFile -> m [P.ExternsFile] sortExterns m ex = do - sorted' <- runExceptT . P.sortModules . (:) m . map mkShallowModule . M.elems $ ex + sorted' <- runExceptT + . P.sortModules + . (:) m + . map mkShallowModule + . M.elems + . M.delete (P.getModuleName m) $ ex case sorted' of Left _ -> throwError (GeneralError "There was a cycle in the dependencies") Right (sorted, graph) -> do @@ -78,8 +155,12 @@ mkShallowModule P.ExternsFile{..} = P.Module undefined [] efModuleName (map mkImport efImports) Nothing mkImport (P.ExternsImport mn it iq) = - P.ImportDeclaration mn it iq False + P.ImportDeclaration mn it iq getExtern mn = M.lookup mn ex -- Sort a list so its elements appear in the same order as in another list. inOrderOf :: (Ord a) => [a] -> [a] -> [a] inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys + +-- | Removes a modules export list. +openModuleExports :: P.Module -> P.Module +openModuleExports (P.Module ss cs mn decls _) = P.Module ss cs mn decls Nothing diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -14,8 +14,6 @@ ----------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TupleSections #-} module Language.PureScript.Ide.Reexports where diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -12,8 +12,6 @@ -- Getting declarations from PureScript sourcefiles ----------------------------------------------------------------------------- -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Ide.SourceFile where @@ -68,14 +66,14 @@ let imports = getImports module' pure (mkModuleImport . unwrapPositionedImport <$> imports) where - mkModuleImport (D.ImportDeclaration mn importType' qualifier _) = + mkModuleImport (D.ImportDeclaration mn importType' qualifier) = ModuleImport (T.pack (N.runModuleName mn)) importType' (T.pack . N.runModuleName <$> qualifier) mkModuleImport _ = error "Shouldn't have gotten anything but Imports here" - unwrapPositionedImport (D.ImportDeclaration mn importType' qualifier b) = - D.ImportDeclaration mn (unwrapImportType importType') qualifier b + unwrapPositionedImport (D.ImportDeclaration mn importType' qualifier) = + D.ImportDeclaration mn (unwrapImportType importType') qualifier unwrapPositionedImport x = x unwrapImportType (D.Explicit decls) = D.Explicit (map unwrapPositionedRef decls) unwrapImportType (D.Hiding decls) = D.Hiding (map unwrapPositionedRef decls) diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -12,15 +12,23 @@ -- Functions to access psc-ide's state ----------------------------------------------------------------------------- -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -module Language.PureScript.Ide.State where +module Language.PureScript.Ide.State + ( getPscIdeState + , getExternFiles + , getModule + , getModuleWithReexports + , getAllModulesWithReexports + , getAllModulesWithReexportsAndCache + , insertModule + , insertModuleSTM + , getCachedRebuild + , resetPscIdeState + , setCachedRebuild + ) where import Prelude () import Prelude.Compat @@ -30,69 +38,106 @@ import "monad-logger" Control.Monad.Logger import Control.Monad.Reader.Class import qualified Data.Map.Lazy as M -import Data.Maybe (catMaybes) +import Data.Maybe (mapMaybe) import Data.Monoid -import qualified Data.Text as T import Language.PureScript.Externs import Language.PureScript.Ide.Externs import Language.PureScript.Ide.Reexports import Language.PureScript.Ide.Types -import Language.PureScript.Names +import Language.PureScript.Ide.Util +import qualified Language.PureScript as P -getPscIdeState :: (PscIde m) => - m (M.Map ModuleIdent [ExternDecl]) +-- | Resets the PscIdeState to emptyPscIdeState +resetPscIdeState :: PscIde m => m () +resetPscIdeState = do + stateVar <- envStateVar <$> ask + liftIO $ atomically (writeTVar stateVar emptyPscIdeState) + +-- | Gets the entire PscIdeState +getPscIdeState :: PscIde m => m PscIdeState getPscIdeState = do stateVar <- envStateVar <$> ask - liftIO $ pscStateModules <$> readTVarIO stateVar + liftIO (readTVarIO stateVar) -getExternFiles :: (PscIde m) => - m (M.Map ModuleName ExternsFile) +-- | Gets all loaded ExternFiles +getExternFiles :: (PscIde m) => m (M.Map P.ModuleName ExternsFile) getExternFiles = do stateVar <- envStateVar <$> ask - liftIO (externsFiles <$> readTVarIO stateVar) + liftIO (pscIdeStateExternsFiles <$> readTVarIO stateVar) -getExternFile :: (PscIde m) => - ModuleName -> m (Maybe ExternsFile) -getExternFile mn = M.lookup mn <$> getExternFiles +-- | Gets all loaded Modules and resolves Reexports +getAllModulesWithReexports :: (PscIde m) => m [Module] +getAllModulesWithReexports = getAllModulesWithReexports' <$> getPscIdeState -getAllDecls :: (PscIde m) => m [ExternDecl] -getAllDecls = concat <$> getPscIdeState +-- | Pure version of @getAllModulesWithReexports@ +getAllModulesWithReexports' :: PscIdeState -> [Module] +getAllModulesWithReexports' state = + mapMaybe (getModuleWithReexports' state) (M.keys (pscIdeStateModules state)) -getAllModules :: (PscIde m) => m [Module] -getAllModules = M.toList <$> getPscIdeState +-- | Checks if the given ModuleName matches the last rebuild cache and if it +-- does, runs @getAllModulesWithReexports@ with the cached module replacing the +-- loaded module +getAllModulesWithReexportsAndCache + :: (PscIde m) + => Maybe P.ModuleName + -> m [Module] +getAllModulesWithReexportsAndCache Nothing = getAllModulesWithReexports +getAllModulesWithReexportsAndCache (Just mn) = do + state <- getPscIdeState + cachedRebuild <- getCachedRebuild + case cachedRebuild of + Just (cachedIdent, ef) | cachedIdent == mn -> + pure (getAllModulesWithReexports' (insertModule' ef state)) + _ -> getAllModulesWithReexports -getAllModulesWithReexports :: (PscIde m, MonadLogger m) => - m [Module] -getAllModulesWithReexports = do - mis <- M.keys <$> getPscIdeState - ms <- traverse getModuleWithReexports mis - pure (catMaybes ms) +-- | Looks up a single Module inside the loaded Modules +getModule :: (PscIde m, MonadLogger m) => ModuleIdent -> m (Maybe Module) +getModule m = getModule' <$> getPscIdeState <*> pure m -getModule :: (PscIde m, MonadLogger m) => - ModuleIdent -> m (Maybe Module) -getModule m = do - modules <- getPscIdeState - pure ((m,) <$> M.lookup m modules) +-- | Pure version of @getModule@ +getModule' :: PscIdeState -> ModuleIdent -> Maybe Module +getModule' ps mi = (mi,) <$> M.lookup mi (pscIdeStateModules ps) -getModuleWithReexports :: (PscIde m, MonadLogger m) => - ModuleIdent -> m (Maybe Module) -getModuleWithReexports mi = do - m <- getModule mi - modules <- getPscIdeState - pure $ resolveReexports modules <$> m +-- | Looks up a single Module and resolves its Reexports +getModuleWithReexports :: PscIde m => ModuleIdent -> m (Maybe Module) +getModuleWithReexports i = getModuleWithReexports' <$> getPscIdeState <*> pure i -insertModule ::(PscIde m, MonadLogger m) => +-- | Pure version of @getModuleWithReexports@ +getModuleWithReexports' :: PscIdeState -> ModuleIdent -> Maybe Module +getModuleWithReexports' ps mi = + resolveReexports (pscIdeStateModules ps) <$> getModule' ps mi + +-- | Inserts an @ExternsFile@ into the PscIdeState. Also converts the +-- ExternsFile into psc-ide's internal Declaration format +insertModule :: (PscIde m, MonadLogger m) => ExternsFile -> m () insertModule externsFile = do - env <- ask + stateVar <- envStateVar <$> ask let moduleName = efModuleName externsFile - $(logDebug) $ "Inserting Module: " <> T.pack (runModuleName moduleName) - liftIO . atomically $ insertModule' (envStateVar env) externsFile + $(logDebug) $ "Inserting Module: " <> runModuleNameT moduleName + liftIO . atomically $ insertModuleSTM stateVar externsFile -insertModule' :: TVar PscIdeState -> ExternsFile -> STM () -insertModule' st ef = - modifyTVar st $ \x -> - x { externsFiles = M.insert (efModuleName ef) ef (externsFiles x) - , pscStateModules = let (mn, decls) = convertExterns ef - in M.insert mn decls (pscStateModules x) - } +-- | STM version of insertModule +insertModuleSTM :: TVar PscIdeState -> ExternsFile -> STM () +insertModuleSTM st ef = modifyTVar st (insertModule' ef) + +-- | Pure version of insertModule +insertModule' :: ExternsFile -> PscIdeState -> PscIdeState +insertModule' ef state = + state + { pscIdeStateExternsFiles = + M.insert (efModuleName ef) ef (pscIdeStateExternsFiles state) + , pscIdeStateModules = let (mn, decls) = convertExterns ef + in M.insert mn decls (pscIdeStateModules state) + } + +-- | Sets rebuild cache to the given ExternsFile +setCachedRebuild :: PscIde m => ExternsFile -> m () +setCachedRebuild ef = do + st <- envStateVar <$> ask + liftIO . atomically . modifyTVar st $ \x -> + x { pscIdeStateCachedRebuild = Just (efModuleName ef, ef) } + +-- | Retrieves the rebuild cache +getCachedRebuild :: PscIde m => m (Maybe (P.ModuleName, ExternsFile)) +getCachedRebuild = pscIdeStateCachedRebuild <$> getPscIdeState diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -12,11 +12,7 @@ -- Type definitions for psc-ide ----------------------------------------------------------------------------- -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} module Language.PureScript.Ide.Types where @@ -65,6 +61,8 @@ P.Type -- The "type" -- | An exported module | TypeClassDeclaration (P.ProperName 'P.ClassName) + | ValueOperator (P.OpName 'P.ValueOpName) Ident P.Precedence P.Associativity + | TypeOperator (P.OpName 'P.TypeOpName) Ident P.Precedence P.Associativity | Export ModuleIdent -- The exported Modules name deriving (Show,Eq,Ord) @@ -86,12 +84,13 @@ data PscIdeState = PscIdeState - { pscStateModules :: M.Map Text [ExternDecl] - , externsFiles :: M.Map P.ModuleName ExternsFile + { pscIdeStateModules :: M.Map Text [ExternDecl] + , pscIdeStateExternsFiles :: M.Map P.ModuleName ExternsFile + , pscIdeStateCachedRebuild :: Maybe (P.ModuleName, ExternsFile) } deriving Show emptyPscIdeState :: PscIdeState -emptyPscIdeState = PscIdeState M.empty M.empty +emptyPscIdeState = PscIdeState M.empty M.empty Nothing data Match = Match ModuleIdent ExternDecl deriving (Show, Eq) diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -16,6 +16,7 @@ module Language.PureScript.Ide.Util where +import Prelude.Compat import Data.Aeson import Data.Text (Text) import qualified Data.Text as T @@ -30,6 +31,12 @@ runIdentT :: P.Ident -> Text runIdentT = T.pack . P.runIdent +runOpNameT :: P.OpName a -> Text +runOpNameT = T.pack . P.runOpName + +runModuleNameT :: P.ModuleName -> Text +runModuleNameT = T.pack . P.runModuleName + prettyTypeT :: P.Type -> Text prettyTypeT = T.unwords . fmap T.strip . T.lines . T.pack . P.prettyPrintType @@ -40,6 +47,8 @@ identifierFromExternDecl (DataConstructor name _ _) = name identifierFromExternDecl (TypeClassDeclaration name) = runProperNameT name identifierFromExternDecl (ModuleDecl name _) = name +identifierFromExternDecl (ValueOperator op _ _ _) = runOpNameT op +identifierFromExternDecl (TypeOperator op _ _ _) = runOpNameT op identifierFromExternDecl Dependency{} = "~Dependency~" identifierFromExternDecl Export{} = "~Export~" @@ -47,16 +56,25 @@ identifierFromMatch (Match _ ed) = identifierFromExternDecl ed completionFromMatch :: Match -> Maybe Completion -completionFromMatch (Match _ Dependency{}) = Nothing -completionFromMatch (Match _ Export{}) = Nothing -completionFromMatch (Match m d) = Just $ case d of - ValueDeclaration name type' -> Completion (m, name, prettyTypeT type') - TypeDeclaration name kind -> Completion (m, runProperNameT name, T.pack $ P.prettyPrintKind kind) - TypeSynonymDeclaration name kind -> Completion (m, runProperNameT name, prettyTypeT kind) - DataConstructor name _ type' -> Completion (m, name, prettyTypeT type') - TypeClassDeclaration name -> Completion (m, runProperNameT name, "class") - ModuleDecl name _ -> Completion ("module", name, "module") - _ -> error "the impossible happened in completionFromMatch" +completionFromMatch (Match m d) = case d of + ValueDeclaration name type' -> Just $ Completion (m, name, prettyTypeT type') + TypeDeclaration name kind -> Just $ Completion (m, runProperNameT name, T.pack $ P.prettyPrintKind kind) + TypeSynonymDeclaration name kind -> Just $ Completion (m, runProperNameT name, prettyTypeT kind) + DataConstructor name _ type' -> Just $ Completion (m, name, prettyTypeT type') + TypeClassDeclaration name -> Just $ Completion (m, runProperNameT name, "class") + ModuleDecl name _ -> Just $ Completion ("module", name, "module") + ValueOperator op ref precedence associativity -> Just $ Completion (m, runOpNameT op, showFixity precedence associativity ref op) + TypeOperator op ref precedence associativity -> Just $ Completion (m, runOpNameT op, showFixity precedence associativity ref op) + Dependency{} -> Nothing + Export{} -> Nothing + where + showFixity p a r o = + let asso = case a of + P.Infix -> "infix" + P.Infixl -> "infixl" + P.Infixr -> "infixr" + in T.unwords [asso, T.pack (show p), r, "as", runOpNameT o] + encodeT :: (ToJSON a) => a -> Text encodeT = toStrict . decodeUtf8 . encode diff --git a/src/Language/PureScript/Ide/Watcher.hs b/src/Language/PureScript/Ide/Watcher.hs --- a/src/Language/PureScript/Ide/Watcher.hs +++ b/src/Language/PureScript/Ide/Watcher.hs @@ -12,44 +12,38 @@ -- File watcher for externs files ----------------------------------------------------------------------------- -{-# LANGUAGE RecordWildCards #-} - module Language.PureScript.Ide.Watcher where -import Prelude () -import Prelude.Compat - import Control.Concurrent (threadDelay) import Control.Concurrent.STM import Control.Monad import Control.Monad.Trans.Except -import qualified Data.Map as M -import Data.Maybe (isJust) -import Language.PureScript.Externs import Language.PureScript.Ide.Externs import Language.PureScript.Ide.State import Language.PureScript.Ide.Types +import Prelude import System.FilePath import System.FSNotify - -reloadFile :: TVar PscIdeState -> FilePath -> IO () -reloadFile stateVar fp = do - (Right ef@ExternsFile{..}) <- runExceptT $ readExternFile fp - reloaded <- atomically $ do - st <- readTVar stateVar - if isLoaded efModuleName st - then - insertModule' stateVar ef *> pure True - else - pure False - when reloaded $ putStrLn $ "Reloaded File at: " ++ fp - where - isLoaded name st = isJust (M.lookup name (externsFiles st)) +-- | Reloads an ExternsFile from Disc. If the Event indicates the ExternsFile +-- was deleted we don't do anything. +reloadFile :: TVar PscIdeState -> Event -> IO () +reloadFile _ Removed{} = pure () +reloadFile stateVar ev = do + let fp = eventPath ev + ef' <- runExceptT (readExternFile fp) + case ef' of + Left _ -> pure () + Right ef -> do + atomically (insertModuleSTM stateVar ef) + putStrLn ("Reloaded File at: " ++ fp) +-- | Installs filewatchers for the given directory and reloads ExternsFiles when +-- they change on disc watcher :: TVar PscIdeState -> FilePath -> IO () -watcher stateVar fp = withManager $ \mgr -> do - _ <- watchTree mgr fp - (\ev -> takeFileName (eventPath ev) == "externs.json") - (reloadFile stateVar . eventPath) - forever (threadDelay 10000) +watcher stateVar fp = + withManagerConf (defaultConfig { confDebounce = NoDebounce }) $ \mgr -> do + _ <- watchTree mgr fp + (\ev -> takeFileName (eventPath ev) == "externs.json") + (reloadFile stateVar) + forever (threadDelay 100000) diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Interactive.hs @@ -0,0 +1,283 @@ +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DataKinds #-} + +module Language.PureScript.Interactive + ( handleCommand + , module Interactive + + -- TODO: remove these exports + , make + , runMake + ) where + +import Prelude () +import Prelude.Compat + +import Data.List (intercalate, nub, sort, find, foldl') +import qualified Data.Map as M + +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.State.Class +import Control.Monad.Reader.Class +import Control.Monad.Trans.Except (ExceptT(..), runExceptT) +import Control.Monad.Trans.State.Strict (StateT, runStateT) +import Control.Monad.Writer.Strict (Writer(), runWriter) + +import qualified Language.PureScript as P +import qualified Language.PureScript.Names as N + +import Language.PureScript.Interactive.Completion as Interactive +import Language.PureScript.Interactive.IO as Interactive +import Language.PureScript.Interactive.Message as Interactive +import Language.PureScript.Interactive.Module as Interactive +import Language.PureScript.Interactive.Parser as Interactive +import Language.PureScript.Interactive.Printer as Interactive +import Language.PureScript.Interactive.Types as Interactive + +import System.Exit +import System.Process (readProcessWithExitCode) + +-- | Pretty-print errors +printErrors :: MonadIO m => P.MultipleErrors -> m () +printErrors = liftIO . putStrLn . P.prettyPrintMultipleErrors P.defaultPPEOptions + +-- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the +-- options and ignores the warning messages. +runMake :: P.Make a -> IO (Either P.MultipleErrors a) +runMake mk = fst <$> P.runMake P.defaultOptions mk + +-- | Rebuild a module, using the cached externs data for dependencies. +rebuild + :: [P.ExternsFile] + -> P.Module + -> P.Make (P.ExternsFile, P.Environment) +rebuild loadedExterns m = do + externs <- P.rebuildModule buildActions loadedExterns m + return (externs, foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment (loadedExterns ++ [externs])) + where + buildActions :: P.MakeActions P.Make + buildActions = + (P.buildMakeActions modulesDir + filePathMap + M.empty + False) { P.progress = const (return ()) } + + filePathMap :: M.Map P.ModuleName (Either P.RebuildPolicy FilePath) + filePathMap = M.singleton (P.getModuleName m) (Left P.RebuildAlways) + +-- | Build the collection of modules from scratch. This is usually done on startup. +make + :: [(FilePath, P.Module)] + -> P.Make ([P.ExternsFile], P.Environment) +make ms = do + foreignFiles <- P.inferForeignModules filePathMap + externs <- P.make (buildActions foreignFiles) (map snd ms) + return (externs, foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs) + where + buildActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make + buildActions foreignFiles = + P.buildMakeActions modulesDir + filePathMap + foreignFiles + False + + filePathMap :: M.Map P.ModuleName (Either P.RebuildPolicy FilePath) + filePathMap = M.fromList $ map (\(fp, m) -> (P.getModuleName m, Right fp)) ms + +-- | Performs a PSCi command +handleCommand + :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) + => Command + -> m () +handleCommand ShowHelp = liftIO $ putStrLn helpMessage +handleCommand ResetState = handleResetState +handleCommand (Expression val) = handleExpression val +handleCommand (Import im) = handleImport im +handleCommand (Decls l) = handleDecls l +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 = P.internalError "`handleCommand QuitPSCi` was called. This is a bug." + +-- | Reset the application state +handleResetState + :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) + => m () +handleResetState = do + modify $ updateImportedModules (const []) + . updateLets (const []) + files <- asks psciLoadedFiles + e <- runExceptT $ do + modules <- ExceptT . liftIO $ loadAllModules files + (externs, _) <- ExceptT . liftIO . runMake . make $ modules + return (map snd modules, externs) + case e of + Left errs -> printErrors errs + Right (modules, externs) -> modify (updateLoadedExterns (const (zip modules externs))) + +-- | Takes a value expression and evaluates it with the current state. +-- +-- TODO: factor out the Node process runner, so that we can use PSCi in other settings. +handleExpression + :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) + => P.Expr + -> m () +handleExpression val = do + st <- get + let m = createTemporaryModule True st val + nodeArgs <- asks ((++ [indexFile]) . psciNodeFlags) + e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m + case e of + Left errs -> printErrors errs + Right _ -> do + liftIO $ writeFile indexFile "require('$PSCI')['$main']();" + process <- liftIO findNodeProcess + result <- liftIO $ traverse (\node -> readProcessWithExitCode node nodeArgs "") process + case result of + Just (ExitSuccess, out, _) -> liftIO $ putStrLn out + Just (ExitFailure _, _, err) -> liftIO $ putStrLn err + Nothing -> liftIO $ putStrLn "Couldn't find node.js" + +-- | +-- Takes a list of declarations and updates the environment, then run a make. If the declaration fails, +-- restore the original environment. +-- +handleDecls + :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) + => [P.Declaration] + -> m () +handleDecls ds = do + st <- gets (updateLets (++ ds)) + let m = createTemporaryModule False st (P.Literal (P.ObjectLiteral [])) + e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m + case e of + Left err -> printErrors err + Right _ -> put st + +-- | Show actual loaded modules in psci. +handleShowLoadedModules + :: (MonadState PSCiState m, MonadIO m) + => m () +handleShowLoadedModules = do + loadedModules <- gets psciLoadedExterns + liftIO $ putStrLn (readModules loadedModules) + where + readModules = unlines . sort . nub . map (P.runModuleName . P.getModuleName . fst) + +-- | Show the imported modules in psci. +handleShowImportedModules + :: (MonadState PSCiState m, MonadIO m) + => m () +handleShowImportedModules = do + PSCiState { psciImportedModules = importedModules } <- get + liftIO $ showModules importedModules >>= putStrLn + return () + where + showModules = return . unlines . sort . map showModule + showModule (mn, declType, asQ) = + "import " ++ N.runModuleName mn ++ showDeclType declType ++ + foldMap (\mn' -> " as " ++ N.runModuleName mn') asQ + + 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 (P.TypeRef pn dctors) = N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")" + showRef (P.TypeOpRef op) = "type " ++ N.showOp op + showRef (P.ValueRef ident) = N.runIdent ident + showRef (P.ValueOpRef op) = N.showOp op + showRef (P.TypeClassRef pn) = "class " ++ N.runProperName pn + showRef (P.TypeInstanceRef ident) = N.runIdent ident + showRef (P.ModuleRef name) = "module " ++ N.runModuleName name + showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref + + commaList :: [String] -> String + commaList = intercalate ", " + +-- | Imports a module, preserving the initial state on failure. +handleImport + :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) + => ImportedModule + -> m () +handleImport im = do + st <- gets (updateImportedModules (im :)) + let m = createTemporaryModuleForImports st + e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m + case e of + Left errs -> printErrors errs + Right _ -> put st + +-- | Takes a value and prints its type +handleTypeOf + :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) + => P.Expr + -> m () +handleTypeOf val = do + st <- get + let m = createTemporaryModule False st val + e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m + case e of + Left errs -> printErrors errs + Right (_, env') -> + case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of + Just (ty, _, _) -> liftIO . putStrLn . P.prettyPrintType $ ty + Nothing -> liftIO $ putStrLn "Could not find type" + +-- | Takes a type and prints its kind +handleKindOf + :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) + => P.Type + -> m () +handleKindOf typ = do + st <- get + let m = createTemporaryModuleForKind st typ + mName = P.ModuleName [P.ProperName "$PSCI"] + e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m + case e of + Left errs -> printErrors errs + Right (_, env') -> + case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of + Just (_, typ') -> do + let chk = (P.emptyCheckState env') { P.checkCurrentModule = Just mName } + k = check (P.kindOf typ') chk + + check :: StateT P.CheckState (ExceptT P.MultipleErrors (Writer P.MultipleErrors)) a -> P.CheckState -> Either P.MultipleErrors (a, P.CheckState) + check sew = fst . runWriter . runExceptT . runStateT sew + case k of + Left err -> printErrors err + Right (kind, _) -> liftIO . putStrLn . P.prettyPrintKind $ kind + Nothing -> liftIO $ putStrLn "Could not find kind" + +-- | Browse a module and displays its signature +handleBrowse + :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) + => P.ModuleName + -> m () +handleBrowse moduleName = do + st <- get + env <- asks psciEnvironment + if isModInEnv moduleName st + then liftIO . putStrLn $ printModuleSignatures moduleName env + else case lookupUnQualifiedModName moduleName st of + Just unQualifiedName -> + if isModInEnv unQualifiedName st + then liftIO . putStrLn $ printModuleSignatures unQualifiedName env + else failNotInEnv moduleName + Nothing -> + failNotInEnv moduleName + where + isModInEnv modName = + any ((== modName) . P.getModuleName . fst) . psciLoadedExterns + failNotInEnv modName = + liftIO $ putStrLn $ "Module '" ++ N.runModuleName modName ++ "' is not valid." + lookupUnQualifiedModName quaModName st = + (\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st) diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Interactive/Completion.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE DataKinds #-} + +module Language.PureScript.Interactive.Completion + ( CompletionM + , liftCompletionM + , completion + , completion' + ) where + +import Prelude.Compat + +import Control.Arrow (second) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.State.Class (MonadState(..)) +import Control.Monad.Trans.Reader (asks, runReaderT, ReaderT) +import Data.Function (on) +import Data.List (nub, nubBy, isPrefixOf, sortBy, stripPrefix) +import Data.Maybe (mapMaybe) +import qualified Language.PureScript as P +import qualified Language.PureScript.Interactive.Directive as D +import Language.PureScript.Interactive.Types +import qualified Language.PureScript.Names as N +import System.Console.Haskeline + +-- Completions may read the state, but not modify it. +type CompletionM = ReaderT PSCiState IO + +-- Lift a `CompletionM` action into a state monad. +liftCompletionM + :: (MonadState PSCiState m, MonadIO m) + => CompletionM a + -> m a +liftCompletionM act = do + st <- get + liftIO $ runReaderT act st + +-- Haskeline completions + +-- | Loads module, function, and file completions. +completion + :: (MonadState PSCiState m, MonadIO m) + => CompletionFunc m +completion = liftCompletionM . completion' + +completion' :: CompletionFunc CompletionM +completion' = completeWordWithPrev Nothing " \t\n\r" findCompletions + +-- | 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 + + 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)) + + completeDirectives :: String -> [String] + completeDirectives = map (':' :) . D.directiveStringsFor + + prefixedBy :: String -> String -> Maybe Completion + prefixedBy w cand = if w `isPrefixOf` cand + then Just (simpleCompletion cand) + else Nothing + + 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 + +data CompletionContext + = CtxDirective String + | CtxFilePath String + | CtxModule + | CtxIdentifier + | CtxType + | CtxFixed String + deriving (Show, Read) + +-- | +-- 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 _ 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"], _) -> [CtxModule] + _ -> [] + +headSatisfies :: (a -> Bool) -> [a] -> Bool +headSatisfies p str = + case str of + (c:_) -> p c + _ -> False + +getLoadedModules :: CompletionM [P.Module] +getLoadedModules = asks (map fst . psciLoadedExterns) + +getModuleNames :: CompletionM [String] +getModuleNames = moduleNames <$> getLoadedModules + +mapLoadedModulesAndQualify :: (a -> String) -> (P.Module -> [(a, P.Declaration)]) -> CompletionM [String] +mapLoadedModulesAndQualify sho f = do + ms <- getLoadedModules + let argPairs = do m <- ms + fm <- f m + return (m, fm) + concat <$> traverse (uncurry (getAllQualifications sho)) argPairs + +getIdentNames :: CompletionM [String] +getIdentNames = mapLoadedModulesAndQualify P.showIdent identNames + +getDctorNames :: CompletionM [String] +getDctorNames = mapLoadedModulesAndQualify P.runProperName dctorNames + +getTypeNames :: CompletionM [String] +getTypeNames = mapLoadedModulesAndQualify P.runProperName 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 :: (a -> String) -> P.Module -> (a, P.Declaration) -> CompletionM [String] +getAllQualifications sho 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 = P.showQualified sho (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 -> [q | referencedBy refs] + P.Hiding refs -> [q | not $ referencedBy refs] + + +-- | 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 'N.TypeName, P.Declaration)] +typeDecls = mapMaybe getTypeName . filter P.isDataDecl . P.exportedDeclarations + where + getTypeName :: P.Declaration -> Maybe (N.ProperName 'N.TypeName, 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 . concatMap getDeclNames . P.exportedDeclarations + where + getDeclNames :: P.Declaration -> [(P.Ident, P.Declaration)] + getDeclNames d@(P.ValueDeclaration ident _ _ _) = [(ident, d)] + getDeclNames d@(P.TypeDeclaration ident _ ) = [(ident, d)] + getDeclNames d@(P.ExternDeclaration ident _) = [(ident, d)] + getDeclNames d@(P.TypeClassDeclaration _ _ _ ds) = map (second (const d)) $ concatMap getDeclNames ds + getDeclNames (P.PositionedDeclaration _ _ d) = getDeclNames d + getDeclNames _ = [] + +dctorNames :: P.Module -> [(N.ProperName 'N.ConstructorName, P.Declaration)] +dctorNames = nubOnFst . concatMap go . P.exportedDeclarations + where + go :: P.Declaration -> [(N.ProperName 'N.ConstructorName, P.Declaration)] + go decl@(P.DataDeclaration _ _ _ ctors) = map (\n -> (n, decl)) (map fst ctors) + go (P.PositionedDeclaration _ _ d) = go d + go _ = [] + +moduleNames :: [P.Module] -> [String] +moduleNames = nub . map (P.runModuleName . P.getModuleName) diff --git a/src/Language/PureScript/Interactive/Directive.hs b/src/Language/PureScript/Interactive/Directive.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Interactive/Directive.hs @@ -0,0 +1,100 @@ +-- | +-- Directives for PSCI. +-- +module Language.PureScript.Interactive.Directive where + +import Prelude.Compat + +import Data.Maybe (fromJust, listToMaybe) +import Data.List (isPrefixOf) +import Data.Tuple (swap) + +import Language.PureScript.Interactive.Types + +-- | +-- List of all avaliable directives. +-- +directives :: [Directive] +directives = map fst directiveStrings + +-- | +-- A mapping of directives to the different strings that can be used to invoke +-- them. +-- +directiveStrings :: [(Directive, [String])] +directiveStrings = + [ (Help , ["?", "help"]) + , (Quit , ["quit"]) + , (Reset , ["reset"]) + , (Browse , ["browse"]) + , (Type , ["type"]) + , (Kind , ["kind"]) + , (Show , ["show"]) + ] + +-- | +-- Like directiveStrings, but the other way around. +-- +directiveStrings' :: [(String, Directive)] +directiveStrings' = concatMap go directiveStrings + where + go (dir, strs) = map (\s -> (s, dir)) strs + +-- | +-- List of all directive strings. +-- +strings :: [String] +strings = concatMap snd directiveStrings + +-- | +-- Returns all possible string representations of a directive. +-- +stringsFor :: Directive -> [String] +stringsFor d = fromJust (lookup d directiveStrings) + +-- | +-- Returns the default string representation of a directive. +-- +stringFor :: Directive -> String +stringFor = head . stringsFor + +-- | +-- Returns the list of directives which could be expanded from the string +-- argument, together with the string alias that matched. +-- +directivesFor' :: String -> [(Directive, String)] +directivesFor' str = go directiveStrings' + where + go = map swap . filter ((str `isPrefixOf`) . fst) + +directivesFor :: String -> [Directive] +directivesFor = map fst . directivesFor' + +directiveStringsFor :: String -> [String] +directiveStringsFor = map snd . directivesFor' + +parseDirective :: String -> Maybe Directive +parseDirective = listToMaybe . directivesFor + +-- | +-- 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. +-- +help :: [(Directive, String, String)] +help = + [ (Help, "", "Show this help menu") + , (Quit, "", "Quit PSCi") + , (Reset, "", "Discard all imported modules and declared bindings") + , (Browse, "", "See all functions in ") + , (Type, "", "Show the type of ") + , (Kind, "", "Show the kind of ") + , (Show, "import", "Show all imported modules") + , (Show, "loaded", "Show all loaded modules") + ] diff --git a/src/Language/PureScript/Interactive/IO.hs b/src/Language/PureScript/Interactive/IO.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Interactive/IO.hs @@ -0,0 +1,41 @@ +module Language.PureScript.Interactive.IO where + +import Prelude.Compat + +import Control.Monad (msum) +import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +import System.Directory (createDirectoryIfMissing, getHomeDirectory, findExecutable) +import System.FilePath (takeDirectory, (), isPathSeparator) + +mkdirp :: FilePath -> IO () +mkdirp = createDirectoryIfMissing True . takeDirectory + +-- File helpers + +onFirstFileMatching :: Monad m => (b -> m (Maybe a)) -> [b] -> m (Maybe a) +onFirstFileMatching f pathVariants = runMaybeT . msum $ map (MaybeT . f) pathVariants + +-- | +-- Locates the node executable. +-- Checks for either @nodejs@ or @node@. +-- +findNodeProcess :: IO (Maybe String) +findNodeProcess = onFirstFileMatching findExecutable names + where names = ["nodejs", "node"] + +-- | +-- Grabs the filename where the history is stored. +-- +getHistoryFilename :: IO FilePath +getHistoryFilename = do + home <- getHomeDirectory + let filename = home ".purescript" "psci_history" + mkdirp filename + return filename + +-- | +-- Expands tilde in path. +-- +expandTilde :: FilePath -> IO FilePath +expandTilde ('~':p:rest) | isPathSeparator p = ( rest) <$> getHomeDirectory +expandTilde p = return p diff --git a/src/Language/PureScript/Interactive/Message.hs b/src/Language/PureScript/Interactive/Message.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Interactive/Message.hs @@ -0,0 +1,52 @@ +module Language.PureScript.Interactive.Message where + +import Prelude.Compat + +import Data.List (intercalate) +import Data.Version (showVersion) +import qualified Paths_purescript as Paths +import qualified Language.PureScript.Interactive.Directive as D +import Language.PureScript.Interactive.Types + +-- Messages + +-- | The help message. +helpMessage :: String +helpMessage = "The following commands are available:\n\n " ++ + intercalate "\n " (map line D.help) ++ + "\n\n" ++ extraHelp + where + line :: (Directive, String, String) -> String + line (dir, arg, desc) = + let cmd = ':' : D.stringFor dir + in unwords [ 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. +prologueMessage :: String +prologueMessage = unlines + [ "PSCi, version " ++ showVersion Paths.version + , "Type :? for help" + ] + +supportModuleMessage :: String +supportModuleMessage = unlines + [ "PSCi requires the purescript-psci-support package to be installed." + , "You can install it using Bower as follows:" + , "" + , " bower i purescript-psci-support --save-dev" + , "" + , "For help getting started, visit http://wiki.purescript.org/PSCi" + ] + +-- | The quit message. +quitMessage :: String +quitMessage = "See ya!" diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Interactive/Module.hs @@ -0,0 +1,99 @@ +module Language.PureScript.Interactive.Module where + +import Prelude.Compat + +import Control.Monad +import qualified Language.PureScript as P +import Language.PureScript.Interactive.Types +import System.FilePath (pathSeparator) +import System.IO.UTF8 (readUTF8File) + +-- * Support Module + +-- | The name of the PSCI support module +supportModuleName :: P.ModuleName +supportModuleName = P.moduleNameFromString "PSCI.Support" + +-- | Checks if the Console module is defined +supportModuleIsDefined :: [P.Module] -> Bool +supportModuleIsDefined = any ((== supportModuleName) . P.getModuleName) + +-- * Module Management + +-- | +-- Loads a file for use with imports. +-- +loadModule :: FilePath -> IO (Either String [P.Module]) +loadModule filename = do + content <- readUTF8File filename + return $ either (Left . P.prettyPrintMultipleErrors P.defaultPPEOptions) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)] + +-- | +-- Load all modules. +-- +loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)]) +loadAllModules files = do + filesAndContent <- forM files $ \filename -> do + content <- readUTF8File filename + return (filename, content) + return $ P.parseModulesFromFiles id filesAndContent + +-- | +-- Makes a volatile module to execute the current expression. +-- +createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module +createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindings = lets} val = + let + moduleName = P.ModuleName [P.ProperName "$PSCI"] + effModuleName = P.moduleNameFromString "Control.Monad.Eff" + effImport = (effModuleName, P.Implicit, Just (P.ModuleName [P.ProperName "$Eff"])) + supportImport = (supportModuleName, P.Implicit, Just (P.ModuleName [P.ProperName "$Support"])) + eval = P.Var (P.Qualified (Just (P.ModuleName [P.ProperName "$Support"])) (P.Ident "eval")) + mainValue = P.App eval (P.Var (P.Qualified Nothing (P.Ident "it"))) + itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] $ Right val + typeDecl = P.TypeDeclaration (P.Ident "$main") + (P.TypeApp + (P.TypeApp + (P.TypeConstructor + (P.Qualified (Just (P.ModuleName [P.ProperName "$Eff"])) (P.ProperName "Eff"))) + (P.TypeWildcard internalSpan)) + (P.TypeWildcard internalSpan)) + mainDecl = P.ValueDeclaration (P.Ident "$main") P.Public [] $ Right mainValue + decls = if exec then [itDecl, typeDecl, mainDecl] else [itDecl] + internalSpan = P.internalModuleSourceSpan "" + in + P.Module internalSpan + [] moduleName + ((importDecl `map` (effImport : supportImport : imports)) ++ lets ++ decls) + Nothing + + +-- | +-- Makes a volatile module to hold a non-qualified type synonym for a fully-qualified data type declaration. +-- +createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module +createTemporaryModuleForKind PSCiState{psciImportedModules = imports, psciLetBindings = lets} typ = + let + moduleName = P.ModuleName [P.ProperName "$PSCI"] + itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ + in + P.Module (P.internalModuleSourceSpan "") [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing + +-- | +-- Makes a volatile module to execute the current imports. +-- +createTemporaryModuleForImports :: PSCiState -> P.Module +createTemporaryModuleForImports PSCiState{psciImportedModules = imports} = + let + moduleName = P.ModuleName [P.ProperName "$PSCI"] + in + P.Module (P.internalModuleSourceSpan "") [] moduleName (importDecl `map` imports) Nothing + +importDecl :: ImportedModule -> P.Declaration +importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ + +indexFile :: FilePath +indexFile = ".psci_modules" ++ pathSeparator : "index.js" + +modulesDir :: FilePath +modulesDir = ".psci_modules" ++ pathSeparator : "node_modules" diff --git a/src/Language/PureScript/Interactive/Parser.hs b/src/Language/PureScript/Interactive/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Interactive/Parser.hs @@ -0,0 +1,122 @@ +-- | +-- Parser for PSCI. +-- +module Language.PureScript.Interactive.Parser + ( parseCommand + ) where + +import Prelude.Compat hiding (lex) + +import Data.Char (isSpace) +import Data.List (intercalate) +import Text.Parsec hiding ((<|>)) +import qualified Language.PureScript as P +import qualified Language.PureScript.Interactive.Directive as D +import Language.PureScript.Interactive.Types +import Language.PureScript.Parser.Common (mark, same) + +-- | +-- Parses PSCI metacommands or expressions input from the user. +-- +parseCommand :: String -> Either String Command +parseCommand cmdString = + case cmdString of + (':' : cmd) -> parseDirective cmd + _ -> parseRest psciCommand cmdString + +parseRest :: P.TokenParser a -> String -> Either String a +parseRest p s = either (Left . show) Right $ do + ts <- P.lex "" s + P.runTokenParser "" (p <* eof) ts + +psciCommand :: P.TokenParser Command +psciCommand = choice (map try parsers) + where + parsers = + [ psciLet + , psciImport + , psciOtherDeclaration + , psciExpression + ] + +trim :: String -> String +trim = trimEnd . trimStart + +trimStart :: String -> String +trimStart = dropWhile isSpace + +trimEnd :: String -> String +trimEnd = reverse . trimStart . reverse + +parseDirective :: String -> Either String Command +parseDirective cmd = + case D.directivesFor' dstr of + [(d, _)] -> commandFor d + [] -> Left "Unrecognized directive. Type :? for help." + ds -> Left ("Ambiguous directive. Possible matches: " ++ + intercalate ", " (map snd ds) ++ ". Type :? for help.") + where + (dstr, arg) = break isSpace cmd + + commandFor d = case d of + Help -> return ShowHelp + Quit -> return QuitPSCi + Reset -> return ResetState + Browse -> BrowseModule <$> parseRest P.moduleName arg + 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 Command +psciExpression = Expression <$> P.parseValue + +-- | +-- PSCI version of @let@. +-- This is essentially let from do-notation. +-- However, since we don't support the @Eff@ monad, +-- we actually want the normal @let@. +-- +psciLet :: P.TokenParser Command +psciLet = Decls <$> (P.reserved "let" *> P.indented *> manyDecls) + where + manyDecls :: P.TokenParser [P.Declaration] + manyDecls = mark (many1 (same *> P.parseLocalDeclaration)) + +-- | Imports must be handled separately from other declarations, so that +-- :show import works, for example. +psciImport :: P.TokenParser Command +psciImport = do + (mn, declType, asQ) <- P.parseImportDeclaration' + return $ Import (mn, declType, asQ) + +-- | Any other declaration that we don't need a 'special case' parser for +-- (like let or import declarations). +psciOtherDeclaration :: P.TokenParser Command +psciOtherDeclaration = Decls . (:[]) <$> do + decl <- discardPositionInfo <$> P.parseDeclaration + if acceptable decl + then return decl + else fail "this kind of declaration is not supported in psci" + +discardPositionInfo :: P.Declaration -> P.Declaration +discardPositionInfo (P.PositionedDeclaration _ _ d) = d +discardPositionInfo d = d + +acceptable :: P.Declaration -> Bool +acceptable P.DataDeclaration{} = True +acceptable P.TypeSynonymDeclaration{} = True +acceptable P.ExternDeclaration{} = True +acceptable P.ExternDataDeclaration{} = 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/src/Language/PureScript/Interactive/Printer.hs b/src/Language/PureScript/Interactive/Printer.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Interactive/Printer.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DataKinds #-} + +module Language.PureScript.Interactive.Printer where + +import Prelude.Compat + +import Data.List (intersperse) +import qualified Data.Map as M +import Data.Maybe (mapMaybe) +import qualified Language.PureScript as P +import qualified Text.PrettyPrint.Boxes as Box + +-- Printers + +-- | +-- Pretty print a module's signatures +-- +printModuleSignatures :: P.ModuleName -> P.Environment -> String +printModuleSignatures moduleName (P.Environment {..}) = + -- get relevant components of a module from environment + let moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) names + moduleTypeClasses = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) typeClasses + moduleTypes = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) types + + in + -- print each component + (unlines . map trimEnd . lines . Box.render . Box.vsep 1 Box.left) + [ printModule's (mapMaybe (showTypeClass . findTypeClass typeClasses)) moduleTypeClasses -- typeClasses + , printModule's (mapMaybe (showType typeClasses dataConstructors typeSynonyms . findType types)) moduleTypes -- types + , printModule's (map (showNameType . findNameType names)) moduleNamesIdent -- functions + ] + + where printModule's showF = Box.vsep 1 Box.left . showF + + findNameType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) + findNameType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames) + + showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box + showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType + showNameType _ = P.internalError "The impossible happened in printModuleSignatures." + + findTypeClass + :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]) + -> P.Qualified (P.ProperName 'P.ClassName) + -> (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])) + findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses) + + showTypeClass + :: (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])) + -> Maybe Box.Box + showTypeClass (_, Nothing) = Nothing + showTypeClass (P.Qualified _ name, Just (vars, body, constrs)) = + let constraints = + if null constrs + then Box.text "" + else Box.text "(" + Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Constraint (P.Qualified _ pn) lt _) -> Box.text (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) constrs) + Box.<> Box.text ") <= " + className = + Box.text (P.runProperName name) + Box.<> Box.text (concatMap ((' ':) . fst) vars) + classBody = + Box.vcat Box.top (map (\(i, t) -> Box.text (P.showIdent i ++ " ::") Box.<+> P.typeAsBox t) body) + + in + Just $ + (Box.text "class " + Box.<> constraints + Box.<> className + Box.<+> if null body then Box.text "" else Box.text "where") + Box.// Box.moveRight 2 classBody + + + findType + :: M.Map (P.Qualified (P.ProperName 'P.TypeName)) (P.Kind, P.TypeKind) + -> P.Qualified (P.ProperName 'P.TypeName) + -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind)) + findType envTypes name = (name, M.lookup name envTypes) + + showType + :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]) + -> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.Type, [P.Ident]) + -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(String, Maybe P.Kind)], P.Type) + -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind)) + -> Maybe Box.Box + showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) = + case (typ, M.lookup n typeSynonymsEnv) of + (Just (_, P.TypeSynonym), Just (typevars, dtType)) -> + if M.member (fmap P.coerceProperName n) typeClassesEnv + then + Nothing + else + Just $ + Box.text ("type " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars) + Box.// Box.moveRight 2 (Box.text "=" Box.<+> P.typeAsBox dtType) + + (Just (_, P.DataType typevars pt), _) -> + let prefix = + case pt of + [(dtProperName,_)] -> + case M.lookup (P.Qualified modul dtProperName) dataConstructorsEnv of + Just (dataDeclType, _, _, _) -> P.showDataDeclType dataDeclType + _ -> "data" + _ -> "data" + + in + Just $ Box.text (prefix ++ " " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars) Box.// printCons pt + + _ -> + Nothing + + where printCons pt = + Box.moveRight 2 $ + Box.vcat Box.left $ + mapFirstRest (Box.text "=" Box.<+>) (Box.text "|" Box.<+>) $ + map (\(cons,idents) -> (Box.text (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents))) pt + + prettyPrintType t = Box.text " " Box.<> P.typeAtomAsBox t + + mapFirstRest _ _ [] = [] + mapFirstRest f g (x:xs) = f x : map g xs + + trimEnd = reverse . dropWhile (== ' ') . reverse diff --git a/src/Language/PureScript/Interactive/Types.hs b/src/Language/PureScript/Interactive/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Interactive/Types.hs @@ -0,0 +1,146 @@ +-- | +-- Type declarations and associated basic functions for PSCI. +-- +module Language.PureScript.Interactive.Types where + +import Prelude.Compat + +import qualified Language.PureScript as P + +-- | The PSCI configuration. +-- +-- These configuration values do not change during execution. +-- +data PSCiConfig = PSCiConfig + { psciLoadedFiles :: [FilePath] + , psciNodeFlags :: [String] + , psciEnvironment :: P.Environment + } deriving Show + +-- | 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 + { psciImportedModules :: [ImportedModule] + , psciLetBindings :: [P.Declaration] + , psciLoadedExterns :: [(P.Module, P.ExternsFile)] + } deriving Show + +initialPSCiState :: PSCiState +initialPSCiState = PSCiState [] [] [] + +-- | 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 imported modules in the state record. +updateImportedModules :: ([ImportedModule] -> [ImportedModule]) -> PSCiState -> PSCiState +updateImportedModules f st = st { psciImportedModules = f (psciImportedModules st) } + +-- | Updates the loaded externs files in the state record. +updateLoadedExterns :: ([(P.Module, P.ExternsFile)] -> [(P.Module, P.ExternsFile)]) -> PSCiState -> PSCiState +updateLoadedExterns f st = st { psciLoadedExterns = f (psciLoadedExterns st) } + +-- | Updates the let bindings in the state record. +updateLets :: ([P.Declaration] -> [P.Declaration]) -> PSCiState -> PSCiState +updateLets f st = st { psciLetBindings = f (psciLetBindings st) } + +-- * Commands + +-- | +-- 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 + -- | + -- 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 + | Type + | Kind + | Show + deriving (Eq, Show) diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs --- a/src/Language/PureScript/Kinds.hs +++ b/src/Language/PureScript/Kinds.hs @@ -2,35 +2,24 @@ module Language.PureScript.Kinds where -import Prelude () import Prelude.Compat import qualified Data.Aeson.TH as A --- | --- The data type of kinds --- +-- | The data type of kinds data Kind - -- | - -- Unification variable of type Kind - -- + -- | Unification variable of type Kind = KUnknown Int - -- | - -- The kind of types - -- + -- | The kind of types | Star - -- | - -- The kind of effects - -- + -- | The kind of effects | Bang - -- | - -- Kinds for labelled, unordered rows without duplicates - -- + -- | Kinds for labelled, unordered rows without duplicates | Row Kind - -- | - -- Function kinds - -- + -- | Function kinds | FunKind Kind Kind + -- | Type-level strings + | Symbol deriving (Show, Read, Eq, Ord) $(A.deriveJSON A.defaultOptions ''Kind) diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -1,30 +1,24 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE PatternGuards #-} - -- | -- This module implements a simple linting pass on the PureScript AST. -- module Language.PureScript.Linter (lint, module L) where -import Prelude () import Prelude.Compat +import Control.Monad.Writer.Class + import Data.List (nub, (\\)) import Data.Maybe (mapMaybe) import Data.Monoid - import qualified Data.Set as S -import Control.Monad.Writer.Class - -import Language.PureScript.Crash import Language.PureScript.AST -import Language.PureScript.Names +import Language.PureScript.Crash import Language.PureScript.Errors -import Language.PureScript.Types import Language.PureScript.Linter.Exhaustive as L import Language.PureScript.Linter.Imports as L +import Language.PureScript.Names +import Language.PureScript.Types -- | Lint the PureScript AST. -- | @@ -46,7 +40,7 @@ lintDeclaration :: Declaration -> m () lintDeclaration = tell . f where - (warningsInDecl, _, _, _, _) = everythingWithScope stepD stepE stepB (\_ _ -> mempty) stepDo + (warningsInDecl, _, _, _, _) = everythingWithScope (\_ _ -> mempty) stepE stepB (\_ _ -> mempty) stepDo f :: Declaration -> MultipleErrors f (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f dec) @@ -54,16 +48,6 @@ f (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars ty) f dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec - stepD :: S.Set Ident -> Declaration -> MultipleErrors - stepD _ (ValueDeclaration (Op name) _ _ _) = errorMessage (DeprecatedOperatorDecl name) - stepD _ (TypeClassDeclaration _ _ _ decls) = foldMap go decls - where - go :: Declaration -> MultipleErrors - go (PositionedDeclaration _ _ d') = go d' - go (TypeDeclaration (Op name) _) = errorMessage (DeprecatedOperatorDecl name) - go _ = mempty - stepD _ _ = mempty - stepE :: S.Set Ident -> Expr -> MultipleErrors stepE s (Abs (Left name) _) | name `S.member` s = errorMessage (ShadowedName name) stepE s (Let ds' _) = foldMap go ds' @@ -71,7 +55,6 @@ go d | Just i <- getDeclIdent d , i `S.member` s = errorMessage (ShadowedName i) | otherwise = mempty - stepE _ (OperatorSection op val) = errorMessage $ DeprecatedOperatorSection op val stepE _ _ = mempty stepB :: S.Set Ident -> Binder -> MultipleErrors diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -1,36 +1,38 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - -- | -- Module for exhaustivity checking over pattern matching definitions -- The algorithm analyses the clauses of a definition one by one from top -- to bottom, where in each step it has the cases already missing (uncovered), -- and it generates the new set of missing cases. -- -module Language.PureScript.Linter.Exhaustive (checkExhaustiveModule) where +module Language.PureScript.Linter.Exhaustive + ( checkExhaustiveExpr + ) where -import Prelude () import Prelude.Compat -import qualified Data.Map as M -import Data.Maybe (fromMaybe) -import Data.List (foldl', sortBy, nub) -import Data.Function (on) - -import Control.Monad (unless) import Control.Applicative import Control.Arrow (first, second) +import Control.Monad (unless) import Control.Monad.Writer.Class +import Control.Monad.Supply.Class (MonadSupply, fresh, freshName) -import Language.PureScript.Crash +import Data.Function (on) +import Data.List (foldl', sortBy, nub) +import Data.Maybe (fromMaybe) +import qualified Data.Map as M + import Language.PureScript.AST.Binders -import Language.PureScript.AST.Literals import Language.PureScript.AST.Declarations +import Language.PureScript.AST.Literals +import Language.PureScript.Crash import Language.PureScript.Environment -import Language.PureScript.Names as P +import Language.PureScript.Errors import Language.PureScript.Kinds +import Language.PureScript.Names as P +import Language.PureScript.Pretty.Values (prettyPrintBinderAtom) +import Language.PureScript.Traversals import Language.PureScript.Types as P -import Language.PureScript.Errors +import qualified Language.PureScript.Constants as C -- | There are two modes of failure for the redundancy check: -- @@ -44,7 +46,7 @@ -- Qualifies a propername from a given qualified propername and a default module name -- qualifyName - :: (ProperName a) + :: ProperName a -> ModuleName -> Qualified (ProperName b) -> Qualified (ProperName a) @@ -179,12 +181,11 @@ missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedundancyError Bool) missingCasesMultiple env mn = go where - go [] [] = ([], pure True) go (x:xs) (y:ys) = (map (: xs) miss1 ++ map (x :) miss2, liftA2 (&&) pr1 pr2) where (miss1, pr1) = missingCasesSingle env mn x y (miss2, pr2) = go xs ys - go _ _ = internalError "Argument lengths did not match in missingCasesMultiple." + go _ _ = ([], pure True) -- | -- Guard handling @@ -229,8 +230,16 @@ -- it partitions that set with the new uncovered cases, until it consumes the whole set of clauses. -- Then, returns the uncovered set of case alternatives. -- -checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Bool -> Environment -> ModuleName -> Int -> [CaseAlternative] -> m () -checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas +checkExhaustive + :: forall m + . (MonadWriter MultipleErrors m, MonadSupply m) + => Environment + -> ModuleName + -> Int + -> [CaseAlternative] + -> Expr + -> m Expr +checkExhaustive env mn numArgs cas expr = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas where step :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedundancyError Bool, [[Binder]])) step (uncovered, (nec, redundant)) ca = @@ -246,69 +255,91 @@ ) ) - makeResult :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> m () + makeResult :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> m Expr makeResult (bss, (rr, bss')) = - do unless (hasConstraint || null bss) tellNonExhaustive - unless (null bss') tellRedundant + do unless (null bss') tellRedundant case rr of - Left Incomplete -> unless hasConstraint tellIncomplete + Left Incomplete -> tellIncomplete _ -> return () + if null bss + then return expr + else addPartialConstraint (second null (splitAt 5 bss)) expr where - tellNonExhaustive = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss - tellRedundant = tell . errorMessage . uncurry OverlappingPattern . second null . splitAt 5 $ bss' - tellIncomplete = tell . errorMessage $ IncompleteExhaustivityCheck + tellRedundant = tell . errorMessage . uncurry OverlappingPattern . second null . splitAt 5 $ bss' + tellIncomplete = tell . errorMessage $ IncompleteExhaustivityCheck --- | --- Exhaustivity checking over a list of declarations --- -checkExhaustiveDecls :: forall m. MonadWriter MultipleErrors m => Environment -> ModuleName -> [Declaration] -> m () -checkExhaustiveDecls env mn = mapM_ onDecl - where - onDecl :: Declaration -> m () - onDecl (BindingGroupDeclaration bs) = mapM_ (onDecl . convert) bs + -- | We add a Partial constraint by adding a call to the following identity function: + -- + -- partial :: forall a. Partial => a -> a + -- + -- The binder information is provided so that it can be embedded in the constraint, + -- and then included in the error message. + addPartialConstraint :: MonadSupply m => ([[Binder]], Bool) -> Expr -> m Expr + addPartialConstraint (bss, complete) e = do + tyVar <- ("p" ++) . show <$> fresh + var <- freshName + return $ + Let + [ partial var tyVar ] + $ App (Var (Qualified Nothing (Ident C.__unused))) e where - convert :: (Ident, NameKind, Expr) -> Declaration - convert (name, nk, e) = ValueDeclaration name nk [] (Right e) - onDecl (ValueDeclaration name _ _ (Right e)) = censor (addHint (ErrorInValueDeclaration name)) (onExpr False e) - onDecl (PositionedDeclaration pos _ dec) = censor (addHint (PositionedError pos)) (onDecl dec) - onDecl _ = return () - - onExpr :: Bool -> Expr -> m () - onExpr isP (UnaryMinus e) = onExpr isP e - onExpr isP (Literal (ArrayLiteral es)) = mapM_ (onExpr isP) es - onExpr isP (Literal (ObjectLiteral es)) = mapM_ (onExpr isP . snd) es - onExpr isP (TypeClassDictionaryConstructorApp _ e) = onExpr isP e - onExpr isP (Accessor _ e) = onExpr isP e - onExpr isP (ObjectUpdate o es) = onExpr isP o >> mapM_ (onExpr isP . snd) es - onExpr isP (Abs _ e) = onExpr isP e - onExpr isP (App e1 e2) = onExpr isP e1 >> onExpr isP e2 - onExpr isP (IfThenElse e1 e2 e3) = onExpr isP e1 >> onExpr isP e2 >> onExpr isP e3 - onExpr isP (Case es cas) = checkExhaustive isP env mn (length es) cas >> mapM_ (onExpr isP) es >> mapM_ (onCaseAlternative isP) cas - onExpr isP (TypedValue _ e ty) = onExpr (isP || hasPartialConstraint ty) e - onExpr isP (Let ds e) = mapM_ onDecl ds >> onExpr isP e - onExpr isP (PositionedValue pos _ e) = censor (addHint (PositionedError pos)) (onExpr isP e) - onExpr _ _ = return () + partial :: String -> String -> Declaration + partial var tyVar = + ValueDeclaration (Ident C.__unused) Private [] $ Right $ + TypedValue + True + (Abs (Left (Ident var)) (Var (Qualified Nothing (Ident var)))) + (ty tyVar) - onCaseAlternative :: Bool -> CaseAlternative -> m () - onCaseAlternative isP (CaseAlternative _ (Left es)) = mapM_ (\(e, g) -> onExpr isP e >> onExpr isP g) es - onCaseAlternative isP (CaseAlternative _ (Right e)) = onExpr isP e + ty :: String -> Type + ty tyVar = + ForAll tyVar + ( ConstrainedType + [ Constraint C.Partial [] (Just constraintData) ] + $ TypeApp (TypeApp tyFunction (TypeVar tyVar)) (TypeVar tyVar) + ) + Nothing - hasPartialConstraint :: Type -> Bool - hasPartialConstraint (ConstrainedType cs _) = any (go . fst) cs - where - go :: Qualified (ProperName 'ClassName) -> Bool - go qname - | qname == partialClass = True - | otherwise = - case qname `M.lookup` typeClasses env of - Just ([], _, cs') -> any (go . fst) cs' - _ -> False - partialClass :: Qualified (ProperName 'ClassName) - partialClass = primName "Partial" - hasPartialConstraint _ = False + constraintData :: ConstraintData + constraintData = + PartialConstraintData (map (map prettyPrintBinderAtom) bss) complete -- | --- Exhaustivity checking over a single module +-- Exhaustivity checking -- -checkExhaustiveModule :: forall m. MonadWriter MultipleErrors m => Environment -> Module -> m () -checkExhaustiveModule env (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ checkExhaustiveDecls env mn ds +checkExhaustiveExpr + :: forall m + . (MonadWriter MultipleErrors m, MonadSupply m) + => Environment + -> ModuleName + -> Expr + -> m Expr +checkExhaustiveExpr env mn = onExpr + where + onDecl :: Declaration -> m Declaration + onDecl (BindingGroupDeclaration bs) = BindingGroupDeclaration <$> mapM (thirdM onExpr) bs + onDecl (ValueDeclaration name x y (Right e)) = ValueDeclaration name x y . Right <$> censor (addHint (ErrorInValueDeclaration name)) (onExpr e) + onDecl (PositionedDeclaration pos x dec) = PositionedDeclaration pos x <$> censor (addHint (PositionedError pos)) (onDecl dec) + onDecl decl = return decl + + onExpr :: Expr -> m Expr + onExpr (UnaryMinus e) = UnaryMinus <$> onExpr e + onExpr (Literal (ArrayLiteral es)) = Literal . ArrayLiteral <$> mapM onExpr es + onExpr (Literal (ObjectLiteral es)) = Literal . ObjectLiteral <$> mapM (sndM onExpr) es + onExpr (TypeClassDictionaryConstructorApp x e) = TypeClassDictionaryConstructorApp x <$> onExpr e + onExpr (Accessor x e) = Accessor x <$> onExpr e + onExpr (ObjectUpdate o es) = ObjectUpdate <$> onExpr o <*> mapM (sndM onExpr) es + onExpr (Abs x e) = Abs x <$> onExpr e + onExpr (App e1 e2) = App <$> onExpr e1 <*> onExpr e2 + onExpr (IfThenElse e1 e2 e3) = IfThenElse <$> onExpr e1 <*> onExpr e2 <*> onExpr e3 + onExpr (Case es cas) = do + case' <- Case <$> mapM onExpr es <*> mapM onCaseAlternative cas + checkExhaustive env mn (length es) cas case' + onExpr (TypedValue x e y) = TypedValue x <$> onExpr e <*> pure y + onExpr (Let ds e) = Let <$> mapM onDecl ds <*> onExpr e + onExpr (PositionedValue pos x e) = PositionedValue pos x <$> censor (addHint (PositionedError pos)) (onExpr e) + onExpr expr = return expr + + onCaseAlternative :: CaseAlternative -> m CaseAlternative + onCaseAlternative (CaseAlternative x (Left es)) = CaseAlternative x . Left <$> mapM (\(e, g) -> (,) <$> onExpr e <*> onExpr g) es + onCaseAlternative (CaseAlternative x (Right e)) = CaseAlternative x . Right <$> onExpr e diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -1,63 +1,37 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} - module Language.PureScript.Linter.Imports ( lintImports , Name(..) , UsedImports() ) where -import Prelude () import Prelude.Compat -import Control.Monad (unless, when) -import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad (join, unless, foldM, (<=<)) import Control.Monad.Writer.Class -import Data.Foldable (forM_) -import Data.List ((\\), find, intersect, nub) -import Data.Maybe (mapMaybe) +import Data.Function (on) +import Data.Foldable (for_) +import Data.List (find, intersect, nub, groupBy, sortBy, (\\)) +import Data.Maybe (mapMaybe, fromMaybe) import Data.Monoid (Sum(..)) +import Data.Traversable (forM) import qualified Data.Map as M import Language.PureScript.AST.Declarations import Language.PureScript.AST.SourcePos import Language.PureScript.Crash -import Language.PureScript.Names as P - import Language.PureScript.Errors +import Language.PureScript.Names +import Language.PureScript.Sugar.Names.Common (warnDuplicateRefs) import Language.PureScript.Sugar.Names.Env import Language.PureScript.Sugar.Names.Imports - import qualified Language.PureScript.Constants as C --- | Imported name used in some type or expression. -data Name - = IdentName (Qualified Ident) - | TyName (Qualified (ProperName 'TypeName)) - | TyOpName (Qualified Ident) - | DctorName (Qualified (ProperName 'ConstructorName)) - | TyClassName (Qualified (ProperName 'ClassName)) - deriving (Eq, Show) - -getIdentName :: Maybe ModuleName -> Name -> Maybe Ident -getIdentName q (IdentName (Qualified q' name)) | q == q' = Just name -getIdentName _ _ = Nothing - -getTypeOpName :: Maybe ModuleName -> Name -> Maybe Ident -getTypeOpName q (TyOpName (Qualified q' name)) | q == q' = Just name -getTypeOpName _ _ = Nothing - -getTypeName :: Maybe ModuleName -> Name -> Maybe (ProperName 'TypeName) -getTypeName q (TyName (Qualified q' name)) | q == q' = Just name -getTypeName _ _ = Nothing - -getClassName :: Maybe ModuleName -> Name -> Maybe (ProperName 'ClassName) -getClassName q (TyClassName (Qualified q' name)) | q == q' = Just name -getClassName _ _ = Nothing - --- | Map of module name to list of imported names from that module which have been used. -type UsedImports = M.Map ModuleName [Name] +-- | +-- Map of module name to list of imported names from that module which have +-- been used. +-- +type UsedImports = M.Map ModuleName [Qualified Name] -- | -- Find and warn on: @@ -75,46 +49,79 @@ -- lintImports :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . MonadWriter MultipleErrors m => Module -> Env -> UsedImports -> m () -lintImports (Module _ _ mn mdecls mexports) env usedImps = do +lintImports (Module _ _ _ _ Nothing) _ _ = + internalError "lintImports needs desugared exports" +lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do - let scope = maybe nullImports (\(_, imps, _) -> imps) (M.lookup mn env) + -- TODO: this needs some work to be easier to understand + + let scope = maybe primImports (\(_, imps', _) -> imps') (M.lookup mn env) usedImps' = foldr (elaborateUsed scope) usedImps exportedModules numOpenImports = getSum $ foldMap (Sum . countOpenImports) mdecls allowImplicit = numOpenImports == 1 - - imps <- M.toAscList <$> findImports mdecls + imports = M.toAscList (findImports mdecls) - forM_ imps $ \(mni, decls) -> - unless (isPrim mni) $ do - forM_ decls $ \(ss, declType, qualifierName) -> - censor (onErrorMessages $ addModuleLocError ss) $ do + for_ imports $ \(mni, decls) -> + unless (isPrim mni) $ + for_ decls $ \(ss', declType, qualifierName) -> + maybe id warnWithPosition ss' $ do let names = nub $ M.findWithDefault [] mni usedImps' lintImportDecl env mni qualifierName names declType allowImplicit - forM_ (M.toAscList (byQual imps)) $ \(mnq, entries) -> do + for_ (M.toAscList (byQual imports)) $ \(mnq, entries) -> do let mnis = nub $ map (\(_, _, mni) -> mni) entries unless (length mnis == 1) $ do let implicits = filter (\(_, declType, _) -> not $ isExplicit declType) entries - forM_ implicits $ \(ss, _, mni) -> - censor (onErrorMessages $ addModuleLocError ss) $ do + for_ implicits $ \(ss', _, mni) -> + maybe id warnWithPosition ss' $ do let names = nub $ M.findWithDefault [] mni usedImps' usedRefs = findUsedRefs env mni (Just mnq) names unless (null usedRefs) $ tell $ errorMessage $ ImplicitQualifiedImport mni mnq usedRefs - return () + for_ imports $ \(mnq, imps) -> do + warned <- foldM (checkDuplicateImports mnq) [] (selfCartesianSubset imps) + + let unwarned = imps \\ warned + duplicates + = join + . map tail + . filter ((> 1) . length) + . groupBy ((==) `on` defQual) + . sortBy (compare `on` defQual) + $ unwarned + + for_ duplicates $ \(pos, _, _) -> + maybe id warnWithPosition pos $ + tell $ errorMessage $ DuplicateSelectiveImport mnq + + for_ (imps \\ (warned ++ duplicates)) $ \(pos, typ, _) -> + warnDuplicateRefs (fromMaybe ss pos) DuplicateImportRef $ case typ of + Explicit refs -> refs + Hiding refs -> refs + _ -> [] + where + defQual :: ImportDef -> Maybe ModuleName + defQual (_, _, q) = q + + selfCartesianSubset :: [a] -> [(a, a)] + selfCartesianSubset (x : xs) = [(x, y) | y <- xs] ++ selfCartesianSubset xs + selfCartesianSubset [] = [] + countOpenImports :: Declaration -> Int - countOpenImports (ImportDeclaration mn' Implicit Nothing _) | not (isPrim mn') = 1 - countOpenImports (ImportDeclaration mn' (Hiding _) Nothing _) | not (isPrim mn') = 1 countOpenImports (PositionedDeclaration _ _ d) = countOpenImports d + countOpenImports (ImportDeclaration mn' Implicit Nothing) + | not (isPrim mn' || mn == mn') = 1 + countOpenImports (ImportDeclaration mn' (Hiding _) Nothing) + | not (isPrim mn' || mn == mn') = 1 countOpenImports _ = 0 -- Checks whether a module is the Prim module - used to suppress any checks @@ -131,15 +138,15 @@ byQual = foldr goImp M.empty where goImp (mni, xs) acc = foldr (goDecl mni) acc xs - goDecl mni (ss, declType, Just qmn) acc = - let entry = (ss, declType, mni) + goDecl mni (ss', declType, Just qmn) acc = + let entry = (ss', declType, mni) in M.alter (Just . maybe [entry] (entry :)) qmn acc goDecl _ _ acc = acc -- The list of modules that are being re-exported by the current module. Any -- module that appears in this list is always considered to be used. exportedModules :: [ModuleName] - exportedModules = nub $ maybe [] (mapMaybe extractModule) mexports + exportedModules = nub $ mapMaybe extractModule mexports where extractModule (PositionedDeclarationRef _ _ r) = extractModule r extractModule (ModuleRef mne) = Just mne @@ -150,52 +157,55 @@ -- that are implicitly exported and then re-exported. elaborateUsed :: Imports -> ModuleName -> UsedImports -> UsedImports elaborateUsed scope mne used = - let classes = extractByQual mne (importedTypeClasses scope) TyClassName - types = extractByQual mne (importedTypes scope) TyName - dctors = extractByQual mne (importedDataConstructors scope) DctorName - values = extractByQual mne (importedValues scope) IdentName - in foldr go used (classes ++ types ++ dctors ++ values) + foldr go used + $ extractByQual mne (importedTypeClasses scope) TyClassName + ++ extractByQual mne (importedTypeOps scope) TyOpName + ++ extractByQual mne (importedTypes scope) TyName + ++ extractByQual mne (importedDataConstructors scope) DctorName + ++ extractByQual mne (importedValues scope) IdentName + ++ extractByQual mne (importedValueOps scope) ValOpName where - go :: (ModuleName, Name) -> UsedImports -> UsedImports + go :: (ModuleName, Qualified Name) -> UsedImports -> UsedImports go (q, name) = M.alter (Just . maybe [name] (name :)) q extractByQual - :: (Eq a) + :: Eq a => ModuleName -> M.Map (Qualified a) [ImportRecord a] - -> (Qualified a -> Name) - -> [(ModuleName, Name)] + -> (a -> Name) + -> [(ModuleName, Qualified Name)] extractByQual k m toName = mapMaybe go (M.toList m) where go (q@(Qualified mnq _), is) | isUnqualified q = case find (isQualifiedWith k) (map importName is) of - Just (Qualified _ name) -> Just (k, toName $ Qualified mnq name) + Just (Qualified _ name) -> Just (k, Qualified mnq (toName name)) _ -> Nothing | isQualifiedWith k q = - case importName (head is) of - Qualified (Just mn') name -> Just (mn', toName $ Qualified mnq name) - _ -> internalError "unqualified name in extractByQual" + case importName (head is) of + Qualified (Just mn') name -> Just (mn', Qualified mnq (toName name)) + _ -> internalError "unqualified name in extractByQual" go _ = Nothing lintImportDecl :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . MonadWriter MultipleErrors m => Env -> ModuleName -> Maybe ModuleName - -> [Name] + -> [Qualified Name] -> ImportDeclarationType -> Bool - -> m () + -> m Bool lintImportDecl env mni qualifierName names declType allowImplicit = case declType of Implicit -> case qualifierName of - Nothing -> unless allowImplicit (checkImplicit ImplicitImport) - Just q -> - let usedModuleNames = mapMaybe extractQualName names - in unless (q `elem` usedModuleNames) unused - Hiding _ -> unless allowImplicit (checkImplicit HidingImport) + Nothing -> + if null allRefs + then unused + else unless' allowImplicit (checkImplicit ImplicitImport) + Just q -> unless' (q `elem` mapMaybe getQual names) unused + Hiding _ -> unless' allowImplicit (checkImplicit HidingImport) Explicit [] -> unused Explicit declrefs -> checkExplicit declrefs @@ -203,82 +213,103 @@ checkImplicit :: (ModuleName -> [DeclarationRef] -> SimpleErrorMessage) - -> m () + -> m Bool checkImplicit warning = if null allRefs then unused - else tell $ errorMessage $ warning mni allRefs + else warn (warning mni (map simplifyTypeRef allRefs)) + where + -- Replace explicit type refs with data constructor lists from listing the + -- used constructors explicity `T(X, Y, [...])` to `T(..)` for suggestion + -- message. + simplifyTypeRef :: DeclarationRef -> DeclarationRef + simplifyTypeRef (TypeRef name (Just dctors)) + | not (null dctors) = TypeRef name Nothing + simplifyTypeRef other = other checkExplicit :: [DeclarationRef] - -> m () + -> m Bool checkExplicit declrefs = do let idents = nub (mapMaybe runDeclRef declrefs) - dctors = mapMaybe (matchDctor qualifierName) names - usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names + dctors = mapMaybe (getDctorName <=< disqualifyFor qualifierName) names + usedNames = mapMaybe (matchName (typeForDCtor mni) <=< disqualifyFor qualifierName) names diff = idents \\ usedNames - case (length diff, length idents) of - (0, _) -> return () + + didWarn <- case (length diff, length idents) of + (0, _) -> return False (n, m) | n == m -> unused - _ -> tell $ errorMessage $ UnusedExplicitImport mni diff qualifierName allRefs + _ -> warn (UnusedExplicitImport mni diff qualifierName allRefs) - -- If we've not already warned a type is unused, check its data constructors - forM_ (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do + didWarn' <- forM (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do let allCtors = dctorsForType mni tn - when (runProperName tn `elem` usedNames) $ case (c, dctors `intersect` allCtors) of - (_, []) | c /= Just [] -> - tell $ errorMessage $ UnusedDctorImport tn - (Just ctors, dctors') -> - let ddiff = ctors \\ dctors' - in unless (null ddiff) $ tell $ errorMessage $ UnusedDctorExplicitImport tn ddiff - _ -> return () - return () + -- If we've not already warned a type is unused, check its data constructors + unless' (runProperName tn `notElem` usedNames) $ + case (c, dctors `intersect` allCtors) of + (_, []) | c /= Just [] -> warn (UnusedDctorImport tn) + (Just ctors, dctors') -> + let ddiff = ctors \\ dctors' + in unless' (null ddiff) $ warn $ UnusedDctorExplicitImport tn ddiff + _ -> return False - unused :: m () - unused = tell $ errorMessage $ UnusedImport mni + return (didWarn || or didWarn') + unused :: m Bool + unused = warn (UnusedImport mni) + + warn :: SimpleErrorMessage -> m Bool + warn err = tell (errorMessage err) >> return True + + -- Unless the boolean is true, run the action. Return false when the action is + -- not run, otherwise return whatever the action does. + -- + -- The return value is intended for cases where we want to track whether some + -- work was done, as there may be further conditions in the action that mean + -- it ends up doing nothing. + unless' :: Bool -> m Bool -> m Bool + unless' False m = m + unless' True _ = return False + allRefs :: [DeclarationRef] allRefs = findUsedRefs env mni qualifierName names dtys :: ModuleName - -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] - dtys mn = maybe [] exportedTypes $ envModuleExports <$> mn `M.lookup` env + -> M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName) + dtys mn = maybe M.empty exportedTypes $ envModuleExports <$> mn `M.lookup` env dctorsForType :: ModuleName -> ProperName 'TypeName -> [ProperName 'ConstructorName] - dctorsForType mn tn = - maybe [] getDctors (find matches $ dtys mn) - where - matches ((ty, _),_) = ty == tn - getDctors ((_,ctors),_) = ctors + dctorsForType mn tn = maybe [] fst $ tn `M.lookup` dtys mn typeForDCtor :: ModuleName -> ProperName 'ConstructorName -> Maybe (ProperName 'TypeName) - typeForDCtor mn pn = - getTy <$> find matches (dtys mn) - where - matches ((_, ctors), _) = pn `elem` ctors - getTy ((ty, _), _) = ty + typeForDCtor mn pn = fst <$> find (elem pn . fst . snd) (M.toList (dtys mn)) -findUsedRefs :: Env -> ModuleName -> Maybe ModuleName -> [Name] -> [DeclarationRef] -findUsedRefs env mni qualifierName names = +findUsedRefs + :: Env + -> ModuleName + -> Maybe ModuleName + -> [Qualified Name] + -> [DeclarationRef] +findUsedRefs env mni qn names = let - classRefs = TypeClassRef <$> mapMaybe (getClassName qualifierName) names - valueRefs = ValueRef <$> mapMaybe (getIdentName qualifierName) names - typeOpRefs = TypeOpRef <$> mapMaybe (getTypeOpName qualifierName) names - types = mapMaybe (getTypeName qualifierName) names - dctors = mapMaybe (matchDctor qualifierName) names + classRefs = TypeClassRef <$> mapMaybe (getClassName <=< disqualifyFor qn) names + valueRefs = ValueRef <$> mapMaybe (getIdentName <=< disqualifyFor qn) names + valueOpRefs = ValueOpRef <$> mapMaybe (getValOpName <=< disqualifyFor qn) names + typeOpRefs = TypeOpRef <$> mapMaybe (getTypeOpName <=< disqualifyFor qn) names + types = mapMaybe (getTypeName <=< disqualifyFor qn) names + dctors = mapMaybe (getDctorName <=< disqualifyFor qn) names typesWithDctors = reconstructTypeRefs dctors typesWithoutDctors = filter (`M.notMember` typesWithDctors) types typesRefs = map (flip TypeRef (Just [])) typesWithoutDctors ++ map (\(ty, ds) -> TypeRef ty (Just ds)) (M.toList typesWithDctors) - in classRefs ++ typeOpRefs ++ typesRefs ++ valueRefs + in classRefs ++ typeOpRefs ++ typesRefs ++ valueRefs ++ valueOpRefs where @@ -287,7 +318,8 @@ -> M.Map (ProperName 'TypeName) [ProperName 'ConstructorName] reconstructTypeRefs = foldr accumDctors M.empty where - accumDctors dctor = M.alter (Just . maybe [dctor] (dctor :)) (findTypeForDctor mni dctor) + accumDctors dctor = + M.alter (Just . maybe [dctor] (dctor :)) (findTypeForDctor mni dctor) findTypeForDctor :: ModuleName @@ -296,32 +328,20 @@ findTypeForDctor mn dctor = case mn `M.lookup` env of Just (_, _, exps) -> - case find (elem dctor . snd . fst) (exportedTypes exps) of - Just ((ty, _), _) -> ty + case find (elem dctor . fst . snd) (M.toList (exportedTypes exps)) of + Just (ty, _) -> ty Nothing -> internalError $ "missing type for data constructor " ++ runProperName dctor ++ " in findTypeForDctor" Nothing -> internalError $ "missing module " ++ runModuleName mn ++ " in findTypeForDctor" matchName :: (ProperName 'ConstructorName -> Maybe (ProperName 'TypeName)) - -> Maybe ModuleName -> Name -> Maybe String -matchName _ qual (IdentName (Qualified q x)) | q == qual = Just $ showIdent x -matchName _ qual (TyName (Qualified q x)) | q == qual = Just $ runProperName x -matchName _ qual (TyClassName (Qualified q x)) | q == qual = Just $ runProperName x -matchName lookupDc qual (DctorName (Qualified q x)) | q == qual = runProperName <$> lookupDc x -matchName _ _ _ = Nothing - -extractQualName :: Name -> Maybe ModuleName -extractQualName (IdentName (Qualified q _)) = q -extractQualName (TyName (Qualified q _)) = q -extractQualName (TyOpName (Qualified q _)) = q -extractQualName (TyClassName (Qualified q _)) = q -extractQualName (DctorName (Qualified q _)) = q - -matchDctor :: Maybe ModuleName -> Name -> Maybe (ProperName 'ConstructorName) -matchDctor qual (DctorName (Qualified q x)) | q == qual = Just x -matchDctor _ _ = Nothing +matchName _ (IdentName x) = Just $ showIdent x +matchName _ (TyName x) = Just $ runProperName x +matchName _ (TyClassName x) = Just $ runProperName x +matchName lookupDc (DctorName x) = runProperName <$> lookupDc x +matchName _ _ = Nothing runDeclRef :: DeclarationRef -> Maybe String runDeclRef (PositionedDeclarationRef _ _ ref) = runDeclRef ref @@ -330,15 +350,16 @@ runDeclRef (TypeClassRef pn) = Just $ runProperName pn runDeclRef _ = Nothing -getTypeRef - :: DeclarationRef - -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName]) -getTypeRef (PositionedDeclarationRef _ _ ref) = getTypeRef ref -getTypeRef (TypeRef pn x) = Just (pn, x) -getTypeRef _ = Nothing - -addModuleLocError :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage -addModuleLocError sp err = - case sp of - Just pos -> withPosition pos err - _ -> err +checkDuplicateImports + :: MonadWriter MultipleErrors m + => ModuleName + -> [ImportDef] + -> (ImportDef, ImportDef) + -> m [ImportDef] +checkDuplicateImports mn xs ((_, t1, q1), (pos, t2, q2)) = + if t1 == t2 && q1 == q2 + then do + maybe id warnWithPosition pos $ + tell $ errorMessage $ DuplicateImport mn t2 q2 + return $ (pos, t2, q2) : xs + else return xs diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -1,10 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} module Language.PureScript.Make @@ -20,59 +14,46 @@ -- * Implementation of Make API using files on disk , Make(..) , runMake + , makeIO + , readTextFile , buildMakeActions + , inferForeignModules ) where -import Prelude () import Prelude.Compat -import Control.Applicative ((<|>)) +import Control.Concurrent.Lifted as C import Control.Monad hiding (sequence) +import Control.Monad.Base (MonadBase(..)) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer.Class (MonadWriter(..)) -import Control.Monad.Trans.Class (MonadTrans(..)) -import Control.Monad.Trans.Except import Control.Monad.IO.Class -import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks) import Control.Monad.Logger +import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks) import Control.Monad.Supply -import Control.Monad.Base (MonadBase(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Control (MonadBaseControl(..)) - -import Control.Concurrent.Lifted as C +import Control.Monad.Trans.Except +import Control.Monad.Writer.Class (MonadWriter(..)) -import Data.List (foldl', sort) -import Data.Maybe (fromMaybe, catMaybes, isJust) +import Data.Aeson (encode, decode) import Data.Either (partitionEithers) -import Data.Time.Clock -import Data.String (fromString) import Data.Foldable (for_) +import Data.List (foldl', sort) +import Data.Maybe (fromMaybe, catMaybes) +import Data.String (fromString) +import Data.Time.Clock import Data.Traversable (for) import Data.Version (showVersion) -import Data.Aeson (encode, decode) import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.UTF8 as BU8 -import qualified Data.Set as S import qualified Data.Map as M - -import qualified Text.Parsec as Parsec - -import SourceMap.Types -import SourceMap - -import System.Directory - (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory) -import System.FilePath ((), takeDirectory, makeRelative, splitPath, normalise) -import System.IO.Error (tryIOError) -import System.IO.UTF8 (readUTF8File, writeUTF8File) - -import qualified Language.JavaScript.Parser as JS +import qualified Data.Set as S -import Language.PureScript.Crash import Language.PureScript.AST -import Language.PureScript.Externs +import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors +import Language.PureScript.Externs import Language.PureScript.Linter import Language.PureScript.ModuleDependencies import Language.PureScript.Names @@ -82,14 +63,25 @@ import Language.PureScript.Renamer import Language.PureScript.Sugar import Language.PureScript.TypeChecker -import qualified Language.PureScript.Constants as C +import qualified Language.JavaScript.Parser as JS import qualified Language.PureScript.Bundle as Bundle -import qualified Language.PureScript.Parser as PSParser - import qualified Language.PureScript.CodeGen.JS as J +import qualified Language.PureScript.Constants as C import qualified Language.PureScript.CoreFn as CF +import qualified Language.PureScript.Parser as PSParser + import qualified Paths_purescript as Paths +import SourceMap +import SourceMap.Types + +import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory) +import System.FilePath ((), takeDirectory, makeRelative, splitPath, normalise, replaceExtension) +import System.IO.Error (tryIOError) +import System.IO.UTF8 (readUTF8File, writeUTF8File) + +import qualified Text.Parsec as Parsec + -- | Progress messages from the make process data ProgressMessage = CompilingModule ModuleName @@ -107,31 +99,22 @@ -- -- * The details of how files are read/written etc. -- -data MakeActions m = MakeActions { - -- | - -- Get the timestamp for the input file(s) for a module. If there are multiple - -- files (.purs and foreign files, for example) the timestamp should be for +data MakeActions m = MakeActions + { getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime)) + -- ^ Get the timestamp for the input file(s) for a module. If there are multiple + -- files (@.purs@ and foreign files, for example) the timestamp should be for -- the most recently modified file. - -- - getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime)) - -- | - -- Get the timestamp for the output files for a module. This should be the - -- timestamp for the oldest modified file, or Nothing if any of the required - -- output files are missing. - -- , getOutputTimestamp :: ModuleName -> m (Maybe UTCTime) - -- | - -- Read the externs file for a module as a string and also return the actual - -- path for the file. + -- ^ Get the timestamp for the output files for a module. This should be the + -- timestamp for the oldest modified file, or 'Nothing' if any of the required + -- output files are missing. , readExterns :: ModuleName -> m (FilePath, Externs) - -- | - -- Run the code generator for the module and write any required output files. - -- + -- ^ Read the externs file for a module as a string and also return the actual + -- path for the file. , codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT m () - -- | - -- Respond to a progress update. - -- + -- ^ Run the code generator for the module and write any required output files. , progress :: ProgressMessage -> m () + -- ^ Respond to a progress update. } -- | @@ -157,11 +140,11 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do progress $ CompilingModule moduleName let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs - lint m - ((checked@(Module ss coms _ elaborated exps), env'), nextVar) <- runSupplyT 0 $ do - [desugared] <- desugar externs [m] + withPrim = importPrim m + lint withPrim + ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do + [desugared] <- desugar externs [withPrim] runCheck' env $ typeCheckModule desugared - checkExhaustiveModule env' checked regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated let mod' = Module ss coms moduleName regrouped exps corefn = CF.moduleToCoreFn env' mod' @@ -179,11 +162,8 @@ make :: forall m. (Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> [Module] - -> m Environment + -> m [ExternsFile] make ma@MakeActions{..} ms = do - requirePath <- asks optionsRequirePath - when (isJust requirePath) $ tell $ errorMessage DeprecatedRequirePath - checkModuleNamesAreUnique (sorted, graph) <- sortModules ms @@ -202,7 +182,7 @@ -- Bundle up all the externs and return them as an Environment (_, externs) <- unzip . fromMaybe (internalError "make: externs were missing but no errors reported.") . sequence <$> for barriers (takeMVar . fst . snd) - return $ foldl' (flip applyExternsFileToEnvironment) initEnvironment externs + return externs where checkModuleNamesAreUnique :: m () @@ -304,11 +284,29 @@ e <- liftIO $ tryIOError io either (throwError . singleError . f) return e --- Traverse (Either e) instance (base 4.7) -traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b) -traverseEither _ (Left x) = pure (Left x) -traverseEither f (Right y) = Right <$> f y +-- | Read a text file in the 'Make' monad, capturing any errors using the +-- 'MonadError' instance. +readTextFile :: FilePath -> Make String +readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path +-- | Infer the module name for a module by looking for the same filename with +-- a .js extension. +inferForeignModules + :: forall m + . MonadIO m + => M.Map ModuleName (Either RebuildPolicy FilePath) + -> m (M.Map ModuleName FilePath) +inferForeignModules = fmap (M.mapMaybe id) . traverse inferForeignModule + where + inferForeignModule :: Either RebuildPolicy FilePath -> m (Maybe FilePath) + inferForeignModule (Left _) = return Nothing + inferForeignModule (Right path) = do + let jsFile = replaceExtension path "js" + exists <- liftIO $ doesFileExist jsFile + if exists + then return (Just jsFile) + else return Nothing + -- | -- A set of make actions that read and write modules from the given directory. -- @@ -324,7 +322,7 @@ getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime)) getInputTimestamp mn = do let path = fromMaybe (internalError "Module has no filename in 'make'") $ M.lookup mn filePathMap - e1 <- traverseEither getTimestamp path + e1 <- traverse getTimestamp path fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns return $ fmap (max fPath) e1 @@ -375,7 +373,7 @@ genSourceMap dir mapFile extraLines mappings = do let pathToDir = iterate (".." ) ".." !! length (splitPath $ normalise outputDir) sourceFile = case mappings of - ((SMap file _ _):_) -> Just $ pathToDir makeRelative dir file + (SMap file _ _ : _) -> Just $ pathToDir makeRelative dir file _ -> Nothing let rawMapping = SourceMapping { smFile = "index.js", smSourceRoot = Nothing, smMappings = map (\(SMap _ orig gen) -> Mapping { @@ -414,9 +412,6 @@ progress :: ProgressMessage -> Make () progress = liftIO . putStrLn . renderProgressMessage -readTextFile :: FilePath -> Make String -readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path - -- | -- Check that the declarations in a given PureScript module match with those -- in its corresponding foreign module. @@ -464,11 +459,10 @@ (errs, _) -> Left errs - -- TODO: Handling for parenthesised operators should be removed after 0.9. -- We ignore the error message here, just being told it's an invalid -- identifier should be enough. parseIdent :: String -> Either String Ident - parseIdent str = try str <|> try ("(" ++ str ++ ")") + parseIdent str = try str where try s = either (const (Left str)) Right $ do ts <- PSParser.lex "" s diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -1,24 +1,24 @@ -{-# LANGUAGE FlexibleContexts #-} - -- | -- Provides the ability to sort modules based on module dependencies -- -module Language.PureScript.ModuleDependencies ( - sortModules, - ModuleGraph -) where +module Language.PureScript.ModuleDependencies + ( sortModules + , ModuleGraph + ) where +import Prelude.Compat + import Control.Monad.Error.Class (MonadError(..)) import Data.Graph import Data.List (nub) import Data.Maybe (fromMaybe) -import Language.PureScript.Crash import Language.PureScript.AST +import Language.PureScript.Crash +import Language.PureScript.Errors import Language.PureScript.Names import Language.PureScript.Types -import Language.PureScript.Errors -- | A list of modules with their transitive dependencies type ModuleGraph = [(ModuleName, [ModuleName])] @@ -47,7 +47,7 @@ -- Extract module names that have been brought into scope by an `as` import. extractQualAs :: Declaration -> [ModuleName] extractQualAs (PositionedDeclaration _ _ d) = extractQualAs d - extractQualAs (ImportDeclaration _ _ (Just am) _) = [am] + extractQualAs (ImportDeclaration _ _ (Just am)) = [am] extractQualAs _ = [] -- | @@ -65,12 +65,12 @@ where forDecls :: Declaration -> [ModuleName] - forDecls (ImportDeclaration mn _ _ _) = + forDecls (ImportDeclaration mn _ _) = -- Regardless of whether an imported module is qualified we still need to -- take into account its import to build an accurate list of dependencies. [mn] - forDecls (FixityDeclaration _ _ (Just (Qualified (Just mn) _))) - | mn `notElem` ams = [mn] + forDecls (FixityDeclaration fd) + | Just mn <- extractQualFixity fd, mn `notElem` ams = [mn] forDecls (TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) | mn `notElem` ams = [mn] forDecls _ = [] @@ -86,6 +86,10 @@ forTypes (TypeConstructor (Qualified (Just mn) _)) | mn `notElem` ams = [mn] forTypes _ = [] + + extractQualFixity :: Either ValueFixity TypeFixity -> Maybe ModuleName + extractQualFixity (Left (ValueFixity _ (Qualified mn _) _)) = mn + extractQualFixity (Right (TypeFixity _ (Qualified mn _) _)) = mn -- | -- Convert a strongly connected component of the module graph to a module diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -1,20 +1,57 @@ -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE KindSignatures #-} -- | -- Data types for names -- module Language.PureScript.Names where -import Control.Monad (liftM) +import Prelude.Compat + import Control.Monad.Supply.Class -import Data.List import Data.Aeson import Data.Aeson.TH +import Data.List +-- | A sum of the possible name types, useful for error and lint messages. +data Name + = IdentName Ident + | ValOpName (OpName 'ValueOpName) + | TyName (ProperName 'TypeName) + | TyOpName (OpName 'TypeOpName) + | DctorName (ProperName 'ConstructorName) + | TyClassName (ProperName 'ClassName) + | ModName ModuleName + deriving (Eq, Show) + +getIdentName :: Name -> Maybe Ident +getIdentName (IdentName name) = Just name +getIdentName _ = Nothing + +getValOpName :: Name -> Maybe (OpName 'ValueOpName) +getValOpName (ValOpName name) = Just name +getValOpName _ = Nothing + +getTypeName :: Name -> Maybe (ProperName 'TypeName) +getTypeName (TyName name) = Just name +getTypeName _ = Nothing + +getTypeOpName :: Name -> Maybe (OpName 'TypeOpName) +getTypeOpName (TyOpName name) = Just name +getTypeOpName _ = Nothing + +getDctorName :: Name -> Maybe (ProperName 'ConstructorName) +getDctorName (DctorName name) = Just name +getDctorName _ = Nothing + +getClassName :: Name -> Maybe (ProperName 'ClassName) +getClassName (TyClassName name) = Just name +getClassName _ = Nothing + +getModName :: Name -> Maybe ModuleName +getModName (ModName name) = Just name +getModName _ = Nothing + -- | -- Names for value identifiers -- @@ -24,10 +61,6 @@ -- = Ident String -- | - -- A symbolic name for an infix operator - -- - | Op String - -- | -- A generated name for an identifier -- | GenIdent (Maybe String) Integer @@ -35,21 +68,39 @@ runIdent :: Ident -> String runIdent (Ident i) = i -runIdent (Op op) = op runIdent (GenIdent Nothing n) = "$" ++ show n runIdent (GenIdent (Just name) n) = "$" ++ name ++ show n showIdent :: Ident -> String -showIdent (Op op) = '(' : op ++ ")" -showIdent i = runIdent i +showIdent = runIdent -freshIdent :: (MonadSupply m) => String -> m Ident -freshIdent name = liftM (GenIdent (Just name)) fresh +freshIdent :: MonadSupply m => String -> m Ident +freshIdent name = GenIdent (Just name) <$> fresh -freshIdent' :: (MonadSupply m) => m Ident -freshIdent' = liftM (GenIdent Nothing) fresh +freshIdent' :: MonadSupply m => m Ident +freshIdent' = GenIdent Nothing <$> fresh -- | +-- Operator alias names. +-- +newtype OpName (a :: OpNameType) = OpName { runOpName :: String } + deriving (Show, Read, Eq, Ord) + +instance ToJSON (OpName a) where + toJSON = toJSON . runOpName + +instance FromJSON (OpName a) where + parseJSON = fmap OpName . parseJSON + +showOp :: OpName a -> String +showOp op = '(' : runOpName op ++ ")" + +-- | +-- The closed set of operator alias types. +-- +data OpNameType = ValueOpName | TypeOpName + +-- | -- Proper names, i.e. capitalized names for e.g. module names, type//data constructors. -- newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: String } @@ -101,6 +152,9 @@ showQualified f (Qualified Nothing a) = f a showQualified f (Qualified (Just name) a) = runModuleName name ++ "." ++ f a +getQual :: Qualified a -> Maybe ModuleName +getQual (Qualified mn _) = mn + -- | -- Provide a default module name, if a name is unqualified -- @@ -117,6 +171,14 @@ -- | Remove the module name from a qualified name disqualify :: Qualified a -> a disqualify (Qualified _ a) = a + +-- | +-- Remove the qualification from a value when it is qualified with a particular +-- module name. +-- +disqualifyFor :: Maybe ModuleName -> Qualified a -> Maybe a +disqualifyFor mn (Qualified mn' a) | mn == mn' = Just a +disqualifyFor _ _ = Nothing -- | -- Checks whether a qualified value is actually qualified with a module reference diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs --- a/src/Language/PureScript/Options.hs +++ b/src/Language/PureScript/Options.hs @@ -1,20 +1,10 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Options --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- The data type of compiler options -- ------------------------------------------------------------------------------ - module Language.PureScript.Options where +import Prelude.Compat + -- | -- The data type of compiler options -- @@ -39,9 +29,6 @@ -- Remove the comments from the generated js , optionsNoComments :: Bool -- | - -- The path to prepend to require statements - , optionsRequirePath :: Maybe FilePath - -- | -- Generate soure maps , optionsSourceMaps :: Bool } deriving Show @@ -49,4 +36,4 @@ -- | -- Default make options defaultOptions :: Options -defaultOptions = Options False False Nothing False False False Nothing False +defaultOptions = Options False False Nothing False False False False diff --git a/src/Language/PureScript/Parser.hs b/src/Language/PureScript/Parser.hs --- a/src/Language/PureScript/Parser.hs +++ b/src/Language/PureScript/Parser.hs @@ -1,36 +1,23 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Parser --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- A collection of parsers for core data types: --- --- [@Language.PureScript.Parser.Kinds@] Parser for kinds --- --- [@Language.PureScript.Parser.Values@] Parser for values --- --- [@Language.PureScript.Parser.Types@] Parser for types --- --- [@Language.PureScript.Parser.Declaration@] Parsers for declarations and modules --- --- [@Language.PureScript.Parser.State@] Parser state, including indentation --- --- [@Language.PureScript.Parser.Common@] Common parsing utility functions --- ------------------------------------------------------------------------------ - -module Language.PureScript.Parser (module P) where - -import Language.PureScript.Parser.Common as P -import Language.PureScript.Parser.Types as P -import Language.PureScript.Parser.State as P -import Language.PureScript.Parser.Kinds as P -import Language.PureScript.Parser.Lexer as P -import Language.PureScript.Parser.Declarations as P -import Language.PureScript.Parser.JS as P +-- | +-- A collection of parsers for core data types: +-- +-- [@Language.PureScript.Parser.Kinds@] Parser for kinds +-- +-- [@Language.PureScript.Parser.Values@] Parser for values +-- +-- [@Language.PureScript.Parser.Types@] Parser for types +-- +-- [@Language.PureScript.Parser.Declaration@] Parsers for declarations and modules +-- +-- [@Language.PureScript.Parser.State@] Parser state, including indentation +-- +-- [@Language.PureScript.Parser.Common@] Common parsing utility functions +-- +module Language.PureScript.Parser (module P) where + +import Language.PureScript.Parser.Common as P +import Language.PureScript.Parser.Declarations as P +import Language.PureScript.Parser.Kinds as P +import Language.PureScript.Parser.Lexer as P +import Language.PureScript.Parser.State as P +import Language.PureScript.Parser.Types as P diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs --- a/src/Language/PureScript/Parser/Common.hs +++ b/src/Language/PureScript/Parser/Common.hs @@ -1,24 +1,34 @@ -{-# LANGUAGE FlexibleContexts #-} - -- | --- Constants, and utility functions to be used when parsing +-- Constants and utility functions to be used when parsing -- module Language.PureScript.Parser.Common where +import Prelude.Compat + import Control.Applicative import Control.Monad (guard) +import Language.PureScript.AST.SourcePos import Language.PureScript.Comments +import Language.PureScript.Names import Language.PureScript.Parser.Lexer import Language.PureScript.Parser.State -import Language.PureScript.Names import qualified Text.Parsec as P +-- | +-- Parse a general proper name. +-- properName :: TokenParser (ProperName a) properName = ProperName <$> uname -- | +-- Parse a proper name for a type. +-- +typeName :: TokenParser (ProperName 'TypeName) +typeName = ProperName <$> tyname + +-- | -- Parse a module name -- moduleName :: TokenParser ModuleName @@ -42,12 +52,18 @@ qual path = if null path then Nothing else Just $ ModuleName path -- | --- Parse an identifier or parenthesized operator +-- Parse an identifier. -- parseIdent :: TokenParser Ident -parseIdent = (Ident <$> identifier) <|> (Op <$> parens symbol) +parseIdent = Ident <$> identifier -- | +-- Parse an operator. +-- +parseOperator :: TokenParser (OpName a) +parseOperator = OpName <$> symbol + +-- | -- Run the first parser, then match the second if possible, applying the specified function on a successful match -- augment :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a @@ -120,3 +136,9 @@ -- runTokenParser :: FilePath -> TokenParser a -> [PositionedToken] -> Either P.ParseError a runTokenParser filePath p = P.runParser p (ParseState 0) filePath + +-- | +-- Convert from Parsec sourcepos +-- +toSourcePos :: P.SourcePos -> SourcePos +toSourcePos pos = SourcePos (P.sourceLine pos) (P.sourceColumn pos) diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -1,22 +1,19 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} - -- | -- Parsers for module definitions and declarations -- -module Language.PureScript.Parser.Declarations ( - parseDeclaration, - parseModule, - parseModules, - parseModulesFromFiles, - parseValue, - parseGuard, - parseBinder, - parseBinderNoParens, - parseImportDeclaration', - parseLocalDeclaration -) where +module Language.PureScript.Parser.Declarations + ( parseDeclaration + , parseModule + , parseModulesFromFiles + , parseModuleFromFile + , parseValue + , parseGuard + , parseBinder + , parseBinderNoParens + , parseImportDeclaration' + , parseLocalDeclaration + , toPositionedError + ) where import Prelude hiding (lex) @@ -46,13 +43,20 @@ -- | -- Read source position information -- -withSourceSpan :: (SourceSpan -> [Comment] -> a -> a) -> P.Parsec [PositionedToken] u a -> P.Parsec [PositionedToken] u a +withSourceSpan + :: (SourceSpan -> [Comment] -> a -> a) + -> P.Parsec [PositionedToken] u a + -> P.Parsec [PositionedToken] u a withSourceSpan f p = do start <- P.getPosition comments <- C.readComments x <- p end <- P.getPosition - let sp = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end) + input <- P.getInput + let end' = case input of + pt:_ -> ptPrevEndPos pt + _ -> Nothing + let sp = SourceSpan (P.sourceName start) (C.toSourcePos start) (C.toSourcePos $ fromMaybe end end') return $ f sp comments x kindedIdent :: TokenParser (String, Maybe Kind) @@ -62,7 +66,7 @@ parseDataDeclaration :: TokenParser Declaration parseDataDeclaration = do dtype <- (reserved "data" *> return Data) <|> (reserved "newtype" *> return Newtype) - name <- indented *> properName + name <- indented *> typeName tyArgs <- many (indented *> kindedIdent) ctors <- P.option [] $ do indented *> equals @@ -76,7 +80,7 @@ parseTypeSynonymDeclaration :: TokenParser Declaration parseTypeSynonymDeclaration = - TypeSynonymDeclaration <$> (reserved "type" *> indented *> properName) + TypeSynonymDeclaration <$> (reserved "type" *> indented *> typeName) <*> many (indented *> kindedIdent) <*> (indented *> equals *> noWildcards parsePolyType) @@ -93,6 +97,7 @@ where parseValueWithWhereClause :: TokenParser Expr parseValueWithWhereClause = do + C.indented value <- parseValue whereClause <- P.optionMaybe $ do C.indented @@ -103,7 +108,7 @@ parseExternDeclaration :: TokenParser Declaration parseExternDeclaration = reserved "foreign" *> indented *> reserved "import" *> indented *> - (ExternDataDeclaration <$> (reserved "data" *> indented *> properName) + (ExternDataDeclaration <$> (reserved "data" *> indented *> typeName) <*> (indented *> doubleColon *> parseKind) <|> (do ident <- parseIdent ty <- indented *> doubleColon *> noWildcards parsePolyType @@ -122,38 +127,33 @@ parseFixityDeclaration = do fixity <- parseFixity indented - alias <- P.optionMaybe $ parseQualified aliased <* reserved "as" - name <- symbol - return $ FixityDeclaration fixity name alias + FixityDeclaration + <$> ((Right <$> typeFixity fixity) <|> (Left <$> valueFixity fixity)) where - aliased = (AliasValue . Ident <$> identifier) - <|> (AliasConstructor <$> properName) - <|> reserved "type" *> (AliasType <$> properName) + typeFixity fixity = + TypeFixity fixity + <$> (reserved "type" *> parseQualified typeName) + <*> (reserved "as" *> parseOperator) + valueFixity fixity = + ValueFixity fixity + <$> parseQualified ((Left <$> parseIdent) <|> (Right <$> properName)) + <*> (reserved "as" *> parseOperator) parseImportDeclaration :: TokenParser Declaration -parseImportDeclaration = do - (mn, declType, asQ, isOldSyntax) <- parseImportDeclaration' - return $ ImportDeclaration mn declType asQ isOldSyntax +parseImportDeclaration = withSourceSpan PositionedDeclaration $ do + (mn, declType, asQ) <- parseImportDeclaration' + return $ ImportDeclaration mn declType asQ -parseImportDeclaration' :: TokenParser (ModuleName, ImportDeclarationType, Maybe ModuleName, Bool) +parseImportDeclaration' :: TokenParser (ModuleName, ImportDeclarationType, Maybe ModuleName) parseImportDeclaration' = do reserved "import" indented - qualImport <|> stdImport + moduleName' <- moduleName + declType <- reserved "hiding" *> qualifyingList Hiding <|> qualifyingList Explicit + qName <- P.optionMaybe qualifiedName + return (moduleName', declType, qName) where - stdImport = do - moduleName' <- moduleName - declType <- reserved "hiding" *> qualifyingList Hiding <|> qualifyingList Explicit - qName <- P.optionMaybe qualifiedName - return (moduleName', declType, qName, False) qualifiedName = reserved "as" *> moduleName - qualImport = do - reserved "qualified" - indented - moduleName' <- moduleName - declType <- qualifyingList Explicit - qName <- qualifiedName - return (moduleName', declType, Just qName, True) qualifyingList expectedType = do declType <- P.optionMaybe (expectedType <$> (indented *> parens (commaSep parseDeclarationRef))) return $ fromMaybe Implicit declType @@ -162,15 +162,16 @@ parseDeclarationRef = withSourceSpan PositionedDeclarationRef $ (ValueRef <$> parseIdent) - <|> parseProperRef + <|> (ValueOpRef <$> parens parseOperator) + <|> parseTypeRef <|> (TypeClassRef <$> (reserved "class" *> properName)) <|> (ModuleRef <$> (indented *> reserved "module" *> moduleName)) - <|> (TypeOpRef <$> (indented *> reserved "type" *> parens (Op <$> symbol))) + <|> (TypeOpRef <$> (indented *> reserved "type" *> parens parseOperator)) where - parseProperRef = do - name <- properName + parseTypeRef = do + name <- typeName dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName) - return $ maybe (ProperRef (runProperName name)) (TypeRef name) dctors + return $ TypeRef name (fromMaybe (Just []) dctors) parseTypeClassDeclaration :: TokenParser Declaration parseTypeClassDeclaration = do @@ -182,13 +183,15 @@ return implies className <- indented *> properName idents <- P.many (indented *> kindedIdent) - members <- P.option [] . P.try $ do + members <- P.option [] $ do indented *> reserved "where" indented *> mark (P.many (same *> positioned parseTypeDeclaration)) return $ TypeClassDeclaration className idents implies members parseConstraint :: TokenParser Constraint -parseConstraint = (,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom) +parseConstraint = Constraint <$> parseQualified properName + <*> P.many (noWildcards parseTypeAtom) + <*> pure Nothing parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration) parseInstanceDeclaration = do @@ -206,7 +209,7 @@ parseTypeInstanceDeclaration :: TokenParser Declaration parseTypeInstanceDeclaration = do instanceDecl <- parseInstanceDeclaration - members <- P.option [] . P.try $ do + members <- P.option [] $ do indented *> reserved "where" mark (P.many (same *> positioned parseValueDeclaration)) return $ instanceDecl (ExplicitInstance members) @@ -231,7 +234,6 @@ , parseValueDeclaration , parseExternDeclaration , parseFixityDeclaration - , parseImportDeclaration , parseTypeClassDeclaration , parseTypeInstanceDeclaration , parseDerivingInstanceDeclaration @@ -255,48 +257,56 @@ name <- moduleName exports <- P.optionMaybe $ parens $ commaSep1 parseDeclarationRef reserved "where" - decls <- mark (P.many (same *> parseDeclaration)) + decls <- mark $ do + -- TODO: extract a module header structure here, and provide a + -- parseModuleHeader function. This should allow us to speed up rebuilds + -- by only parsing as far as the module header. See PR #2054. + imports <- P.many (same *> parseImportDeclaration) + decls <- P.many (same *> parseDeclaration) + return (imports ++ decls) + _ <- P.eof end <- P.getPosition - let ss = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end) + let ss = SourceSpan (P.sourceName start) (C.toSourcePos start) (C.toSourcePos end) return $ Module ss comments name decls exports -- | Parse a collection of modules in parallel -parseModulesFromFiles :: forall m k. (MonadError MultipleErrors m) => - (k -> FilePath) -> [(k, String)] -> m [(k, Module)] -parseModulesFromFiles toFilePath input = do - modules <- flip parU id $ map wrapError $ inParallel $ flip map input $ \(k, content) -> do - let filename = toFilePath k - ts <- lex filename content - ms <- runTokenParser filename parseModules ts - return (k, ms) - return $ collect modules +parseModulesFromFiles + :: forall m k + . MonadError MultipleErrors m + => (k -> FilePath) + -> [(k, String)] + -> m [(k, Module)] +parseModulesFromFiles toFilePath input = + flip parU wrapError . inParallel . flip map input $ parseModuleFromFile toFilePath where - collect :: [(k, [v])] -> [(k, v)] - collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ] wrapError :: Either P.ParseError a -> m a wrapError = either (throwError . MultipleErrors . pure . toPositionedError) return -- It is enough to force each parse result to WHNF, since success or failure can't be -- determined until the end of the file, so this effectively distributes parsing of each file -- to a different spark. - inParallel :: [Either P.ParseError (k, [Module])] -> [Either P.ParseError (k, [Module])] + inParallel :: [Either P.ParseError (k, a)] -> [Either P.ParseError (k, a)] inParallel = withStrategy (parList rseq) + +-- | Parses a single module with FilePath for eventual parsing errors +parseModuleFromFile + :: (k -> FilePath) + -> (k, String) + -> Either P.ParseError (k, Module) +parseModuleFromFile toFilePath (k, content) = do + let filename = toFilePath k + ts <- lex filename content + m <- runTokenParser filename parseModule ts + pure (k, m) + +-- | Converts a @ParseError@ into a @PositionedError@ toPositionedError :: P.ParseError -> ErrorMessage toPositionedError perr = ErrorMessage [ PositionedError (SourceSpan name start end) ] (ErrorParsingModule perr) where - name = (P.sourceName . P.errorPos) perr - start = (toSourcePos . P.errorPos) perr + name = (P.sourceName . P.errorPos) perr + start = (C.toSourcePos . P.errorPos) perr end = start -toSourcePos :: P.SourcePos -> SourcePos -toSourcePos pos = SourcePos (P.sourceLine pos) (P.sourceColumn pos) - --- | --- Parse a collection of modules --- -parseModules :: TokenParser [Module] -parseModules = mark (P.many (same *> parseModule)) <* P.eof - booleanLiteral :: TokenParser Bool booleanLiteral = (reserved "true" >> return True) P.<|> (reserved "false" >> return False) @@ -331,8 +341,7 @@ parseAbs :: TokenParser Expr parseAbs = do symbol' "\\" - -- TODO: remove this 'try' after operator aliases are finished (0.9) - args <- P.many1 (C.indented *> (Abs <$> (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens))) + args <- P.many1 (C.indented *> (Abs <$> (Left <$> C.parseIdent <|> Right <$> parseBinderNoParens))) C.indented *> rarrow value <- parseValue return $ toFunction args value @@ -351,7 +360,7 @@ <*> (C.indented *> C.mark (P.many1 (C.same *> C.mark parseCaseAlternative))) parseCaseAlternative :: TokenParser CaseAlternative -parseCaseAlternative = CaseAlternative <$> (commaSep1 parseBinder) +parseCaseAlternative = CaseAlternative <$> commaSep1 parseBinder <*> (Left <$> (C.indented *> P.many1 ((,) <$> parseGuard <*> (indented *> rarrow *> parseValue) @@ -382,7 +391,7 @@ , Literal <$> parseStringLiteral , Literal <$> parseBooleanLiteral , Literal <$> parseArrayLiteral parseValue - , Literal <$> P.try (parseObjectLiteral parseIdentifierAndValue) + , Literal <$> parseObjectLiteral parseIdentifierAndValue , parseAbs , P.try parseConstructor , P.try parseVar @@ -391,7 +400,7 @@ , parseDo , parseLet , P.try $ Parens <$> parens parseValue - , parseOperatorSection + , Op <$> parseQualified (parens parseOperator) , parseHole ] @@ -399,14 +408,9 @@ -- Parse an expression in backticks or an operator -- parseInfixExpr :: TokenParser Expr -parseInfixExpr = P.between tick tick parseValue - <|> Var <$> parseQualified (Op <$> symbol) - -parseOperatorSection :: TokenParser Expr -parseOperatorSection = parens $ left <|> right - where - right = OperatorSection <$> parseInfixExpr <* indented <*> (Right <$> indexersAndAccessors) - left = flip OperatorSection <$> (Left <$> indexersAndAccessors) <* indented <*> parseInfixExpr +parseInfixExpr + = P.between tick tick parseValue + <|> Op <$> parseQualified parseOperator parseHole :: TokenParser Expr parseHole = Hole <$> holeLit @@ -496,10 +500,8 @@ parseVarOrNamedBinder :: TokenParser Binder parseVarOrNamedBinder = do - -- TODO: once operator aliases are finalized in 0.9, this 'try' won't be needed - -- any more since identifiers in binders won't be 'Op's. - name <- P.try C.parseIdent - let parseNamedBinder = NamedBinder name <$> (at *> C.indented *> parseBinder) + name <- C.parseIdent + let parseNamedBinder = NamedBinder name <$> (at *> C.indented *> parseBinderAtom) parseNamedBinder <|> return (VarBinder name) parseNullBinder :: TokenParser Binder @@ -507,12 +509,12 @@ parseIdentifierAndBinder :: TokenParser (String, Binder) parseIdentifierAndBinder = - do name <- lname - b <- P.option (VarBinder (Ident name)) rest - return (name, b) - <|> (,) <$> stringLiteral <*> rest + do name <- lname + b <- P.option (VarBinder (Ident name)) rest + return (name, b) + <|> (,) <$> stringLiteral <*> rest where - rest = C.indented *> (equals <|> colon) *> C.indented *> parseBinder + rest = C.indented *> colon *> C.indented *> parseBinder -- | -- Parse a binder @@ -531,25 +533,27 @@ return (BinaryNoParensBinder op)) P.AssocRight ] ] + -- TODO: parsePolyType when adding support for polymorphic types postfixTable = [ \b -> flip TypedBinder b <$> (indented *> doubleColon *> parseType) ] - parseBinderAtom :: TokenParser Binder - parseBinderAtom = P.choice - [ parseNullBinder - , LiteralBinder <$> parseCharLiteral - , LiteralBinder <$> parseStringLiteral - , LiteralBinder <$> parseBooleanLiteral - , parseNumberLiteral - , parseVarOrNamedBinder - , parseConstructorBinder - , parseObjectBinder - , parseArrayBinder - , ParensInBinder <$> parens parseBinder - ] P. "binder" parseOpBinder :: TokenParser Binder - parseOpBinder = OpBinder <$> parseQualified (Op <$> symbol) + parseOpBinder = OpBinder <$> parseQualified parseOperator + +parseBinderAtom :: TokenParser Binder +parseBinderAtom = P.choice + [ parseNullBinder + , LiteralBinder <$> parseCharLiteral + , LiteralBinder <$> parseStringLiteral + , LiteralBinder <$> parseBooleanLiteral + , parseNumberLiteral + , parseVarOrNamedBinder + , parseConstructorBinder + , parseObjectBinder + , parseArrayBinder + , ParensInBinder <$> parens parseBinder + ] P. "binder" -- | -- Parse a binder as it would appear in a top level declaration diff --git a/src/Language/PureScript/Parser/JS.hs b/src/Language/PureScript/Parser/JS.hs deleted file mode 100644 --- a/src/Language/PureScript/Parser/JS.hs +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Foreign --- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors --- License : MIT --- --- Maintainer : Phil Freeman , Gary Burgess --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -{-# LANGUAGE FlexibleContexts #-} - -module Language.PureScript.Parser.JS - ( ForeignJS() - , parseForeignModulesFromFiles - ) where - -import Prelude () -import Prelude.Compat hiding (lex) - -import Control.Monad (forM_, when, msum) -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer.Class (MonadWriter(..)) -import Data.Function (on) -import Data.List (sortBy, groupBy) -import Language.PureScript.Errors -import Language.PureScript.Names -import Language.PureScript.Parser.Common -import Language.PureScript.Parser.Lexer -import qualified Data.Map as M -import qualified Text.Parsec as PS - -type ForeignJS = String - -parseForeignModulesFromFiles :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => [(FilePath, ForeignJS)] - -> m (M.Map ModuleName FilePath) -parseForeignModulesFromFiles files = do - foreigns <- parU files $ \(path, file) -> - case findModuleName (lines file) of - Just name -> return (name, path) - Nothing -> throwError (errorMessage $ ErrorParsingFFIModule path Nothing) - let grouped = groupBy ((==) `on` fst) $ sortBy (compare `on` fst) foreigns - forM_ grouped $ \grp -> - when (length grp > 1) $ do - let mn = fst (head grp) - paths = map snd grp - tell $ errorMessage $ MultipleFFIModules mn paths - return $ M.fromList foreigns - -findModuleName :: [String] -> Maybe ModuleName -findModuleName = msum . map parseComment - where - parseComment :: String -> Maybe ModuleName - parseComment s = either (const Nothing) Just $ - lex "" s >>= runTokenParser "" (symbol' "//" *> reserved "module" *> moduleName <* PS.eof) diff --git a/src/Language/PureScript/Parser/Kinds.hs b/src/Language/PureScript/Parser/Kinds.hs --- a/src/Language/PureScript/Parser/Kinds.hs +++ b/src/Language/PureScript/Parser/Kinds.hs @@ -1,28 +1,14 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Parser.Kinds --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- A parser for kinds -- ------------------------------------------------------------------------------ - -module Language.PureScript.Parser.Kinds ( - parseKind -) where +module Language.PureScript.Parser.Kinds (parseKind) where -import Prelude () import Prelude.Compat import Language.PureScript.Kinds import Language.PureScript.Parser.Common import Language.PureScript.Parser.Lexer + import qualified Text.Parsec as P import qualified Text.Parsec.Expr as P @@ -32,10 +18,14 @@ parseBang :: TokenParser Kind parseBang = const Bang <$> symbol' "!" +parseSymbol :: TokenParser Kind +parseSymbol = const Symbol <$> uname' "Symbol" + parseTypeAtom :: TokenParser Kind parseTypeAtom = indented *> P.choice [ parseStar , parseBang + , parseSymbol , parens parseKind ] -- | diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs --- a/src/Language/PureScript/Parser/Lexer.hs +++ b/src/Language/PureScript/Parser/Lexer.hs @@ -1,20 +1,6 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Parser.Lexer --- Copyright : (c) Phil Freeman 2014 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- The first step in the parsing process - turns source code into a list of lexemes -- ------------------------------------------------------------------------------ - -{-# LANGUAGE TupleSections #-} - module Language.PureScript.Parser.Lexer ( PositionedToken(..) , Token() @@ -55,6 +41,7 @@ , commaSep1 , lname , qualifier + , tyname , uname , uname' , mname @@ -75,15 +62,14 @@ import Prelude hiding (lex) -import Data.Char (isSpace, isAscii, isSymbol, isAlphaNum) - +import Control.Applicative import Control.Monad (void, guard) -import Data.Functor.Identity -import Control.Applicative +import Data.Char (isSpace, isAscii, isSymbol, isAlphaNum) +import Data.Functor.Identity -import Language.PureScript.Parser.State import Language.PureScript.Comments +import Language.PureScript.Parser.State import qualified Text.Parsec as P import qualified Text.Parsec.Token as PT @@ -152,7 +138,12 @@ prettyPrintToken (HoleLit name) = "?" ++ name data PositionedToken = PositionedToken - { ptSourcePos :: P.SourcePos + { -- | Start position of this token + ptSourcePos :: P.SourcePos + -- | End position of this token (not including whitespace) + , ptEndPos :: P.SourcePos + -- | End position of the previous token + , ptPrevEndPos :: Maybe P.SourcePos , ptToken :: Token , ptComments :: [Comment] } deriving (Eq) @@ -162,8 +153,14 @@ show = prettyPrintToken . ptToken lex :: FilePath -> String -> Either P.ParseError [PositionedToken] -lex = P.parse parseTokens +lex f s = updatePositions <$> P.parse parseTokens f s +updatePositions :: [PositionedToken] -> [PositionedToken] +updatePositions [] = [] +updatePositions (x:xs) = x : zipWith update (x:xs) xs + where + update PositionedToken { ptEndPos = pos } pt = pt { ptPrevEndPos = Just pos } + parseTokens :: P.Parsec String u [PositionedToken] parseTokens = whitespace *> P.many parsePositionedToken <* P.skipMany parseComment <* P.eof @@ -184,7 +181,9 @@ comments <- P.many parseComment pos <- P.getPosition tok <- parseToken - return $ PositionedToken pos tok comments + pos' <- P.getPosition + whitespace + return $ PositionedToken pos pos' Nothing tok comments parseToken :: P.Parsec String u Token parseToken = P.choice @@ -215,20 +214,21 @@ , P.try $ P.char '_' *> P.notFollowedBy identLetter *> pure Underscore , HoleLit <$> P.try (P.char '?' *> P.many1 identLetter) , LName <$> parseLName - , do uName <- parseUName - (guard (validModuleName uName) >> Qualifier uName <$ P.char '.') <|> pure (UName uName) + , parseUName >>= \uName -> + (guard (validModuleName uName) >> Qualifier uName <$ P.char '.') + <|> pure (UName uName) , Symbol <$> parseSymbol , CharLiteral <$> parseCharLiteral , StringLiteral <$> parseStringLiteral , Number <$> parseNumber - ] <* whitespace + ] where parseLName :: P.Parsec String u String parseLName = (:) <$> identStart <*> P.many identLetter parseUName :: P.Parsec String u String - parseUName = (:) <$> P.upper <*> P.many uidentLetter + parseUName = (:) <$> P.upper <*> P.many identLetter parseSymbol :: P.Parsec String u String parseSymbol = P.many1 symbolChar @@ -239,9 +239,6 @@ identLetter :: P.Parsec String u Char identLetter = P.alphaNum <|> P.oneOf "_'" - uidentLetter :: P.Parsec String u Char - uidentLetter = P.alphaNum <|> P.char '_' - symbolChar :: P.Parsec String u Char symbolChar = P.satisfy isSymbolChar @@ -433,6 +430,18 @@ uname :: TokenParser String uname = token go P. "proper name" where + go (UName s) | validUName s = Just s + go _ = Nothing + +uname' :: String -> TokenParser () +uname' s = token go P. "proper name" + where + go (UName s') | s == s' = Just () + go _ = Nothing + +tyname :: TokenParser String +tyname = token go P. "type name" + where go (UName s) = Just s go _ = Nothing @@ -442,12 +451,6 @@ go (UName s) | validModuleName s = Just s go _ = Nothing -uname' :: String -> TokenParser () -uname' s = token go P. show s - where - go (UName s') | s == s' = Just () - go _ = Nothing - symbol :: TokenParser String symbol = token go P. "symbol" where @@ -497,6 +500,9 @@ validModuleName :: String -> Bool validModuleName s = '_' `notElem` s + +validUName :: String -> Bool +validUName s = '\'' `notElem` s -- | -- A list of purescript reserved identifiers diff --git a/src/Language/PureScript/Parser/State.hs b/src/Language/PureScript/Parser/State.hs --- a/src/Language/PureScript/Parser/State.hs +++ b/src/Language/PureScript/Parser/State.hs @@ -1,20 +1,10 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Parser.State --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- State for the parser monad -- ------------------------------------------------------------------------------ - module Language.PureScript.Parser.State where +import Prelude.Compat + import qualified Text.Parsec as P -- | @@ -26,5 +16,3 @@ -- indentationLevel :: P.Column } deriving Show - - diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -1,19 +1,21 @@ -module Language.PureScript.Parser.Types ( - parseType, - parsePolyType, - noWildcards, - parseTypeAtom -) where +module Language.PureScript.Parser.Types + ( parseType + , parsePolyType + , noWildcards + , parseTypeAtom + ) where +import Prelude.Compat + import Control.Applicative import Control.Monad (when, unless) -import Language.PureScript.Names -import Language.PureScript.Types +import Language.PureScript.AST.SourcePos +import Language.PureScript.Environment import Language.PureScript.Parser.Common import Language.PureScript.Parser.Kinds import Language.PureScript.Parser.Lexer -import Language.PureScript.Environment +import Language.PureScript.Types import qualified Text.Parsec as P import qualified Text.Parsec.Expr as P @@ -22,10 +24,17 @@ parseFunction = parens rarrow >> return tyFunction parseObject :: TokenParser Type -parseObject = braces $ TypeApp tyObject <$> parseRow +parseObject = braces $ TypeApp tyRecord <$> parseRow +parseTypeLevelString :: TokenParser Type +parseTypeLevelString = TypeLevelString <$> stringLiteral + parseTypeWildcard :: TokenParser Type -parseTypeWildcard = underscore >> return TypeWildcard +parseTypeWildcard = do + start <- P.getPosition + let end = P.incSourceColumn start 1 + underscore + return $ TypeWildcard (SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end)) parseTypeVariable :: TokenParser Type parseTypeVariable = do @@ -34,7 +43,7 @@ return $ TypeVar ident parseTypeConstructor :: TokenParser Type -parseTypeConstructor = TypeConstructor <$> parseQualified properName +parseTypeConstructor = TypeConstructor <$> parseQualified typeName parseForAll :: TokenParser Type parseForAll = mkForAll <$> ((reserved "forall" <|> reserved "∀") *> P.many1 (indented *> identifier) <* indented <* dot) @@ -47,6 +56,7 @@ parseTypeAtom = indented *> P.choice [ P.try parseConstrainedType , P.try parseFunction + , parseTypeLevelString , parseObject , parseTypeWildcard , parseForAll @@ -69,16 +79,16 @@ className <- parseQualified properName indented ty <- P.many parseTypeAtom - return (className, ty) + return (Constraint className ty Nothing) parseAnyType :: TokenParser Type parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P. "type" where - operators = [ [ P.Infix (P.try (parseQualified (Op <$> symbol)) >>= \ident -> + operators = [ [ P.Infix (return TypeApp) P.AssocLeft ] + , [ P.Infix (P.try (parseQualified parseOperator) >>= \ident -> return (BinaryNoParensType (TypeOp ident))) P.AssocRight ] - , [ P.Infix (return TypeApp) P.AssocLeft ] , [ P.Infix (rarrow >> return function) P.AssocRight ] ] postfixTable = [ \t -> KindedType t <$> (indented *> doubleColon *> parseKind) diff --git a/src/Language/PureScript/Pretty.hs b/src/Language/PureScript/Pretty.hs --- a/src/Language/PureScript/Pretty.hs +++ b/src/Language/PureScript/Pretty.hs @@ -1,13 +1,3 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Pretty --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- A collection of pretty printers for core data types: -- @@ -19,11 +9,9 @@ -- -- [@Language.PureScript.Pretty.JS@] Pretty printer for values, used for code generation -- ------------------------------------------------------------------------------ - module Language.PureScript.Pretty (module P) where +import Language.PureScript.Pretty.JS as P import Language.PureScript.Pretty.Kinds as P -import Language.PureScript.Pretty.Values as P import Language.PureScript.Pretty.Types as P -import Language.PureScript.Pretty.JS as P +import Language.PureScript.Pretty.Values as P diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -1,30 +1,18 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Pretty.Common --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + -- | -- Common pretty-printing utility functions -- ------------------------------------------------------------------------------ - -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - module Language.PureScript.Pretty.Common where -import Prelude () import Prelude.Compat import Control.Monad.State (StateT, modify, get) + import Data.List (elemIndices, intersperse) -import Language.PureScript.Parser.Lexer (reservedPsNames, isUnquotedKey) import Language.PureScript.AST (SourcePos(..), SourceSpan(..)) +import Language.PureScript.Parser.Lexer (reservedPsNames, isUnquotedKey) import Text.PrettyPrint.Boxes @@ -165,3 +153,7 @@ beforeWithSpace :: Box -> Box -> Box beforeWithSpace b1 = before (b1 <> text " ") + +-- | Place a Box on the bottom right of another +endWith :: Box -> Box -> Box +endWith l r = l <> vcat top [emptyBox (rows l - 1) (cols r), r] diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -1,44 +1,29 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Pretty.JS --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- Pretty printer for the Javascript AST -- ------------------------------------------------------------------------------ - -module Language.PureScript.Pretty.JS ( - prettyPrintJS, prettyPrintJSWithSourceMaps -) where +module Language.PureScript.Pretty.JS + ( prettyPrintJS + , prettyPrintJSWithSourceMaps + ) where -import Prelude () import Prelude.Compat -import Data.Maybe (fromMaybe) - import Control.Arrow ((<+>)) import Control.Monad.State hiding (sequence) import Control.PatternArrows import qualified Control.Arrow as A -import Language.PureScript.Crash +import Data.Maybe (fromMaybe) +import Data.Monoid + +import Language.PureScript.AST (SourceSpan(..)) import Language.PureScript.CodeGen.JS.AST import Language.PureScript.CodeGen.JS.Common -import Language.PureScript.Pretty.Common import Language.PureScript.Comments - - -import Language.PureScript.AST (SourceSpan(..)) +import Language.PureScript.Crash +import Language.PureScript.Pretty.Common import Numeric - -import Data.Monoid literals :: (Emit gen) => Pattern PrinterState JS gen literals = mkPattern' match' diff --git a/src/Language/PureScript/Pretty/Kinds.hs b/src/Language/PureScript/Pretty/Kinds.hs --- a/src/Language/PureScript/Pretty/Kinds.hs +++ b/src/Language/PureScript/Pretty/Kinds.hs @@ -1,27 +1,17 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Pretty.Kinds --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- Pretty printer for kinds -- ------------------------------------------------------------------------------ - -module Language.PureScript.Pretty.Kinds ( - prettyPrintKind -) where +module Language.PureScript.Pretty.Kinds + ( prettyPrintKind + ) where -import Data.Maybe (fromMaybe) +import Prelude.Compat import Control.Arrow (ArrowPlus(..)) -import Control.PatternArrows +import Control.PatternArrows as PA +import Data.Maybe (fromMaybe) + import Language.PureScript.Crash import Language.PureScript.Kinds import Language.PureScript.Pretty.Common @@ -31,6 +21,7 @@ where match Star = Just "*" match Bang = Just "!" + match Symbol = Just "Symbol" match (KUnknown u) = Just $ 'u' : show u match _ = Nothing @@ -48,7 +39,9 @@ -- | Generate a pretty-printed string representing a Kind prettyPrintKind :: Kind -> String -prettyPrintKind = fromMaybe (internalError "Incomplete pattern") . pattern matchKind () +prettyPrintKind + = fromMaybe (internalError "Incomplete pattern") + . PA.pattern matchKind () where matchKind :: Pattern () Kind String matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind) diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -10,40 +10,43 @@ , prettyPrintRow ) where -import Data.Maybe (fromMaybe) +import Prelude.Compat import Control.Arrow ((<+>)) -import Control.PatternArrows +import Control.PatternArrows as PA +import Data.Maybe (fromMaybe) + import Language.PureScript.Crash -import Language.PureScript.Types -import Language.PureScript.Names +import Language.PureScript.Environment import Language.PureScript.Kinds +import Language.PureScript.Names import Language.PureScript.Pretty.Common import Language.PureScript.Pretty.Kinds -import Language.PureScript.Environment +import Language.PureScript.Types import Text.PrettyPrint.Boxes hiding ((<+>)) typeLiterals :: Pattern () Type Box typeLiterals = mkPattern match where - match TypeWildcard = Just $ text "_" + match TypeWildcard{} = Just $ text "_" match (TypeVar var) = Just $ text var + match (TypeLevelString s) = Just . text $ show s match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor - match (TUnknown u) = Just $ text $ '_' : show u + match (TUnknown u) = Just $ text $ 't' : show u match (Skolem name s _ _) = Just $ text $ name ++ show s match REmpty = Just $ text "()" match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row match (BinaryNoParensType op l r) = Just $ typeAsBox l <> text " " <> typeAsBox op <> text " " <> typeAsBox r - match (TypeOp op) = Just $ text $ showQualified runIdent op + match (TypeOp op) = Just $ text $ showQualified runOpName op match _ = Nothing constraintsAsBox :: [Constraint] -> Box -> Box -constraintsAsBox [(pn, tys)] ty = text "(" <> constraintAsBox pn tys <> text ") => " <> ty -constraintsAsBox xs ty = vcat left (zipWith (\i (pn, tys) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] xs) `before` (text ") => " <> ty) +constraintsAsBox [(Constraint pn tys _)] ty = text "(" <> constraintAsBox pn tys <> text ") => " <> ty +constraintsAsBox xs ty = vcat left (zipWith (\i (Constraint pn tys _) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] xs) `before` (text ") => " <> ty) constraintAsBox :: Qualified (ProperName a) -> [Type] -> Box constraintAsBox pn tys = hsep 1 left (text (runProperName (disqualify pn)) : map typeAtomAsBox tys) @@ -97,7 +100,7 @@ insertPlaceholders = everywhereOnTypesTopDown convertForAlls . everywhereOnTypes convert where convert (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret - convert (TypeApp o r) | o == tyObject = PrettyPrintObject r + convert (TypeApp o r) | o == tyRecord = PrettyPrintObject r convert other = other convertForAlls (ForAll ident ty _) = go [ident] ty where @@ -147,14 +150,20 @@ match _ = Nothing typeAtomAsBox :: Type -> Box -typeAtomAsBox = fromMaybe (internalError "Incomplete pattern") . pattern matchTypeAtom () . insertPlaceholders +typeAtomAsBox + = fromMaybe (internalError "Incomplete pattern") + . PA.pattern matchTypeAtom () + . insertPlaceholders -- | Generate a pretty-printed string representing a Type, as it should appear inside parentheses prettyPrintTypeAtom :: Type -> String prettyPrintTypeAtom = render . typeAtomAsBox typeAsBox :: Type -> Box -typeAsBox = fromMaybe (internalError "Incomplete pattern") . pattern matchType () . insertPlaceholders +typeAsBox + = fromMaybe (internalError "Incomplete pattern") + . PA.pattern matchType () + . insertPlaceholders -- | Generate a pretty-printed string representing a Type prettyPrintType :: Type -> String diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -1,19 +1,22 @@ -- | -- Pretty printer for values -- -module Language.PureScript.Pretty.Values ( - prettyPrintValue, - prettyPrintBinder, - prettyPrintBinderAtom -) where +module Language.PureScript.Pretty.Values + ( prettyPrintValue + , prettyPrintBinder + , prettyPrintBinderAtom + ) where +import Prelude.Compat + import Control.Arrow (second) -import Language.PureScript.Crash import Language.PureScript.AST +import Language.PureScript.Crash import Language.PureScript.Names import Language.PureScript.Pretty.Common import Language.PureScript.Pretty.Types (typeAsBox, typeAtomAsBox) +import Language.PureScript.Types (Constraint(..)) import Text.PrettyPrint.Boxes @@ -57,7 +60,7 @@ (text "in " <> prettyPrintValue (d - 1) val) prettyPrintValue d (Do els) = text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els) -prettyPrintValue _ (TypeClassDictionary (name, tys) _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys +prettyPrintValue _ (TypeClassDictionary (Constraint name tys _) _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys prettyPrintValue _ (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name) prettyPrintValue _ (TypeClassDictionaryAccessor className ident) = text "#dict-accessor " <> text (runProperName (disqualify className)) <> text "." <> text (showIdent ident) <> text ">" @@ -68,7 +71,7 @@ prettyPrintValue d expr@AnonymousArgument{} = prettyPrintValueAtom d expr prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr prettyPrintValue d expr@Var{} = prettyPrintValueAtom d expr -prettyPrintValue d expr@OperatorSection{} = prettyPrintValueAtom d expr +prettyPrintValue d expr@Op{} = prettyPrintValueAtom d expr prettyPrintValue d expr@BinaryNoParens{} = prettyPrintValueAtom d expr prettyPrintValue d expr@Parens{} = prettyPrintValueAtom d expr prettyPrintValue d expr@UnaryMinus{} = prettyPrintValueAtom d expr @@ -80,12 +83,10 @@ prettyPrintValueAtom _ AnonymousArgument = text "_" prettyPrintValueAtom _ (Constructor name) = text $ runProperName (disqualify name) prettyPrintValueAtom _ (Var ident) = text $ showIdent (disqualify ident) -prettyPrintValueAtom d (OperatorSection op (Right val)) = ((text "(" <> prettyPrintValue (d - 1) op) `beforeWithSpace` prettyPrintValue (d - 1) val) `before` text ")" -prettyPrintValueAtom d (OperatorSection op (Left val)) = ((text "(" <> prettyPrintValue (d - 1) val) `beforeWithSpace` prettyPrintValue (d - 1) op) `before` text ")" prettyPrintValueAtom d (BinaryNoParens op lhs rhs) = prettyPrintValue (d - 1) lhs `beforeWithSpace` printOp op `beforeWithSpace` prettyPrintValue (d - 1) rhs where - printOp (Var (Qualified _ (Op opName))) = text opName + printOp (Op (Qualified _ name)) = text (runOpName name) printOp expr = text "`" <> prettyPrintValue (d - 1) expr <> text "`" prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val @@ -154,7 +155,7 @@ prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident ++ "@" ++ prettyPrintBinder binder prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder prettyPrintBinderAtom (TypedBinder _ binder) = prettyPrintBinderAtom binder -prettyPrintBinderAtom (OpBinder op) = showIdent (disqualify op) +prettyPrintBinderAtom (OpBinder op) = runOpName (disqualify op) prettyPrintBinderAtom (BinaryNoParensBinder op b1 b2) = prettyPrintBinderAtom b1 ++ " " ++ prettyPrintBinderAtom op ++ " " ++ prettyPrintBinderAtom b2 prettyPrintBinderAtom (ParensInBinder b) = parens (prettyPrintBinder b) diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Publish ( preparePackage @@ -23,47 +21,46 @@ , getResolvedDependencies ) where -import Prelude () import Prelude.Compat hiding (userError) -import Data.Maybe +import Control.Arrow ((***)) +import Control.Category ((>>>)) +import Control.Exception (catch, try) +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +import Control.Monad.Writer.Strict + +import Data.Aeson.BetterErrors import Data.Char (isSpace) +import Data.Foldable (traverse_) +import Data.Function (on) import Data.List (stripPrefix, isSuffixOf, (\\), nubBy) -import Data.List.Split (splitOn) import Data.List.NonEmpty (NonEmpty(..)) +import Data.List.Split (splitOn) +import Data.Maybe import Data.Version -import Data.Function (on) -import Data.Foldable (traverse_) -import Safe (headMay) -import Data.Aeson.BetterErrors +import qualified Data.SPDX as SPDX import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL -import qualified Data.SPDX as SPDX -import Control.Category ((>>>)) -import Control.Arrow ((***)) -import Control.Exception (catch, try) -import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) -import Control.Monad.Trans.Except -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer.Strict +import Safe (headMay) import System.Directory (doesFileExist, findExecutable) -import System.Process (readProcess) import System.Exit (exitFailure) import System.FilePath (pathSeparator) +import System.Process (readProcess) import qualified System.FilePath.Glob as Glob import qualified System.Info -import Web.Bower.PackageMeta (PackageMeta(..), BowerError(..), PackageName, - runPackageName, parsePackageName, Repository(..)) +import Web.Bower.PackageMeta (PackageMeta(..), BowerError(..), PackageName, runPackageName, parsePackageName, Repository(..)) import qualified Web.Bower.PackageMeta as Bower +import Language.PureScript.Publish.ErrorsWarnings +import Language.PureScript.Publish.Utils import qualified Language.PureScript as P (version) import qualified Language.PureScript.Docs as D -import Language.PureScript.Publish.Utils -import Language.PureScript.Publish.ErrorsWarnings data PublishOptions = PublishOptions { -- | How to obtain the version tag and version that the data being @@ -216,8 +213,12 @@ checkLicense :: PackageMeta -> PrepareM () checkLicense pkgMeta = - unless (any isValidSPDX (bowerLicense pkgMeta)) - (userError NoLicenseSpecified) + case bowerLicense pkgMeta of + [] -> + userError NoLicenseSpecified + ls -> + unless (any isValidSPDX ls) + (userError InvalidLicense) -- | -- Check if a string is a valid SPDX license expression. diff --git a/src/Language/PureScript/Publish/BoxesHelpers.hs b/src/Language/PureScript/Publish/BoxesHelpers.hs --- a/src/Language/PureScript/Publish/BoxesHelpers.hs +++ b/src/Language/PureScript/Publish/BoxesHelpers.hs @@ -4,7 +4,10 @@ , module Language.PureScript.Publish.BoxesHelpers ) where +import Prelude.Compat + import System.IO (hPutStr, stderr) + import qualified Text.PrettyPrint.Boxes as Boxes width :: Int diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} module Language.PureScript.Publish.ErrorsWarnings ( PackageError(..) @@ -16,26 +15,24 @@ , renderWarnings ) where -import Prelude () import Prelude.Compat +import Control.Exception (IOException) + import Data.Aeson.BetterErrors -import Data.Version -import Data.Maybe -import Data.Monoid import Data.List (intersperse, intercalate) import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe +import Data.Monoid +import Data.Version import qualified Data.List.NonEmpty as NonEmpty - import qualified Data.Text as T -import Control.Exception (IOException) -import Web.Bower.PackageMeta (BowerError, PackageName, runPackageName, showBowerError) -import qualified Web.Bower.PackageMeta as Bower - +import Language.PureScript.Publish.BoxesHelpers import qualified Language.PureScript as P -import Language.PureScript.Publish.BoxesHelpers +import Web.Bower.PackageMeta (BowerError, PackageName, runPackageName, showBowerError) +import qualified Web.Bower.PackageMeta as Bower -- | An error which meant that it was not possible to retrieve metadata for a -- package. @@ -55,13 +52,13 @@ -- | An error that should be fixed by the user. data UserError = BowerJSONNotFound - | LicenseNotFound | BowerExecutableNotFound [String] -- list of executable names tried | CouldntDecodeBowerJSON (ParseError BowerError) | TagMustBeCheckedOut | AmbiguousVersions [Version] -- Invariant: should contain at least two elements | BadRepositoryField RepositoryFieldError | NoLicenseSpecified + | InvalidLicense | MissingDependencies (NonEmpty PackageName) | CompileError P.MultipleErrors | DirtyWorkingTree @@ -129,12 +126,6 @@ "The bower.json file was not found. Please create one, or run " ++ "`pulp init`." ) - LicenseNotFound -> - para (concat - ["No LICENSE file was found. Please create one. ", - "Distributing code without a license means that nobody ", - "will be able to (legally) use it." - ]) BowerExecutableNotFound names -> para (concat [ "The Bower executable was not found (tried: ", format names, "). Please" @@ -189,14 +180,7 @@ , "following would be acceptable:" ]) , spacer - ] ++ - map (indented . para) - [ "* \"MIT\"" - , "* \"BSD-2-Clause\"" - , "* \"GPL-2.0+\"" - , "* \"(GPL-3.0 OR MIT)\"" - ] - ++ + ] ++ spdxExamples ++ [ spacer , para (concat [ "Note that distributing code without a license means that nobody " @@ -209,6 +193,16 @@ , "necessary." ]) ] + InvalidLicense -> + vcat $ + [ para (concat + [ "The license specified in bower.json is not a valid SPDX license " + , "expression. Please use the SPDX license expression format. For " + , "example, any of the following would be acceptable:" + ]) + , spacer + ] ++ + spdxExamples MissingDependencies pkgs -> let singular = NonEmpty.length pkgs == 1 pl a b = if singular then b else a @@ -231,13 +225,23 @@ CompileError err -> vcat [ para "Compile error:" - , indented (vcat (P.prettyPrintMultipleErrorsBox False err)) + , indented (vcat (P.prettyPrintMultipleErrorsBox P.defaultPPEOptions err)) ] DirtyWorkingTree -> para ( "Your git working tree is dirty. Please commit, discard, or stash " ++ "your changes first." ) + +spdxExamples :: [Box] +spdxExamples = + map (indented . para) + [ "* \"MIT\"" + , "* \"Apache-2.0\"" + , "* \"BSD-2-Clause\"" + , "* \"GPL-2.0+\"" + , "* \"(GPL-3.0 OR MIT)\"" + ] displayRepositoryError :: RepositoryFieldError -> Box displayRepositoryError err = case err of diff --git a/src/Language/PureScript/Publish/Utils.hs b/src/Language/PureScript/Publish/Utils.hs --- a/src/Language/PureScript/Publish/Utils.hs +++ b/src/Language/PureScript/Publish/Utils.hs @@ -1,38 +1,41 @@ - -module Language.PureScript.Publish.Utils where - -import Data.List -import Data.Either (partitionEithers) -import System.Directory -import System.Exit (exitFailure) -import System.IO (hPutStrLn, stderr) -import System.FilePath (pathSeparator) -import qualified System.FilePath.Glob as Glob - --- | Glob relative to the current directory, and produce relative pathnames. -globRelative :: Glob.Pattern -> IO [FilePath] -globRelative pat = do - currentDir <- getCurrentDirectory - filesAbsolute <- Glob.globDir1 pat currentDir - let prefix = currentDir ++ [pathSeparator] - let (fails, paths) = partitionEithers . map (stripPrefix' prefix) $ filesAbsolute - if null fails - then return paths - else do - let p = hPutStrLn stderr - p "Internal error in Language.PureScript.Publish.Utils.globRelative" - p "Unmatched files:" - mapM_ p fails - exitFailure - - where - stripPrefix' prefix dir = - maybe (Left dir) Right $ stripPrefix prefix dir - --- | Glob pattern for PureScript source files. -purescriptSourceFiles :: Glob.Pattern -purescriptSourceFiles = Glob.compile "src/**/*.purs" - --- | Glob pattern for PureScript dependency files. -purescriptDepsFiles :: Glob.Pattern -purescriptDepsFiles = Glob.compile "bower_components/*/src/**/*.purs" + +module Language.PureScript.Publish.Utils where + +import Prelude.Compat + +import Data.Either (partitionEithers) +import Data.List + +import System.Directory +import System.Exit (exitFailure) +import System.FilePath (pathSeparator) +import System.IO (hPutStrLn, stderr) +import qualified System.FilePath.Glob as Glob + +-- | Glob relative to the current directory, and produce relative pathnames. +globRelative :: Glob.Pattern -> IO [FilePath] +globRelative pat = do + currentDir <- getCurrentDirectory + filesAbsolute <- Glob.globDir1 pat currentDir + let prefix = currentDir ++ [pathSeparator] + let (fails, paths) = partitionEithers . map (stripPrefix' prefix) $ filesAbsolute + if null fails + then return paths + else do + let p = hPutStrLn stderr + p "Internal error in Language.PureScript.Publish.Utils.globRelative" + p "Unmatched files:" + mapM_ p fails + exitFailure + + where + stripPrefix' prefix dir = + maybe (Left dir) Right $ stripPrefix prefix dir + +-- | Glob pattern for PureScript source files. +purescriptSourceFiles :: Glob.Pattern +purescriptSourceFiles = Glob.compile "src/**/*.purs" + +-- | Glob pattern for PureScript dependency files. +purescriptDepsFiles :: Glob.Pattern +purescriptDepsFiles = Glob.compile "bower_components/*/src/**/*.purs" diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -1,26 +1,20 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - -- | -- Renaming pass that prevents shadowing of local identifiers. -- module Language.PureScript.Renamer (renameInModules) where -import Prelude () import Prelude.Compat import Control.Monad.State import Data.List (find) import Data.Maybe (fromJust, fromMaybe) - import qualified Data.Map as M import qualified Data.Set as S import Language.PureScript.CoreFn import Language.PureScript.Names import Language.PureScript.Traversals - import qualified Language.PureScript.Constants as C -- | diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -1,35 +1,20 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Sugar --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- Desugaring passes -- ------------------------------------------------------------------------------ - -{-# LANGUAGE FlexibleContexts #-} - module Language.PureScript.Sugar (desugar, module S) where -import Prelude () -import Prelude.Compat - -import Control.Monad import Control.Category ((>>>)) +import Control.Monad import Control.Monad.Error.Class (MonadError()) -import Control.Monad.Writer.Class (MonadWriter()) import Control.Monad.Supply.Class +import Control.Monad.Writer.Class (MonadWriter()) +import Data.List (map) +import Data.Traversable (traverse) + import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.Externs - import Language.PureScript.Sugar.BindingGroups as S import Language.PureScript.Sugar.CaseDeclarations as S import Language.PureScript.Sugar.DoNotation as S @@ -49,7 +34,7 @@ -- -- * Desugar operator sections -- --- * Desugar do-notation using the @Prelude.Monad@ type class +-- * Desugar do-notation -- -- * Desugar top-level case declarations into explicit case expressions -- @@ -63,16 +48,20 @@ -- -- * Group mutually recursive value and data declarations into binding groups. -- -desugar :: (MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module] +desugar + :: (MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => [ExternsFile] + -> [Module] + -> m [Module] desugar externs = - map removeSignedLiterals + map desugarSignedLiterals >>> traverse desugarObjectConstructors - >=> traverse desugarOperatorSections >=> traverse desugarDoModule - >=> desugarCasesModule - >=> desugarTypeDeclarationsModule + >=> traverse desugarCasesModule + >=> traverse desugarTypeDeclarationsModule >=> desugarImports externs >=> rebracket externs + >=> traverse checkFixityExports >=> traverse deriveInstances >=> desugarTypeClasses externs - >=> createBindingGroupsModule + >=> traverse createBindingGroupsModule diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE LambdaCase #-} - -- | -- This module implements the desugaring pass which creates binding groups from sets of -- mutually-recursive value declarations and mutually-recursive type declarations. @@ -13,7 +9,6 @@ , collapseBindingGroupsModule ) where -import Prelude () import Prelude.Compat import Control.Monad ((<=<)) @@ -36,11 +31,10 @@ -- createBindingGroupsModule :: (MonadError MultipleErrors m) - => [Module] - -> m [Module] -createBindingGroupsModule = - mapM $ \(Module ss coms name ds exps) -> - Module ss coms name <$> createBindingGroups name ds <*> pure exps + => Module + -> m Module +createBindingGroupsModule (Module ss coms name ds exps) = + Module ss coms name <$> createBindingGroups name ds <*> pure exps -- | -- Collapse all binding groups in a module to individual declarations @@ -72,11 +66,11 @@ handleDecls ds = do let values = filter isValueDecl ds dataDecls = filter isDataDecl ds - allProperNames = map getTypeName dataDecls - dataVerts = map (\d -> (d, getTypeName d, usedTypeNames moduleName d `intersect` allProperNames)) dataDecls + allProperNames = map declTypeName dataDecls + dataVerts = map (\d -> (d, declTypeName d, usedTypeNames moduleName d `intersect` allProperNames)) dataDecls dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup - let allIdents = map getIdent values - valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values + let allIdents = map declIdent values + valueVerts = map (\d -> (d, declIdent d, usedIdents moduleName d `intersect` allIdents)) values bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName) return $ filter isImportDecl ds ++ filter isExternDataDecl ds ++ @@ -147,23 +141,23 @@ usedNames :: Type -> [ProperName 'TypeName] usedNames (ConstrainedType constraints _) = flip mapMaybe constraints $ \case - (Qualified (Just moduleName') name, _) + (Constraint (Qualified (Just moduleName') name) _ _) | moduleName == moduleName' -> Just (coerceProperName name) _ -> Nothing usedNames (TypeConstructor (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name] usedNames _ = [] -getIdent :: Declaration -> Ident -getIdent (ValueDeclaration ident _ _ _) = ident -getIdent (PositionedDeclaration _ _ d) = getIdent d -getIdent _ = internalError "Expected ValueDeclaration" +declIdent :: Declaration -> Ident +declIdent (ValueDeclaration ident _ _ _) = ident +declIdent (PositionedDeclaration _ _ d) = declIdent d +declIdent _ = internalError "Expected ValueDeclaration" -getTypeName :: Declaration -> ProperName 'TypeName -getTypeName (DataDeclaration _ pn _ _) = pn -getTypeName (TypeSynonymDeclaration pn _ _) = pn -getTypeName (PositionedDeclaration _ _ d) = getTypeName d -getTypeName _ = internalError "Expected DataDeclaration" +declTypeName :: Declaration -> ProperName 'TypeName +declTypeName (DataDeclaration _ pn _ _) = pn +declTypeName (TypeSynonymDeclaration pn _ _) = pn +declTypeName (PositionedDeclaration _ _ d) = declTypeName d +declTypeName _ = internalError "Expected DataDeclaration" -- | -- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration). @@ -192,7 +186,7 @@ idents = map (\(_, i, _) -> i) valueVerts valueVerts :: [(Declaration, Ident, [Ident])] - valueVerts = map (\d -> (d, getIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds' + valueVerts = map (\d -> (d, declIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds' toBinding :: SCC Declaration -> m (Ident, NameKind, Expr) toBinding (AcyclicSCC d) = return $ fromValueDecl d diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -1,45 +1,42 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - -- | -- This module implements the desugaring pass which replaces top-level binders with -- case expressions. -- -module Language.PureScript.Sugar.CaseDeclarations ( - desugarCases, - desugarCasesModule -) where +module Language.PureScript.Sugar.CaseDeclarations + ( desugarCases + , desugarCasesModule + ) where -import Prelude () import Prelude.Compat -import Language.PureScript.Crash -import Data.Maybe (catMaybes, mapMaybe) +import Data.Either (isLeft) import Data.List (nub, groupBy, foldl1') +import Data.Maybe (catMaybes, mapMaybe) -import Control.Monad ((<=<), forM, replicateM, join, unless) +import Control.Monad ((<=<), replicateM, join, unless) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Supply.Class -import Language.PureScript.Names import Language.PureScript.AST +import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors +import Language.PureScript.Names import Language.PureScript.Traversals import Language.PureScript.TypeChecker.Monad (guardWith) --- Data.Either.isLeft (base 4.7) -isLeft :: Either a b -> Bool -isLeft (Left _) = True -isLeft (Right _) = False - -- | -- Replace all top-level binders in a module with case expressions. -- -desugarCasesModule :: (MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module] -desugarCasesModule ms = forM ms $ \(Module ss coms name ds exps) -> +desugarCasesModule + :: (MonadSupply m, MonadError MultipleErrors m) + => Module + -> m Module +desugarCasesModule (Module ss coms name ds exps) = rethrow (addHint (ErrorInModule name)) $ - Module ss coms name <$> (desugarCases <=< desugarAbs <=< validateCases $ ds) <*> pure exps + Module ss coms name + <$> (desugarCases <=< desugarAbs <=< validateCases $ ds) + <*> pure exps -- | -- Validates that case head and binder lengths match. diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -1,34 +1,32 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - -- | -- This module implements the desugaring pass which replaces do-notation statements with --- appropriate calls to bind from the Prelude.Monad type class. +-- appropriate calls to bind. -- -module Language.PureScript.Sugar.DoNotation ( - desugarDoModule -) where +module Language.PureScript.Sugar.DoNotation (desugarDoModule) where -import Prelude () import Prelude.Compat -import Language.PureScript.Crash -import Language.PureScript.Names +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Supply.Class + + import Language.PureScript.AST +import Language.PureScript.Crash import Language.PureScript.Errors - +import Language.PureScript.Names import qualified Language.PureScript.Constants as C -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Supply.Class - -- | --- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.bind function, --- and all @DoNotationLet@ constructors with let expressions. +-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with +-- applications of the bind function in scope, and all @DoNotationLet@ +-- constructors with let expressions. -- desugarDoModule :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Module -> m Module desugarDoModule (Module ss coms mn ds exts) = Module ss coms mn <$> parU ds desugarDo <*> pure exts +-- | +-- Desugar a single do statement +-- desugarDo :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> rethrowWithPosition pos (desugarDo d) desugarDo d = diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} - module Language.PureScript.Sugar.Names ( desugarImports , desugarImportsWithEnv @@ -13,38 +8,41 @@ , Exports(..) ) where -import Prelude () import Prelude.Compat -import Data.List (find, nub) -import Data.Maybe (fromMaybe, mapMaybe) - -import Control.Arrow (first) +import Control.Arrow (first, second) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer (MonadWriter(..), censor) import Control.Monad.State.Lazy +import Control.Monad.Writer (MonadWriter(..), censor) +import Data.List (nub) +import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S -import Language.PureScript.Crash import Language.PureScript.AST -import Language.PureScript.Names -import Language.PureScript.Types +import Language.PureScript.Crash import Language.PureScript.Errors -import Language.PureScript.Traversals import Language.PureScript.Externs +import Language.PureScript.Linter.Imports +import Language.PureScript.Names import Language.PureScript.Sugar.Names.Env -import Language.PureScript.Sugar.Names.Imports import Language.PureScript.Sugar.Names.Exports -import Language.PureScript.Linter.Imports +import Language.PureScript.Sugar.Names.Imports +import Language.PureScript.Traversals +import Language.PureScript.Types -- | -- Replaces all local names with qualified names within a list of modules. The -- modules should be topologically sorted beforehand. -- -desugarImports :: forall m. (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module] +desugarImports + :: forall m + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => [ExternsFile] + -> [Module] + -> m [Module] desugarImports externs modules = fmap snd (desugarImportsWithEnv externs modules) @@ -56,9 +54,8 @@ -> m (Env, [Module]) desugarImportsWithEnv externs modules = do env <- silence $ foldM externsEnv primEnv externs - modules' <- traverse updateExportRefs modules - (modules'', env') <- first reverse <$> foldM updateEnv ([], env) modules' - (env',) <$> traverse (renameInModule' env') modules'' + (modules', env') <- first reverse <$> foldM updateEnv ([], env) modules + (env',) <$> traverse (renameInModule' env') modules' where silence :: m a -> m a silence = censor (const mempty) @@ -68,59 +65,53 @@ externsEnv env ExternsFile{..} = do let members = Exports{..} ss = internalModuleSourceSpan "" - env' = M.insert efModuleName (ss, nullImports, members) env + env' = M.insert efModuleName (ss, primImports, members) env fromEFImport (ExternsImport mn mt qmn) = (mn, [(Nothing, Just mt, qmn)]) - imps <- foldM (resolveModuleImport env') nullImports (map fromEFImport efImports) - exps <- resolveExports env' efModuleName imps members efExports + imps <- foldM (resolveModuleImport env') primImports (map fromEFImport efImports) + exps <- resolveExports env' ss efModuleName imps members efExports return $ M.insert efModuleName (ss, imps, exps) env where - exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] - exportedTypes = mapMaybe toExportedType efExports + exportedTypes :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName) + exportedTypes = M.fromList $ mapMaybe toExportedType efExports where - toExportedType (TypeRef tyCon dctors) = Just ((tyCon, fromMaybe (mapMaybe forTyCon efDeclarations) dctors), efModuleName) + toExportedType (TypeRef tyCon dctors) = Just (tyCon, (fromMaybe (mapMaybe forTyCon efDeclarations) dctors, efModuleName)) where forTyCon :: ExternsDeclaration -> Maybe (ProperName 'ConstructorName) forTyCon (EDDataConstructor pn _ tNm _ _) | tNm == tyCon = Just pn forTyCon _ = Nothing toExportedType (PositionedDeclarationRef _ _ r) = toExportedType r toExportedType _ = Nothing - exportedTypeOps :: [(Ident, ModuleName)] - exportedTypeOps = mapMaybe toExportedTypeOp efExports - where - toExportedTypeOp (TypeOpRef ident) = Just (ident, efModuleName) - toExportedTypeOp (PositionedDeclarationRef _ _ r) = toExportedTypeOp r - toExportedTypeOp _ = Nothing - exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)] - exportedTypeClasses = mapMaybe toExportedTypeClass efExports - where - toExportedTypeClass (TypeClassRef className) = Just (className, efModuleName) - toExportedTypeClass (PositionedDeclarationRef _ _ r) = toExportedTypeClass r - toExportedTypeClass _ = Nothing - exportedValues :: [(Ident, ModuleName)] - exportedValues = mapMaybe toExportedValue efExports - where - toExportedValue (ValueRef ident) = Just (ident, efModuleName) - toExportedValue (PositionedDeclarationRef _ _ r) = toExportedValue r - toExportedValue _ = Nothing + exportedTypeOps :: M.Map (OpName 'TypeOpName) ModuleName + exportedTypeOps = M.fromList $ (, efModuleName) <$> mapMaybe getTypeOpRef efExports + + exportedTypeClasses :: M.Map (ProperName 'ClassName) ModuleName + exportedTypeClasses = M.fromList $ (, efModuleName) <$> mapMaybe getTypeClassRef efExports + + exportedValues :: M.Map Ident ModuleName + exportedValues = M.fromList $ (, efModuleName) <$> mapMaybe getValueRef efExports + + exportedValueOps :: M.Map (OpName 'ValueOpName) ModuleName + exportedValueOps = M.fromList $ (, efModuleName) <$> mapMaybe getValueOpRef efExports + updateEnv :: ([Module], Env) -> Module -> m ([Module], Env) updateEnv (ms, env) m@(Module ss _ mn _ refs) = case mn `M.lookup` env of Just m' -> throwError . errorMessage $ RedefinedModule mn [envModuleSourceSpan m', ss] Nothing -> do members <- findExportable m - let env' = M.insert mn (ss, nullImports, members) env + let env' = M.insert mn (ss, primImports, members) env (m', imps) <- resolveImports env' m - exps <- maybe (return members) (resolveExports env' mn imps members) refs + exps <- maybe (return members) (resolveExports env' ss mn imps members) refs return (m' : ms, M.insert mn (ss, imps, exps) env) renameInModule' :: Env -> Module -> m Module renameInModule' env m@(Module _ _ mn _ _) = warnAndRethrow (addHint (ErrorInModule mn)) $ do let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env - (m', used) <- flip runStateT M.empty $ renameInModule env imps (elaborateExports exps m) - lintImports m env used + (m', used) <- flip runStateT M.empty $ renameInModule imps (elaborateExports exps m) + lintImports m' env used return m' -- | @@ -131,17 +122,24 @@ elaborateExports :: Exports -> Module -> Module elaborateExports exps (Module ss coms mn decls refs) = Module ss coms mn decls $ - Just $ map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) (my exportedTypes) ++ + Just $ map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) myTypes ++ map TypeOpRef (my exportedTypeOps) ++ map TypeClassRef (my exportedTypeClasses) ++ map ValueRef (my exportedValues) ++ + map ValueOpRef (my exportedValueOps) ++ maybe [] (filter isModuleRef) refs where -- Extracts a list of values from the exports and filters out any values that -- are re-exports from other modules. - my :: (Exports -> [(a, ModuleName)]) -> [a] - my f = fst `map` filter ((== mn) . snd) (f exps) + my :: (Exports -> M.Map a ModuleName) -> [a] + my = map fst <$> filt (== mn) + myTypes :: [(ProperName 'TypeName, [ProperName 'ConstructorName])] + myTypes = second fst <$> filt ((== mn) . snd) exportedTypes + + filt :: (b -> Bool) -> (Exports -> M.Map a b) -> [(a, b)] + filt predicate f = M.toList $ predicate `M.filter` f exps + -- | -- Replaces all local names with qualified names within a module and checks that all existing -- qualified names are valid. @@ -149,11 +147,10 @@ renameInModule :: forall m . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m) - => Env - -> Imports + => Imports -> Module -> m Module -renameInModule env imports (Module ss coms mn decls exps) = +renameInModule imports (Module ss coms mn decls exps) = Module ss coms mn <$> parU decls go <*> pure exps where @@ -177,16 +174,12 @@ (,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty) updateDecl (pos, bound) (ExternDeclaration name ty) = (,) (pos, name : bound) <$> (ExternDeclaration name <$> updateTypesEverywhere pos ty) - updateDecl (pos, bound) (FixityDeclaration fx name alias) = - (,) (pos, bound) <$> (FixityDeclaration fx name <$> traverse updateAlias alias) - where - updateAlias :: Qualified FixityAlias -> m (Qualified FixityAlias) - updateAlias (Qualified mn' (AliasValue ident)) = - fmap AliasValue <$> updateValueName (Qualified mn' ident) pos - updateAlias (Qualified mn' (AliasConstructor ctor)) = - fmap AliasConstructor <$> updateDataConstructorName (Qualified mn' ctor) pos - updateAlias (Qualified mn' (AliasType ty)) = - fmap AliasType <$> updateTypeName (Qualified mn' ty) pos + updateDecl (pos, bound) (TypeFixityDeclaration fixity alias op) = + (,) (pos, bound) <$> (TypeFixityDeclaration fixity <$> updateTypeName alias pos <*> pure op) + updateDecl (pos, bound) (ValueFixityDeclaration fixity (Qualified mn' (Left alias)) op) = + (,) (pos, bound) <$> (ValueFixityDeclaration fixity . fmap Left <$> updateValueName (Qualified mn' alias) pos <*> pure op) + updateDecl (pos, bound) (ValueFixityDeclaration fixity (Qualified mn' (Right alias)) op) = + (,) (pos, bound) <$> (ValueFixityDeclaration fixity . fmap Right <$> updateDataConstructorName (Qualified mn' alias) pos <*> pure op) updateDecl s d = return (s, d) updateValue @@ -207,6 +200,8 @@ (,) (pos, bound) <$> (Var <$> updateValueName name' pos) updateValue (pos, bound) (Var name'@(Qualified (Just _) _)) = (,) (pos, bound) <$> (Var <$> updateValueName name' pos) + updateValue (pos, bound) (Op op) = + (,) (pos, bound) <$> (Op <$> updateValueOpName op pos) updateValue s@(pos, _) (Constructor name) = (,) s <$> (Constructor <$> updateDataConstructorName name pos) updateValue s@(pos, _) (TypedValue check val ty) = @@ -221,12 +216,11 @@ return ((Just pos, bound), v) updateBinder s@(pos, _) (ConstructorBinder name b) = (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b) - updateBinder s@(pos, _) (OpBinder name) = - (,) s <$> (OpBinder <$> updateValueName name pos) - updateBinder s (TypedBinder t b) = do - (s'@ (span', _), b') <- updateBinder s b - t' <- updateTypesEverywhere span' t - return (s', TypedBinder t' b') + updateBinder s@(pos, _) (OpBinder op) = + (,) s <$> (OpBinder <$> updateValueOpName op pos) + updateBinder s@(pos, _) (TypedBinder t b) = do + t' <- updateTypesEverywhere pos t + return (s, TypedBinder t' b) updateBinder s v = return (s, v) @@ -248,103 +242,63 @@ updateType :: Type -> m Type updateType (TypeOp name) = TypeOp <$> updateTypeOpName name pos updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos - updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t + updateType (ConstrainedType cs t) = ConstrainedType <$> traverse updateInConstraint cs <*> pure t updateType t = return t + updateInConstraint :: Constraint -> m Constraint + updateInConstraint (Constraint name ts info) = + Constraint <$> updateClassName name pos <*> pure ts <*> pure info updateConstraints :: Maybe SourceSpan -> [Constraint] -> m [Constraint] - updateConstraints pos = traverse (\(name, ts) -> (,) <$> updateClassName name pos <*> traverse (updateTypesEverywhere pos) ts) + updateConstraints pos = traverse $ \(Constraint name ts info) -> + Constraint + <$> updateClassName name pos + <*> traverse (updateTypesEverywhere pos) ts + <*> pure info updateTypeName :: Qualified (ProperName 'TypeName) -> Maybe SourceSpan -> m (Qualified (ProperName 'TypeName)) - updateTypeName = - update UnknownType - (importedTypes imports) - (resolveType . exportedTypes) - TyName - (("type " ++) . runProperName) + updateTypeName = update (importedTypes imports) TyName updateTypeOpName - :: Qualified Ident + :: Qualified (OpName 'TypeOpName) -> Maybe SourceSpan - -> m (Qualified Ident) - updateTypeOpName = - update - UnknownTypeOp - (importedTypeOps imports) - (resolve . exportedTypeOps) - TyOpName - (("type operator" ++) . runIdent) + -> m (Qualified (OpName 'TypeOpName)) + updateTypeOpName = update (importedTypeOps imports) TyOpName updateDataConstructorName :: Qualified (ProperName 'ConstructorName) -> Maybe SourceSpan -> m (Qualified (ProperName 'ConstructorName)) - updateDataConstructorName = - update - (flip UnknownDataConstructor Nothing) - (importedDataConstructors imports) - (resolveDctor . exportedTypes) - DctorName - (("data constructor " ++) . runProperName) + updateDataConstructorName = update (importedDataConstructors imports) DctorName updateClassName :: Qualified (ProperName 'ClassName) -> Maybe SourceSpan -> m (Qualified (ProperName 'ClassName)) - updateClassName = - update - UnknownTypeClass - (importedTypeClasses imports) - (resolve . exportedTypeClasses) - TyClassName - (("class " ++) . runProperName) + updateClassName = update (importedTypeClasses imports) TyClassName updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident) - updateValueName = - update - UnknownValue - (importedValues imports) - (resolve . exportedValues) - IdentName - (("value " ++) . runIdent) - - -- Used when performing an update to qualify values and classes with their - -- module of original definition. - resolve :: (Eq a) => [(a, ModuleName)] -> a -> Maybe (Qualified a) - resolve as name = mkQualified name <$> name `lookup` as - - -- Used when performing an update to qualify types with their module of - -- original definition. - resolveType - :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] - -> ProperName 'TypeName - -> Maybe (Qualified (ProperName 'TypeName)) - resolveType tys name = mkQualified name . snd <$> find ((== name) . fst . fst) tys + updateValueName = update (importedValues imports) IdentName - -- Used when performing an update to qualify data constructors with their - -- module of original definition. - resolveDctor - :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] - -> ProperName 'ConstructorName - -> Maybe (Qualified (ProperName 'ConstructorName)) - resolveDctor tys name = mkQualified name . snd <$> find (elem name . snd . fst) tys + updateValueOpName + :: Qualified (OpName 'ValueOpName) + -> Maybe SourceSpan + -> m (Qualified (OpName 'ValueOpName)) + updateValueOpName = update (importedValueOps imports) ValOpName -- Update names so unqualified references become qualified, and locally -- qualified references are replaced with their canoncial qualified names -- (e.g. M.Map -> Data.Map.Map). update :: (Ord a, Show a) - => (Qualified a -> SimpleErrorMessage) - -> M.Map (Qualified a) [ImportRecord a] - -> (Exports -> a -> Maybe (Qualified a)) - -> (Qualified a -> Name) - -> (a -> String) + => M.Map (Qualified a) [ImportRecord a] + -> (a -> Name) -> Qualified a -> Maybe SourceSpan -> m (Qualified a) - update unknown imps getE toName render qname@(Qualified mn' name) pos = positioned $ + update imps toName qname@(Qualified mn' name) pos = positioned $ case (M.lookup qname imps, mn') of -- We found the name in our imports, so we return the name for it, @@ -353,61 +307,27 @@ -- re-exports. If there are multiple options for the name to resolve to -- in scope, we throw an error. (Just options, _) -> do - (mnNew, mnOrig) <- checkImportConflicts mn render options - modify $ \result -> M.insert mnNew (maybe [toName qname] (toName qname :) (mnNew `M.lookup` result)) result + (mnNew, mnOrig) <- checkImportConflicts mn toName options + modify $ \result -> + M.insert + mnNew + (maybe [fmap toName qname] (fmap toName qname :) (mnNew `M.lookup` result)) + result return $ Qualified (Just mnOrig) name -- If the name wasn't found in our imports but was qualified then we need -- to check whether it's a failed import from a "pseudo" module (created -- by qualified importing). If that's not the case, then we just need to -- check it refers to a symbol in another module. - (Nothing, Just mn'') -> do - case M.lookup mn'' env of - Nothing - | mn'' `S.member` importedVirtualModules imports -> throwUnknown - | otherwise -> throwError . errorMessage $ UnknownModule mn'' - Just env' -> maybe throwUnknown return (getE (envModuleExports env') name) + (Nothing, Just mn'') -> + if mn'' `S.member` importedQualModules imports || mn'' `S.member` importedModules imports + then throwUnknown + else throwError . errorMessage . UnknownName . Qualified Nothing $ ModName mn'' -- If neither of the above cases are true then it's an undefined or -- unimported symbol. _ -> throwUnknown where - positioned err = case pos of - Nothing -> err - Just pos' -> rethrowWithPosition pos' err - throwUnknown = throwError . errorMessage $ unknown qname - --- | --- Replaces `ProperRef` export values with a `TypeRef` or `TypeClassRef` --- depending on what is availble within the module. Warns when a `ProperRef` --- desugars into a `TypeClassRef`. --- -updateExportRefs - :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => Module - -> m Module -updateExportRefs (Module ss coms mn decls exps) = - Module ss coms mn decls <$> traverse (traverse updateRef) exps - where - - updateRef :: DeclarationRef -> m DeclarationRef - updateRef (ProperRef name) - | ProperName name `elem` classNames = do - tell . errorMessage . DeprecatedClassExport $ ProperName name - return . TypeClassRef $ ProperName name - -- Fall through case here - assume it's a type if it's not a class. - -- If it's a reference to something that doesn't actually exist it will - -- be picked up elsewhere - | otherwise = return $ TypeRef (ProperName name) (Just []) - updateRef (PositionedDeclarationRef pos com ref) = - warnWithPosition pos $ PositionedDeclarationRef pos com <$> updateRef ref - updateRef other = return other - - classNames :: [ProperName 'ClassName] - classNames = mapMaybe go decls - where - go (PositionedDeclaration _ _ d) = go d - go (TypeClassDeclaration name _ _ _) = Just name - go _ = Nothing + positioned err = maybe err (`rethrowWithPosition` err) pos + throwUnknown = throwError . errorMessage . UnknownName . fmap toName $ qname diff --git a/src/Language/PureScript/Sugar/Names/Common.hs b/src/Language/PureScript/Sugar/Names/Common.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Sugar/Names/Common.hs @@ -0,0 +1,68 @@ +module Language.PureScript.Sugar.Names.Common (warnDuplicateRefs) where + +import Prelude.Compat + +import Control.Monad.Writer (MonadWriter(..)) + +import Data.Foldable (for_) +import Data.Function (on) +import Data.List (nub, nubBy, (\\)) +import Data.Maybe (mapMaybe) + +import Language.PureScript.AST +import Language.PureScript.Errors +import Language.PureScript.Names + +-- | +-- Warns about duplicate values in a list of declaration refs. +-- +warnDuplicateRefs + :: MonadWriter MultipleErrors m + => SourceSpan + -> (Name -> SimpleErrorMessage) + -> [DeclarationRef] + -> m () +warnDuplicateRefs pos toError refs = do + let withoutCtors = deleteCtors `map` refs + dupeRefs = mapMaybe (refToName pos) $ withoutCtors \\ nubBy ((==) `on` withoutPosInfo) withoutCtors + dupeCtors = concat $ mapMaybe (extractCtors pos) refs + + for_ (dupeRefs ++ dupeCtors) $ \(pos', name) -> + warnWithPosition pos' . tell . errorMessage $ toError name + + where + + -- Returns a DeclarationRef unwrapped from any PositionedDeclarationRef + -- constructor(s) it may be wrapped within. Used so position info is ignored + -- when making the comparison for duplicates. + withoutPosInfo :: DeclarationRef -> DeclarationRef + withoutPosInfo (PositionedDeclarationRef _ _ ref) = withoutPosInfo ref + withoutPosInfo other = other + + -- Deletes the constructor information from TypeRefs so that only the + -- referenced type is used in the duplicate check - constructors are handled + -- separately + deleteCtors :: DeclarationRef -> DeclarationRef + deleteCtors (PositionedDeclarationRef ss com ref) = + PositionedDeclarationRef ss com (deleteCtors ref) + deleteCtors (TypeRef pn _) = TypeRef pn Nothing + deleteCtors other = other + + -- Extracts the names of duplicate constructor references from TypeRefs. + extractCtors :: SourceSpan -> DeclarationRef -> Maybe [(SourceSpan, Name)] + extractCtors _ (PositionedDeclarationRef pos' _ ref) = extractCtors pos' ref + extractCtors pos' (TypeRef _ (Just dctors)) = + let dupes = dctors \\ nub dctors + in if null dupes then Nothing else Just $ ((pos',) . DctorName) <$> dupes + extractCtors _ _ = Nothing + + -- Converts a DeclarationRef into a name for an error message. + refToName :: SourceSpan -> DeclarationRef -> Maybe (SourceSpan, Name) + refToName pos' (TypeRef name _) = Just (pos', TyName name) + refToName pos' (TypeOpRef op) = Just (pos', TyOpName op) + refToName pos' (ValueRef name) = Just (pos', IdentName name) + refToName pos' (ValueOpRef op) = Just (pos', ValOpName op) + refToName pos' (TypeClassRef name) = Just (pos', TyClassName name) + refToName pos' (ModuleRef name) = Just (pos', ModName name) + refToName _ (PositionedDeclarationRef pos' _ ref) = refToName pos' ref + refToName _ _ = Nothing diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -1,11 +1,8 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - module Language.PureScript.Sugar.Names.Env ( ImportRecord(..) , ImportProvenance(..) , Imports(..) - , nullImports + , primImports , Exports(..) , nullExports , Env @@ -13,29 +10,33 @@ , envModuleSourceSpan , envModuleImports , envModuleExports + , ExportMode(..) , exportType , exportTypeOp , exportTypeClass , exportValue + , exportValueOp , getExports , checkImportConflicts ) where -import Data.Function (on) -import Data.List (groupBy, sortBy, nub, delete) -import Data.Maybe (fromJust) -import qualified Data.Map as M -import qualified Data.Set as S +import Prelude.Compat import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class (MonadWriter(..)) +import Data.Function (on) +import Data.Foldable (find) +import Data.List (groupBy, sortBy, delete) +import Data.Maybe (fromJust, mapMaybe) +import qualified Data.Map as M +import qualified Data.Set as S + import Language.PureScript.AST -import Language.PureScript.Crash -import Language.PureScript.Names import Language.PureScript.Environment import Language.PureScript.Errors +import Language.PureScript.Names -- | -- The details for an import: the name of the thing that is being imported @@ -59,8 +60,11 @@ = FromImplicit | FromExplicit | Local + | Prim deriving (Eq, Ord, Show, Read) +type ImportMap a = M.Map (Qualified a) [ImportRecord a] + -- | -- The imported declarations for a module, including the module's own members. -- @@ -69,72 +73,95 @@ -- | -- Local names for types within a module mapped to to their qualified names -- - importedTypes :: M.Map (Qualified (ProperName 'TypeName)) [ImportRecord (ProperName 'TypeName)] + importedTypes :: ImportMap (ProperName 'TypeName) -- | -- Local names for type operators within a module mapped to to their qualified names -- - , importedTypeOps :: M.Map (Qualified Ident) [ImportRecord Ident] + , importedTypeOps :: ImportMap (OpName 'TypeOpName) -- | -- Local names for data constructors within a module mapped to to their qualified names -- - , importedDataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) [ImportRecord (ProperName 'ConstructorName)] + , importedDataConstructors :: ImportMap (ProperName 'ConstructorName) -- | -- Local names for classes within a module mapped to to their qualified names -- - , importedTypeClasses :: M.Map (Qualified (ProperName 'ClassName)) [ImportRecord (ProperName 'ClassName)] + , importedTypeClasses :: ImportMap (ProperName 'ClassName) -- | -- Local names for values within a module mapped to to their qualified names -- - , importedValues :: M.Map (Qualified Ident) [ImportRecord Ident] + , importedValues :: ImportMap Ident -- | - -- The modules that have been imported into the current scope. + -- Local names for value operators within a module mapped to to their qualified names -- + , importedValueOps :: ImportMap (OpName 'ValueOpName) + -- | + -- The name of modules that have been imported into the current scope that + -- can be re-exported. If a module is imported with `as` qualification, the + -- `as` name appears here, otherwise the original name. + -- , importedModules :: S.Set ModuleName -- | - -- The names of "virtual" modules that come into existence when "import as" - -- is used. + -- The "as" names of modules that have been imported qualified. -- - , importedVirtualModules :: S.Set ModuleName + , importedQualModules :: S.Set ModuleName } deriving (Show, Read) +nullImports :: Imports +nullImports = Imports M.empty M.empty M.empty M.empty M.empty M.empty S.empty S.empty + -- | --- An empty 'Imports' value. +-- An 'Imports' value with imports for the `Prim` module. -- -nullImports :: Imports -nullImports = Imports M.empty M.empty M.empty M.empty M.empty S.empty S.empty +primImports :: Imports +primImports = + nullImports + { importedTypes = M.fromList $ mkEntries `concatMap` M.keys primTypes + , importedTypeClasses = M.fromList $ mkEntries `concatMap` M.keys primClasses + } + where + mkEntries :: Qualified a -> [(Qualified a, [ImportRecord a])] + mkEntries fullName@(Qualified _ name) = + [ (fullName, [ImportRecord fullName primModuleName Prim]) + , (Qualified Nothing name, [ImportRecord fullName primModuleName Prim]) + ] +primModuleName :: ModuleName +primModuleName = ModuleName [ProperName "Prim"] + -- | -- The exported declarations from a module. -- data Exports = Exports { -- | - -- The types exported from each module along with the module they originally - -- came from. + -- The exported types along with the module they originally came from. -- - exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] + exportedTypes :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName) -- | - -- The type operators exported from each module along with the module they - -- originally came from. + -- The exported type operators along with the module they originally came + -- from. -- - , exportedTypeOps :: [(Ident, ModuleName)] + , exportedTypeOps :: M.Map (OpName 'TypeOpName) ModuleName -- | - -- The classes exported from each module along with the module they originally - -- came from. + -- The exported classes along with the module they originally came from. -- - , exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)] + , exportedTypeClasses :: M.Map (ProperName 'ClassName) ModuleName -- | - -- The values exported from each module along with the module they originally - -- came from. + -- The exported values along with the module they originally came from. -- - , exportedValues :: [(Ident, ModuleName)] + , exportedValues :: M.Map Ident ModuleName + -- | + -- The exported value operators along with the module they originally came + -- from. + -- + , exportedValueOps :: M.Map (OpName 'ValueOpName) ModuleName } deriving (Show, Read) -- | -- An empty 'Exports' value. -- nullExports :: Exports -nullExports = Exports [] [] [] [] +nullExports = Exports M.empty M.empty M.empty M.empty M.empty -- | -- The imports and exports for a collection of modules. The 'SourceSpan' is used @@ -165,84 +192,184 @@ -- The exported types from the @Prim@ module -- primExports :: Exports -primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] (mkClassEntry `map` M.keys primClasses) [] +primExports = + nullExports + { exportedTypes = M.fromList $ mkTypeEntry `map` M.keys primTypes + , exportedTypeClasses = M.fromList $ mkClassEntry `map` M.keys primClasses + } where - mkTypeEntry (Qualified mn name) = ((name, []), fromJust mn) + mkTypeEntry (Qualified mn name) = (name, ([], fromJust mn)) mkClassEntry (Qualified mn name) = (name, fromJust mn) -- | Environment which only contains the Prim module. primEnv :: Env primEnv = M.singleton - (ModuleName [ProperName "Prim"]) + primModuleName (internalModuleSourceSpan "", nullImports, primExports) -- | +-- When updating the `Exports` the behaviour is slightly different depending +-- on whether we are exporting values defined within the module or elaborating +-- re-exported values. This type is used to indicate which behaviour should be +-- used. +-- +data ExportMode = Internal | ReExport + deriving (Eq, Show) + +-- | -- Safely adds a type and its data constructors to some exports, returning an -- error if a conflict occurs. -- -exportType :: (MonadError MultipleErrors m) => Exports -> ProperName 'TypeName -> [ProperName 'ConstructorName] -> ModuleName -> m Exports -exportType exps name dctors mn = do - let exTypes' = exportedTypes exps - let exTypes = filter ((/= mn) . snd) exTypes' - let exDctors = (snd . fst) `concatMap` exTypes +exportType + :: MonadError MultipleErrors m + => ExportMode + -> Exports + -> ProperName 'TypeName + -> [ProperName 'ConstructorName] + -> ModuleName + -> m Exports +exportType exportMode exps name dctors mn = do + let exTypes = exportedTypes exps let exClasses = exportedTypeClasses exps - when (any ((== name) . fst . fst) exTypes) $ throwConflictError ConflictingTypeDecls name - when (any ((== coerceProperName name) . fst) exClasses) $ throwConflictError TypeConflictsWithClass name - forM_ dctors $ \dctor -> do - when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor - when (any ((== coerceProperName dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor - return $ exps { exportedTypes = nub $ ((name, dctors), mn) : exTypes' } + case exportMode of + Internal -> do + when (name `M.member` exTypes) $ + throwDeclConflict (TyName name) (TyName name) + when (coerceProperName name `M.member` exClasses) $ + throwDeclConflict (TyName name) (TyClassName (coerceProperName name)) + forM_ dctors $ \dctor -> do + when ((elem dctor . fst) `any` exTypes) $ + throwDeclConflict (DctorName dctor) (DctorName dctor) + when (coerceProperName dctor `M.member` exClasses) $ + throwDeclConflict (DctorName dctor) (TyClassName (coerceProperName dctor)) + ReExport -> do + forM_ (name `M.lookup` exTypes) $ \(_, mn') -> + when (mn /= mn') $ + throwExportConflict mn mn' (TyName name) + forM_ dctors $ \dctor -> + forM_ ((elem dctor . fst) `find` exTypes) $ \(_, mn') -> + when (mn /= mn') $ + throwExportConflict mn mn' (DctorName dctor) + return $ exps { exportedTypes = M.alter updateOrInsert name exTypes } + where + updateOrInsert Nothing = Just (dctors, mn) + updateOrInsert (Just (dctors', _)) = Just (dctors ++ dctors', mn) -- | -- Safely adds a type operator to some exports, returning an error if a -- conflict occurs. -- -exportTypeOp :: (MonadError MultipleErrors m) => Exports -> Ident -> ModuleName -> m Exports -exportTypeOp exps name mn = do - typeOps <- addExport DuplicateTypeOpExport name mn (exportedTypeOps exps) +exportTypeOp + :: MonadError MultipleErrors m + => Exports + -> OpName 'TypeOpName + -> ModuleName + -> m Exports +exportTypeOp exps op mn = do + typeOps <- addExport TyOpName op mn (exportedTypeOps exps) return $ exps { exportedTypeOps = typeOps } -- | -- Safely adds a class to some exports, returning an error if a conflict occurs. -- -exportTypeClass :: (MonadError MultipleErrors m) => Exports -> ProperName 'ClassName -> ModuleName -> m Exports -exportTypeClass exps name mn = do +exportTypeClass + :: MonadError MultipleErrors m + => ExportMode + -> Exports + -> ProperName 'ClassName + -> ModuleName + -> m Exports +exportTypeClass exportMode exps name mn = do let exTypes = exportedTypes exps - let exDctors = (snd . fst) `concatMap` exTypes - when (any ((== coerceProperName name) . fst . fst) exTypes) $ throwConflictError ClassConflictsWithType name - when (coerceProperName name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name - classes <- addExport DuplicateClassExport name mn (exportedTypeClasses exps) + when (exportMode == Internal) $ do + when (coerceProperName name `M.member` exTypes) $ + throwDeclConflict (TyClassName name) (TyName (coerceProperName name)) + when ((elem (coerceProperName name) . fst) `any` exTypes) $ + throwDeclConflict (TyClassName name) (DctorName (coerceProperName name)) + classes <- addExport TyClassName name mn (exportedTypeClasses exps) return $ exps { exportedTypeClasses = classes } -- | -- Safely adds a value to some exports, returning an error if a conflict occurs. -- -exportValue :: (MonadError MultipleErrors m) => Exports -> Ident -> ModuleName -> m Exports +exportValue + :: MonadError MultipleErrors m + => Exports + -> Ident + -> ModuleName + -> m Exports exportValue exps name mn = do - values <- addExport DuplicateValueExport name mn (exportedValues exps) + values <- addExport IdentName name mn (exportedValues exps) return $ exps { exportedValues = values } -- | --- Adds an entry to a list of exports unless it is already present, in which case an error is --- returned. +-- Safely adds a value operator to some exports, returning an error if a +-- conflict occurs. -- -addExport :: (MonadError MultipleErrors m, Eq a) => (a -> SimpleErrorMessage) -> a -> ModuleName -> [(a, ModuleName)] -> m [(a, ModuleName)] -addExport what name mn exports = - if any (\(name', mn') -> name == name' && mn /= mn') exports - then throwConflictError what name - else return $ nub $ (name, mn) : exports +exportValueOp + :: MonadError MultipleErrors m + => Exports + -> OpName 'ValueOpName + -> ModuleName + -> m Exports +exportValueOp exps op mn = do + valueOps <- addExport ValOpName op mn (exportedValueOps exps) + return $ exps { exportedValueOps = valueOps } -- | +-- Adds an entry to a list of exports unless it is already present, in which +-- case an error is returned. +-- +addExport + :: (MonadError MultipleErrors m, Ord a) + => (a -> Name) + -> a + -> ModuleName + -> M.Map a ModuleName + -> m (M.Map a ModuleName) +addExport toName name mn exports = + case M.lookup name exports of + Just mn' + | mn == mn' -> return exports + | otherwise -> throwExportConflict mn mn' (toName name) + Nothing -> + return $ M.insert name mn exports + +-- | -- Raises an error for when there is more than one definition for something. -- -throwConflictError :: (MonadError MultipleErrors m) => (a -> SimpleErrorMessage) -> a -> m b -throwConflictError conflict = throwError . errorMessage . conflict +throwDeclConflict + :: MonadError MultipleErrors m + => Name + -> Name + -> m a +throwDeclConflict new existing = + throwError . errorMessage $ DeclConflict new existing --- Gets the exports for a module, or an error message if the module doesn't exist -getExports :: (MonadError MultipleErrors m) => Env -> ModuleName -> m Exports -getExports env mn = maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ M.lookup mn env +-- | +-- Raises an error for when there are conflicting names in the exports. +-- +throwExportConflict + :: MonadError MultipleErrors m + => ModuleName + -> ModuleName + -> Name + -> m a +throwExportConflict new existing name = + throwError . errorMessage $ + ExportConflict (Qualified (Just new) name) (Qualified (Just existing) name) -- | +-- Gets the exports for a module, or raise an error if the module doesn't exist. +-- +getExports :: MonadError MultipleErrors m => Env -> ModuleName -> m Exports +getExports env mn = + maybe + (throwError . errorMessage . UnknownName . Qualified Nothing $ ModName mn) + (return . envModuleExports) + $ M.lookup mn env + +-- | -- When reading a value from the imports, check that there are no conflicts in -- scope. -- @@ -250,16 +377,16 @@ :: forall m a . (Show a, MonadError MultipleErrors m, MonadWriter MultipleErrors m, Ord a) => ModuleName - -> (a -> String) + -> (a -> Name) -> [ImportRecord a] -> m (ModuleName, ModuleName) -checkImportConflicts currentModule render xs = +checkImportConflicts currentModule toName xs = let byOrig = sortBy (compare `on` importSourceModule) xs groups = groupBy ((==) `on` importSourceModule) byOrig nonImplicit = filter ((/= FromImplicit) . importProvenance) xs - name = render' (importName . head $ xs) - conflictModules = map (getQual . importName . head) groups + name = toName . disqualify . importName $ head xs + conflictModules = mapMaybe (getQual . importName . head) groups in if length groups > 1 then case nonImplicit of @@ -271,9 +398,3 @@ else let ImportRecord (Qualified (Just mnNew) _) mnOrig _ = head byOrig in return (mnNew, mnOrig) - where - getQual :: Qualified a -> ModuleName - getQual (Qualified (Just mn) _) = mn - getQual _ = internalError "unexpected unqualified name in checkImportConflicts" - render' :: Qualified a -> String - render' (Qualified _ a) = render a diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -1,32 +1,26 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE LambdaCase #-} - module Language.PureScript.Sugar.Names.Exports ( findExportable , resolveExports ) where -import Prelude () import Prelude.Compat -import Data.List (find, intersect) -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Foldable (traverse_) - import Control.Monad import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Error.Class (MonadError(..)) +import Data.Function (on) +import Data.Foldable (traverse_) +import Data.List (intersect, groupBy, sortBy) +import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as M -import Language.PureScript.Crash import Language.PureScript.AST -import Language.PureScript.Names +import Language.PureScript.Crash import Language.PureScript.Errors -import Language.PureScript.Sugar.Names.Env +import Language.PureScript.Names +import Language.PureScript.Sugar.Names.Env +import Language.PureScript.Sugar.Names.Common (warnDuplicateRefs) -- | -- Finds all exportable members of a module, disregarding any explicit exports. @@ -37,82 +31,87 @@ where updateExports :: Exports -> Declaration -> m Exports updateExports exps (TypeClassDeclaration tcn _ _ ds') = do - exps' <- exportTypeClass exps tcn mn + exps' <- exportTypeClass Internal exps tcn mn foldM go exps' ds' where go exps'' (TypeDeclaration name _) = exportValue exps'' name mn go exps'' (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go exps'' d go _ _ = internalError "Invalid declaration in TypeClassDeclaration" - updateExports exps (DataDeclaration _ tn _ dcs) = exportType exps tn (map fst dcs) mn - updateExports exps (TypeSynonymDeclaration tn _ _) = exportType exps tn [] mn - updateExports exps (ExternDataDeclaration tn _) = exportType exps tn [] mn - updateExports exps (ValueDeclaration name _ _ _) = exportValue exps name mn - updateExports exps (FixityDeclaration _ name (Just (Qualified _ (AliasType _)))) = exportTypeOp exps (Op name) mn - updateExports exps (FixityDeclaration _ name (Just _)) = exportValue exps (Op name) mn - updateExports exps (ExternDeclaration name _) = exportValue exps name mn - updateExports exps (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ updateExports exps d + updateExports exps (DataDeclaration _ tn _ dcs) = + exportType Internal exps tn (map fst dcs) mn + updateExports exps (TypeSynonymDeclaration tn _ _) = + exportType Internal exps tn [] mn + updateExports exps (ExternDataDeclaration tn _) = + exportType Internal exps tn [] mn + updateExports exps (ValueDeclaration name _ _ _) = + exportValue exps name mn + updateExports exps (ValueFixityDeclaration _ _ op) = + exportValueOp exps op mn + updateExports exps (TypeFixityDeclaration _ _ op) = + exportTypeOp exps op mn + updateExports exps (ExternDeclaration name _) = + exportValue exps name mn + updateExports exps (PositionedDeclaration pos _ d) = + rethrowWithPosition pos $ updateExports exps d updateExports exps _ = return exps -- | -- Resolves the exports for a module, filtering out members that have not been -- exported and elaborating re-exports of other modules. -- -resolveExports :: forall m. (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> ModuleName -> Imports -> Exports -> [DeclarationRef] -> m Exports -resolveExports env mn imps exps refs = - rethrow (addHint (ErrorInModule mn)) $ do +resolveExports + :: forall m + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => Env + -> SourceSpan + -> ModuleName + -> Imports + -> Exports + -> [DeclarationRef] + -> m Exports +resolveExports env ss mn imps exps refs = + warnAndRethrow (addHint (ErrorInModule mn)) $ do filtered <- filterModule mn exps refs - let (dupeRefs, dupeDctors) = findDuplicateRefs refs - warnDupeRefs dupeRefs - warnDupeDctors dupeDctors - foldM elaborateModuleExports filtered refs - + exps' <- foldM elaborateModuleExports filtered refs + warnDuplicateRefs ss DuplicateExportRef refs + return exps' + where - warnDupeRefs :: [DeclarationRef] -> m () - warnDupeRefs = traverse_ $ \case - TypeRef name _ -> warnDupe $ "type " ++ runProperName name - TypeOpRef name -> warnDupe $ "type operator " ++ runIdent name - ValueRef name -> warnDupe $ "value " ++ runIdent name - TypeClassRef name -> warnDupe $ "class " ++ runProperName name - ModuleRef name -> warnDupe $ "module " ++ runModuleName name - _ -> return () - - warnDupeDctors :: [ProperName 'ConstructorName] -> m () - warnDupeDctors = traverse_ (warnDupe . ("data constructor " ++) . runProperName) - - warnDupe :: String -> m () - warnDupe ref = tell . errorMessage $ DuplicateExportRef ref - -- Takes the current module's imports, the accumulated list of exports, and a -- `DeclarationRef` for an explicit export. When the ref refers to another -- module, export anything from the imports that matches for that module. elaborateModuleExports :: Exports -> DeclarationRef -> m Exports elaborateModuleExports result (PositionedDeclarationRef pos _ r) = - rethrowWithPosition pos $ elaborateModuleExports result r + warnAndRethrowWithPosition pos $ elaborateModuleExports result r elaborateModuleExports result (ModuleRef name) | name == mn = do - let types' = exportedTypes result ++ exportedTypes exps - let typeOps' = exportedTypeOps result ++ exportedTypeOps exps - let classes' = exportedTypeClasses result ++ exportedTypeClasses exps - let values' = exportedValues result ++ exportedValues exps + let types' = exportedTypes result `M.union` exportedTypes exps + let typeOps' = exportedTypeOps result `M.union` exportedTypeOps exps + let classes' = exportedTypeClasses result `M.union` exportedTypeClasses exps + let values' = exportedValues result `M.union` exportedValues exps + let valueOps' = exportedValueOps result `M.union` exportedValueOps exps return result { exportedTypes = types' , exportedTypeOps = typeOps' , exportedTypeClasses = classes' , exportedValues = values' + , exportedValueOps = valueOps' } elaborateModuleExports result (ModuleRef name) = do let isPseudo = isPseudoModule name - when (not isPseudo && not (isImportedModule name)) $ - throwError . errorMessage . UnknownExportModule $ name - reTypes <- extract isPseudo name (("type " ++) . runProperName) (importedTypes imps) - reTypeOps <- extract isPseudo name (("type operator " ++) . runIdent) (importedTypeOps imps) - reDctors <- extract isPseudo name (("data constructor " ++) . runProperName) (importedDataConstructors imps) - reClasses <- extract isPseudo name (("class " ++) . runProperName) (importedTypeClasses imps) - reValues <- extract isPseudo name (("value " ++) . runIdent) (importedValues imps) - result' <- foldM (\exps' ((tctor, dctors), mn') -> exportType exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors) - result'' <- foldM (uncurry . exportTypeOp) result' (map resolveTypeOp reTypeOps) - result''' <- foldM (uncurry . exportTypeClass) result'' (map resolveClass reClasses) - foldM (uncurry . exportValue) result''' (map resolveValue reValues) + when (not isPseudo && not (isImportedModule name)) + . throwError . errorMessage . UnknownExport $ ModName name + reTypes <- extract isPseudo name TyName (importedTypes imps) + reTypeOps <- extract isPseudo name TyOpName (importedTypeOps imps) + reDctors <- extract isPseudo name DctorName (importedDataConstructors imps) + reClasses <- extract isPseudo name TyClassName (importedTypeClasses imps) + reValues <- extract isPseudo name IdentName (importedValues imps) + reValueOps <- extract isPseudo name ValOpName (importedValueOps imps) + foldM (\exps' ((tctor, dctors), mn') -> exportType ReExport exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors) + >>= flip (foldM (uncurry . exportTypeOp)) (map resolveTypeOp reTypeOps) + >>= flip (foldM (uncurry . exportTypeClass ReExport)) (map resolveClass reClasses) + >>= flip (foldM (uncurry . exportValue)) (map resolveValue reValues) + >>= flip (foldM (uncurry . exportValueOp)) (map resolveValueOp reValueOps) elaborateModuleExports result _ = return result -- Extracts a list of values for a module based on a lookup table. If the @@ -121,14 +120,14 @@ :: (Show a, Ord a) => Bool -> ModuleName - -> (a -> String) + -> (a -> Name) -> M.Map (Qualified a) [ImportRecord a] -> m [Qualified a] - extract useQual name render = fmap (map (importName . head . snd)) . go . M.toList + extract useQual name toName = fmap (map (importName . head . snd)) . go . M.toList where go = filterM $ \(name', options) -> do let isMatch = if useQual then isQualifiedWith name name' else any (checkUnqual name') options - when (isMatch && length options > 1) $ void $ checkImportConflicts mn render options + when (isMatch && length options > 1) $ void $ checkImportConflicts mn toName options return isMatch checkUnqual name' ir = isUnqualified name' && isQualifiedWith name (importName ir) @@ -147,6 +146,7 @@ || any (isQualifiedWith mn') (f (importedDataConstructors imps)) || any (isQualifiedWith mn') (f (importedTypeClasses imps)) || any (isQualifiedWith mn') (f (importedValues imps)) + || any (isQualifiedWith mn') (f (importedValueOps imps)) -- Check whether a module name refers to a module that has been imported -- without qualification into an import scope. @@ -164,35 +164,54 @@ go :: Qualified (ProperName 'TypeName) -> ((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName) - go (Qualified (Just mn'') name) = fromMaybe (internalError "Missing value in resolveTypeExports") $ do - exps' <- envModuleExports <$> mn'' `M.lookup` env - ((_, dctors'), mnOrig) <- find (\((name', _), _) -> name == name') (exportedTypes exps') - let relevantDctors = mapMaybe (\(Qualified mn''' dctor) -> if mn''' == Just mn'' then Just dctor else Nothing) dctors - return ((name, relevantDctors `intersect` dctors'), mnOrig) + go (Qualified (Just mn'') name) = + fromMaybe (internalError "Missing value in resolveTypeExports") $ do + exps' <- envModuleExports <$> mn'' `M.lookup` env + (dctors', mnOrig) <- name `M.lookup` exportedTypes exps' + let relevantDctors = mapMaybe (disqualifyFor (Just mn'')) dctors + return ((name, relevantDctors `intersect` dctors'), mnOrig) go (Qualified Nothing _) = internalError "Unqualified value in resolveTypeExports" -- Looks up an imported type operator and re-qualifies it with the original -- module it came from. - resolveTypeOp :: Qualified Ident -> (Ident, ModuleName) - resolveTypeOp ident = splitQual $ fromMaybe (internalError "Missing value in resolveValue") $ - resolve exportedTypeOps ident + resolveTypeOp :: Qualified (OpName 'TypeOpName) -> (OpName 'TypeOpName, ModuleName) + resolveTypeOp op + = splitQual + . fromMaybe (internalError "Missing value in resolveValue") + $ resolve exportedTypeOps op -- Looks up an imported class and re-qualifies it with the original module it -- came from. resolveClass :: Qualified (ProperName 'ClassName) -> (ProperName 'ClassName, ModuleName) - resolveClass className = splitQual $ fromMaybe (internalError "Missing value in resolveClass") $ - resolve exportedTypeClasses className + resolveClass className + = splitQual + . fromMaybe (internalError "Missing value in resolveClass") + $ resolve exportedTypeClasses className -- Looks up an imported value and re-qualifies it with the original module it -- came from. resolveValue :: Qualified Ident -> (Ident, ModuleName) - resolveValue ident = splitQual $ fromMaybe (internalError "Missing value in resolveValue") $ - resolve exportedValues ident + resolveValue ident + = splitQual + . fromMaybe (internalError "Missing value in resolveValue") + $ resolve exportedValues ident - resolve :: (Eq a) => (Exports -> [(a, ModuleName)]) -> Qualified a -> Maybe (Qualified a) + -- Looks up an imported operator and re-qualifies it with the original + -- module it came from. + resolveValueOp :: Qualified (OpName 'ValueOpName) -> (OpName 'ValueOpName, ModuleName) + resolveValueOp op + = splitQual + . fromMaybe (internalError "Missing value in resolveValueOp") + $ resolve exportedValueOps op + + resolve + :: Ord a + => (Exports -> M.Map a ModuleName) + -> Qualified a + -> Maybe (Qualified a) resolve f (Qualified (Just mn'') a) = do exps' <- envModuleExports <$> mn'' `M.lookup` env - mn''' <- snd <$> find ((== a) . fst) (f exps') + mn''' <- a `M.lookup` f exps' return $ Qualified (Just mn''') a resolve _ _ = internalError "Unqualified value in resolve" @@ -208,97 +227,80 @@ -- filterModule :: forall m - . (MonadError MultipleErrors m) + . MonadError MultipleErrors m => ModuleName -> Exports -> [DeclarationRef] -> m Exports filterModule mn exps refs = do - types <- foldM (filterTypes $ exportedTypes exps) [] refs - typeOps <- foldM (filterTypeOps $ exportedTypeOps exps) [] refs - values <- foldM (filterValues $ exportedValues exps) [] refs - classes <- foldM (filterClasses $ exportedTypeClasses exps) [] refs - return $ exps + types <- foldM filterTypes M.empty (combineTypeRefs refs) + typeOps <- foldM (filterExport TyOpName getTypeOpRef exportedTypeOps) M.empty refs + classes <- foldM (filterExport TyClassName getTypeClassRef exportedTypeClasses) M.empty refs + values <- foldM (filterExport IdentName getValueRef exportedValues) M.empty refs + valueOps <- foldM (filterExport ValOpName getValueOpRef exportedValueOps) M.empty refs + return Exports { exportedTypes = types , exportedTypeOps = typeOps , exportedTypeClasses = classes , exportedValues = values + , exportedValueOps = valueOps } where - -- Takes a list of all the exportable types with their data constructors, the - -- accumulated list of filtered exports, and a `DeclarationRef` for an - -- explicit export. When the ref refers to a type in the list of exportable - -- values, the type and specified data constructors are included in the - -- result. + -- Takes the list of exported refs, filters out any non-TypeRefs, then + -- combines any duplicate type exports to ensure that all constructors + -- listed for the type are covered. Without this, only the data constructor + -- listing for the last ref would be used. + combineTypeRefs :: [DeclarationRef] -> [DeclarationRef] + combineTypeRefs + = fmap (uncurry TypeRef) + . map (foldr1 $ \(tc, dcs1) (_, dcs2) -> (tc, liftM2 (++) dcs1 dcs2)) + . groupBy ((==) `on` fst) + . sortBy (compare `on` fst) + . mapMaybe getTypeRef + filterTypes - :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] - -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] + :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName) -> DeclarationRef - -> m [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] - filterTypes exps' result (PositionedDeclarationRef pos _ r) = - rethrowWithPosition pos $ filterTypes exps' result r - filterTypes exps' result (TypeRef name expDcons) = - case (\((name', _), mn') -> name == name' && mn == mn') `find` exps' of - Nothing -> throwError . errorMessage . UnknownExportType $ name - Just ((_, dcons), _) -> do + -> m (M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName)) + filterTypes result (PositionedDeclarationRef pos _ r) = + rethrowWithPosition pos $ filterTypes result r + filterTypes result (TypeRef name expDcons) = + case name `M.lookup` exportedTypes exps of + Nothing -> throwError . errorMessage . UnknownExport $ TyName name + Just (dcons, _) -> do let expDcons' = fromMaybe dcons expDcons traverse_ (checkDcon name dcons) expDcons' - return $ ((name, expDcons'), mn) : result - filterTypes _ result _ = return result - - -- Ensures a data constructor is exportable for a given type. Takes a type - -- name, a list of exportable data constructors for the type, and the name of - -- the data constructor to check. - checkDcon - :: ProperName 'TypeName - -> [ProperName 'ConstructorName] - -> ProperName 'ConstructorName - -> m () - checkDcon tcon exps' name = - unless (name `elem` exps') $ - throwError . errorMessage $ UnknownExportDataConstructor tcon name - - -- Takes a list of all the exportable type operators, the accumulated list of - -- filtered exports, and a `DeclarationRef` for an explicit export. When the - -- ref refers to a value in the list of exportable values, the value is - -- included in the result. - filterTypeOps :: [(Ident, ModuleName)] -> [(Ident, ModuleName)] -> DeclarationRef -> m [(Ident, ModuleName)] - filterTypeOps exps' result (PositionedDeclarationRef pos _ r) = - rethrowWithPosition pos $ filterTypeOps exps' result r - filterTypeOps exps' result (TypeOpRef name) = - if (name, mn) `elem` exps' - then return $ (name, mn) : result - else throwError . errorMessage . UnknownExportTypeOp $ name - filterTypeOps _ result _ = return result + return $ M.insert name (expDcons', mn) result + where + -- Ensures a data constructor is exportable for a given type. Takes a type + -- name, a list of exportable data constructors for the type, and the name of + -- the data constructor to check. + checkDcon + :: ProperName 'TypeName + -> [ProperName 'ConstructorName] + -> ProperName 'ConstructorName + -> m () + checkDcon tcon dcons dcon = + unless (dcon `elem` dcons) $ + throwError . errorMessage $ UnknownExportDataConstructor tcon dcon + filterTypes result _ = return result - -- Takes a list of all the exportable classes, the accumulated list of - -- filtered exports, and a `DeclarationRef` for an explicit export. When the - -- ref refers to a class in the list of exportable classes, the class is - -- included in the result. - filterClasses - :: [(ProperName 'ClassName, ModuleName)] - -> [(ProperName 'ClassName, ModuleName)] + filterExport + :: Ord a + => (a -> Name) + -> (DeclarationRef -> Maybe a) + -> (Exports -> M.Map a ModuleName) + -> M.Map a ModuleName -> DeclarationRef - -> m [(ProperName 'ClassName, ModuleName)] - filterClasses exps' result (PositionedDeclarationRef pos _ r) = - rethrowWithPosition pos $ filterClasses exps' result r - filterClasses exps' result (TypeClassRef name) = - if (name, mn) `elem` exps' - then return $ (name, mn) : result - else throwError . errorMessage . UnknownExportTypeClass $ name - filterClasses _ result _ = return result - - -- Takes a list of all the exportable values, the accumulated list of filtered - -- exports, and a `DeclarationRef` for an explicit export. When the ref refers - -- to a value in the list of exportable values, the value is included in the - -- result. - filterValues :: [(Ident, ModuleName)] -> [(Ident, ModuleName)] -> DeclarationRef -> m [(Ident, ModuleName)] - filterValues exps' result (PositionedDeclarationRef pos _ r) = - rethrowWithPosition pos $ filterValues exps' result r - filterValues exps' result (ValueRef name) = - if (name, mn) `elem` exps' - then return $ (name, mn) : result - else throwError . errorMessage . UnknownExportValue $ name - filterValues _ result _ = return result + -> m (M.Map a ModuleName) + filterExport toName get fromExps result (PositionedDeclarationRef pos _ r) = + rethrowWithPosition pos $ filterExport toName get fromExps result r + filterExport toName get fromExps result ref + | Just name <- get ref = + case name `M.lookup` fromExps exps of + -- TODO: I'm not sure if we actually need to check mn == mn' here -gb + Just mn' | mn == mn' -> return $ M.insert name mn result + _ -> throwError . errorMessage . UnknownExport $ toName name + filterExport _ _ _ result _ = return result diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -1,166 +1,64 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE LambdaCase #-} - module Language.PureScript.Sugar.Names.Imports - ( resolveImports + ( ImportDef + , resolveImports , resolveModuleImport , findImports ) where -import Prelude () import Prelude.Compat -import Data.Foldable (traverse_, for_) -import Data.Function (on) -import Data.List (find, sortBy, groupBy, (\\)) -import Data.Maybe (fromMaybe, isNothing, fromJust) -import Data.Traversable (for) - -import Control.Arrow (first) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer (MonadWriter(..)) +import Data.Foldable (for_, traverse_) +import Data.Maybe (fromMaybe) import qualified Data.Map as M import qualified Data.Set as S -import Language.PureScript.Crash import Language.PureScript.AST -import Language.PureScript.Names +import Language.PureScript.Crash import Language.PureScript.Errors +import Language.PureScript.Names import Language.PureScript.Sugar.Names.Env +type ImportDef = (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) + -- | -- Finds the imports within a module, mapping the imported module name to an optional set of -- explicitly imported declarations. -- findImports - :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => [Declaration] - -> m (M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) -findImports = foldM (go Nothing) M.empty + :: [Declaration] + -> M.Map ModuleName [ImportDef] +findImports = foldl (go Nothing) M.empty where - go pos result (ImportDeclaration mn typ qual isOldSyntax) = do - when isOldSyntax . tell . errorMessage $ DeprecatedQualifiedSyntax mn (fromJust qual) + go pos result (ImportDeclaration mn typ qual) = let imp = (pos, typ, qual) - return $ M.insert mn (maybe [imp] (imp :) (mn `M.lookup` result)) result - go _ result (PositionedDeclaration pos _ d) = warnAndRethrowWithPosition pos $ go (Just pos) result d - go _ result _ = return result - -type ImportDef = (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) + in M.insert mn (maybe [imp] (imp :) (mn `M.lookup` result)) result + go _ result (PositionedDeclaration pos _ d) = go (Just pos) result d + go _ result _ = result -- | -- Constructs a set of imports for a module. -- resolveImports :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . MonadError MultipleErrors m => Env -> Module -> m (Module, Imports) resolveImports env (Module ss coms currentModule decls exps) = - warnAndRethrow (addHint (ErrorInModule currentModule)) $ do - - decls' <- traverse updateImportRef decls - imports <- findImports decls' - - for_ (M.toList imports) $ \(mn, imps) -> do - - warned <- foldM (checkDuplicateImports mn) [] (selfCartesianSubset imps) - - let unwarned = imps \\ warned - duplicates - = join - . map tail - . filter ((> 1) . length) - . groupBy ((==) `on` defQual) - . sortBy (compare `on` defQual) - $ unwarned - - warned' <- - for duplicates $ \i@(pos, _, _) -> do - warn pos $ DuplicateSelectiveImport mn - return i - - for_ (imps \\ (warned ++ warned')) $ \(pos, typ, _) -> - let (dupeRefs, dupeDctors) = findDuplicateRefs $ case typ of - Explicit refs -> refs - Hiding refs -> refs - _ -> [] - in warnDupeRefs pos dupeRefs >> warnDupeDctors pos dupeDctors - - return () - - let imports' = M.map (map (\(ss', dt, mmn) -> (ss', Just dt, mmn))) imports + rethrow (addHint (ErrorInModule currentModule)) $ do + let imports = findImports decls + imports' = M.map (map (\(ss', dt, mmn) -> (ss', Just dt, mmn))) imports scope = M.insert currentModule [(Nothing, Nothing, Nothing)] imports' - resolved <- foldM (resolveModuleImport env) nullImports (M.toList scope) - - return (Module ss coms currentModule decls' exps, resolved) - - where - defQual :: ImportDef -> Maybe ModuleName - defQual (_, _, q) = q - - selfCartesianSubset :: [a] -> [(a, a)] - selfCartesianSubset (x : xs) = [(x, y) | y <- xs] ++ selfCartesianSubset xs - selfCartesianSubset [] = [] - - checkDuplicateImports :: ModuleName -> [ImportDef] -> (ImportDef, ImportDef) -> m [ImportDef] - checkDuplicateImports mn xs ((_, t1, q1), (pos, t2, q2)) = - if (t1 == t2 && q1 == q2) - then do - warn pos $ DuplicateImport mn t2 q2 - return $ (pos, t2, q2) : xs - else return xs - - warnDupeRefs :: Maybe SourceSpan -> [DeclarationRef] -> m () - warnDupeRefs pos = traverse_ $ \case - TypeRef name _ -> warnDupe pos $ "type " ++ runProperName name - TypeOpRef name -> warnDupe pos $ "type operator " ++ runIdent name - ValueRef name -> warnDupe pos $ "value " ++ runIdent name - TypeClassRef name -> warnDupe pos $ "class " ++ runProperName name - ModuleRef name -> warnDupe pos $ "module " ++ runModuleName name - _ -> return () - - warnDupeDctors :: Maybe SourceSpan -> [ProperName 'ConstructorName] -> m () - warnDupeDctors pos = traverse_ (warnDupe pos . ("data constructor " ++) . runProperName) - - warnDupe :: Maybe SourceSpan -> String -> m () - warnDupe pos ref = warn pos $ DuplicateImportRef ref - - warn :: Maybe SourceSpan -> SimpleErrorMessage -> m () - warn pos msg = maybe id warnWithPosition pos $ tell . errorMessage $ msg - - updateImportRef :: Declaration -> m Declaration - updateImportRef (PositionedDeclaration pos com d) = - warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> updateImportRef d - updateImportRef (ImportDeclaration mn typ qual isOldSyntax) = do - modExports <- getExports env mn - typ' <- case typ of - Implicit -> return Implicit - Explicit refs -> Explicit <$> updateProperRef mn modExports `traverse` refs - Hiding refs -> Hiding <$> updateProperRef mn modExports `traverse` refs - return $ ImportDeclaration mn typ' qual isOldSyntax - updateImportRef other = return other - - updateProperRef :: ModuleName -> Exports -> DeclarationRef -> m DeclarationRef - updateProperRef importModule modExports (ProperRef name) = - if ProperName name `elem` (fst `map` exportedTypeClasses modExports) - then do - tell . errorMessage $ DeprecatedClassImport importModule (ProperName name) - return . TypeClassRef $ ProperName name - else return $ TypeRef (ProperName name) (Just []) - updateProperRef importModule modExports (PositionedDeclarationRef pos com ref) = - PositionedDeclarationRef pos com <$> updateProperRef importModule modExports ref - updateProperRef _ _ other = return other + (Module ss coms currentModule decls exps,) <$> + foldM (resolveModuleImport env) primImports (M.toList scope) -- | Constructs a set of imports for a single module import. resolveModuleImport :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . MonadError MultipleErrors m => Env -> Imports -> (ModuleName, [(Maybe SourceSpan, Maybe ImportDeclarationType, Maybe ModuleName)]) @@ -171,10 +69,15 @@ -> (Maybe SourceSpan, Maybe ImportDeclarationType, Maybe ModuleName) -> m Imports go ie' (pos, typ, impQual) = do - modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ mn `M.lookup` env - let virtualModules = importedVirtualModules ie' - ie'' = ie' { importedModules = S.insert mn (importedModules ie') - , importedVirtualModules = maybe virtualModules (`S.insert` virtualModules) impQual + modExports <- + positioned $ maybe + (throwError . errorMessage . UnknownName . Qualified Nothing $ ModName mn) + (return . envModuleExports) + (mn `M.lookup` env) + let impModules = importedModules ie' + qualModules = importedQualModules ie' + ie'' = ie' { importedModules = maybe (S.insert mn impModules) (const impModules) impQual + , importedQualModules = maybe qualModules (`S.insert` qualModules) impQual } positioned $ resolveImport mn modExports ie'' impQual typ where @@ -187,7 +90,7 @@ -- resolveImport :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . MonadError MultipleErrors m => ModuleName -> Exports -> Imports @@ -198,19 +101,14 @@ where resolveByType :: Maybe ImportDeclarationType -> m Imports - resolveByType Nothing = importAll (importRef Local) - resolveByType (Just Implicit) = importAll (importRef FromImplicit) - resolveByType (Just (Explicit refs)) = checkRefs False refs >> foldM (importRef FromExplicit) imps refs - resolveByType (Just (Hiding refs)) = do - imps' <- checkRefs True refs >> importAll (importNonHidden refs) - let isEmptyImport - = M.null (importedTypes imps') - && M.null (importedTypeOps imps') - && M.null (importedDataConstructors imps') - && M.null (importedTypeClasses imps') - && M.null (importedValues imps') - when isEmptyImport $ tell . errorMessage $ RedundantEmptyHidingImport importModule - return imps' + resolveByType Nothing = + importAll (importRef Local) + resolveByType (Just Implicit) = + importAll (importRef FromImplicit) + resolveByType (Just (Explicit refs)) = + checkRefs False refs >> foldM (importRef FromExplicit) imps refs + resolveByType (Just (Hiding refs)) = + checkRefs True refs >> importAll (importNonHidden refs) -- Check that a 'DeclarationRef' refers to an importable symbol checkRefs :: Bool -> [DeclarationRef] -> m () @@ -219,28 +117,32 @@ check (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ check r check (ValueRef name) = - checkImportExists UnknownImportValue (fst `map` exportedValues exps) name + checkImportExists IdentName (exportedValues exps) name + check (ValueOpRef op) = + checkImportExists ValOpName (exportedValueOps exps) op check (TypeRef name dctors) = do - checkImportExists UnknownImportType ((fst . fst) `map` exportedTypes exps) name - let allDctors = fst `map` allExportedDataConstructors name - maybe (return ()) (traverse_ $ checkDctorExists name allDctors) dctors + checkImportExists TyName (exportedTypes exps) name + let (allDctors, _) = allExportedDataConstructors name + for_ dctors $ traverse_ (checkDctorExists name allDctors) check (TypeOpRef name) = - checkImportExists UnknownImportTypeOp (fst `map` exportedTypeOps exps) name + checkImportExists TyOpName (exportedTypeOps exps) name check (TypeClassRef name) = - checkImportExists UnknownImportTypeClass (fst `map` exportedTypeClasses exps) name + checkImportExists TyClassName (exportedTypeClasses exps) name check (ModuleRef name) | isHiding = throwError . errorMessage $ ImportHidingModule name check r = internalError $ "Invalid argument to checkRefs: " ++ show r -- Check that an explicitly imported item exists in the module it is being imported from checkImportExists - :: Eq a - => (ModuleName -> a -> SimpleErrorMessage) - -> [a] + :: Ord a + => (a -> Name) + -> M.Map a b -> a -> m () - checkImportExists unknown exports item = - when (item `notElem` exports) $ throwError . errorMessage $ unknown importModule item + checkImportExists toName exports item + = when (item `M.notMember` exports) + . throwError . errorMessage + $ UnknownImport importModule (toName item) -- Ensure that an explicitly imported data constructor exists for the type it is being imported -- from @@ -249,7 +151,10 @@ -> [ProperName 'ConstructorName] -> ProperName 'ConstructorName -> m () - checkDctorExists tcon = checkImportExists (flip UnknownImportDataConstructor tcon) + checkDctorExists tcon exports dctor + = when (dctor `notElem` exports) + . throwError . errorMessage + $ UnknownImportDataConstructor importModule tcon dctor importNonHidden :: [DeclarationRef] -> Imports -> DeclarationRef -> m Imports importNonHidden hidden m ref | isHidden ref = return m @@ -270,54 +175,59 @@ -- Import all symbols importAll :: (Imports -> DeclarationRef -> m Imports) -> m Imports - importAll importer = do - imp' <- foldM (\m ((name, dctors), _) -> importer m (TypeRef name (Just dctors))) imps (exportedTypes exps) - imp'' <- foldM (\m (name, _) -> importer m (TypeOpRef name)) imp' (exportedTypeOps exps) - imp''' <- foldM (\m (name, _) -> importer m (ValueRef name)) imp'' (exportedValues exps) - foldM (\m (name, _) -> importer m (TypeClassRef name)) imp''' (exportedTypeClasses exps) + importAll importer = + foldM (\m (name, (dctors, _)) -> importer m (TypeRef name (Just dctors))) imps (M.toList (exportedTypes exps)) + >>= flip (foldM (\m (name, _) -> importer m (TypeOpRef name))) (M.toList (exportedTypeOps exps)) + >>= flip (foldM (\m (name, _) -> importer m (ValueRef name))) (M.toList (exportedValues exps)) + >>= flip (foldM (\m (name, _) -> importer m (ValueOpRef name))) (M.toList (exportedValueOps exps)) + >>= flip (foldM (\m (name, _) -> importer m (TypeClassRef name))) (M.toList (exportedTypeClasses exps)) importRef :: ImportProvenance -> Imports -> DeclarationRef -> m Imports importRef prov imp (PositionedDeclarationRef pos _ r) = - warnAndRethrowWithPosition pos $ importRef prov imp r + rethrowWithPosition pos $ importRef prov imp r importRef prov imp (ValueRef name) = do - let values' = updateImports (importedValues imp) (exportedValues exps) name prov + let values' = updateImports (importedValues imp) (exportedValues exps) id name prov return $ imp { importedValues = values' } + importRef prov imp (ValueOpRef name) = do + let valueOps' = updateImports (importedValueOps imp) (exportedValueOps exps) id name prov + return $ imp { importedValueOps = valueOps' } importRef prov imp (TypeRef name dctors) = do - let types' = updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name prov - let exportedDctors :: [(ProperName 'ConstructorName, ModuleName)] - exportedDctors = allExportedDataConstructors name - dctorNames :: [ProperName 'ConstructorName] - dctorNames = fst `map` exportedDctors - maybe (return ()) (traverse_ $ checkDctorExists name dctorNames) dctors - when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name - let dctors' = foldl (\m d -> updateImports m exportedDctors d prov) (importedDataConstructors imp) (fromMaybe dctorNames dctors) + let types' = updateImports (importedTypes imp) (exportedTypes exps) snd name prov + let (dctorNames, mn) = allExportedDataConstructors name + dctorLookup :: M.Map (ProperName 'ConstructorName) ModuleName + dctorLookup = M.fromList $ map (, mn) dctorNames + traverse_ (traverse_ $ checkDctorExists name dctorNames) dctors + let dctors' = foldl (\m d -> updateImports m dctorLookup id d prov) (importedDataConstructors imp) (fromMaybe dctorNames dctors) return $ imp { importedTypes = types', importedDataConstructors = dctors' } importRef prov imp (TypeOpRef name) = do - let ops' = updateImports (importedTypeOps imp) (exportedTypeOps exps) name prov + let ops' = updateImports (importedTypeOps imp) (exportedTypeOps exps) id name prov return $ imp { importedTypeOps = ops' } importRef prov imp (TypeClassRef name) = do - let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name prov + let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) id name prov return $ imp { importedTypeClasses = typeClasses' } - importRef _ _ _ = internalError "Invalid argument to importRef" + importRef _ _ TypeInstanceRef{} = internalError "TypeInstanceRef in importRef" + importRef _ _ ModuleRef{} = internalError "ModuleRef in importRef" -- Find all exported data constructors for a given type - allExportedDataConstructors :: ProperName 'TypeName -> [(ProperName 'ConstructorName, ModuleName)] + allExportedDataConstructors + :: ProperName 'TypeName + -> ([ProperName 'ConstructorName], ModuleName) allExportedDataConstructors name = - case find ((== name) . fst . fst) (exportedTypes exps) of - Nothing -> internalError "Invalid state in allExportedDataConstructors" - Just ((_, dctors), mn) -> map (, mn) dctors + fromMaybe (internalError "Invalid state in allExportedDataConstructors") + $ name `M.lookup` exportedTypes exps -- Add something to an import resolution list updateImports :: (Ord a) => M.Map (Qualified a) [ImportRecord a] - -> [(a, ModuleName)] + -> M.Map a b + -> (b -> ModuleName) -> a -> ImportProvenance -> M.Map (Qualified a) [ImportRecord a] - updateImports imps' exps' name prov = + updateImports imps' exps' expName name prov = let - mnOrig = fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps') + mnOrig = maybe (internalError "Invalid state in updateImports") expName (name `M.lookup` exps') rec = ImportRecord (Qualified (Just importModule) name) mnOrig prov in M.alter diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -1,12 +1,7 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.PureScript.Sugar.ObjectWildcards ( - desugarObjectConstructors -) where +module Language.PureScript.Sugar.ObjectWildcards + ( desugarObjectConstructors + ) where -import Prelude () import Prelude.Compat import Control.Monad (forM) @@ -39,10 +34,12 @@ desugarExpr (Parens b) | b' <- stripPositionInfo b , BinaryNoParens op val u <- b' - , isAnonymousArgument u = return $ OperatorSection op (Left val) + , isAnonymousArgument u = do arg <- freshIdent' + return $ Abs (Left arg) $ App (App op val) (Var (Qualified Nothing arg)) | b' <- stripPositionInfo b , BinaryNoParens op u val <- b' - , isAnonymousArgument u = return $ OperatorSection op (Right val) + , isAnonymousArgument u = do arg <- freshIdent' + return $ Abs (Left arg) $ App (App op (Var (Qualified Nothing arg))) val desugarExpr (Literal (ObjectLiteral ps)) = wrapLambda (Literal . ObjectLiteral) ps desugarExpr (ObjectUpdate u ps) | isAnonymousArgument u = do obj <- freshIdent' diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} - -- | -- This module implements the desugaring pass which reapplies binary operators based -- on their fixity data and removes explicit parentheses. @@ -11,12 +6,11 @@ -- it is necessary to reorder them here. -- module Language.PureScript.Sugar.Operators - ( rebracket - , removeSignedLiterals - , desugarOperatorSections + ( desugarSignedLiterals + , rebracket + , checkFixityExports ) where -import Prelude () import Prelude.Compat import Language.PureScript.AST @@ -30,85 +24,101 @@ import Language.PureScript.Traversals (defS, sndM) import Language.PureScript.Types -import Control.Monad ((<=<)) +import Control.Monad (unless, (<=<)) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Supply.Class +import Data.Either (partitionEithers) +import Data.Foldable (for_, traverse_) import Data.Function (on) -import Data.Functor.Identity -import Data.List (partition, groupBy, sortBy) -import Data.Maybe (mapMaybe) +import Data.Functor.Identity (Identity(..), runIdentity) +import Data.List (groupBy, sortBy) +import Data.Maybe (mapMaybe, listToMaybe) +import Data.Traversable (for) import qualified Data.Map as M import qualified Language.PureScript.Constants as C --- TODO: in 0.9 operators names can have their own type rather than being in a sum with `Ident`, and `FixityAlias` no longer needs to be optional +-- | +-- Removes unary negation operators and replaces them with calls to `negate`. +-- +desugarSignedLiterals :: Module -> Module +desugarSignedLiterals (Module ss coms mn ds exts) = + Module ss coms mn (map f' ds) exts + where + (f', _, _) = everywhereOnValues id go id + go (UnaryMinus val) = App (Var (Qualified Nothing (Ident C.negate))) val + go other = other -- | -- An operator associated with its declaration position, fixity, and the name -- of the function or data constructor it is an alias for. -- -type FixityRecord = (Qualified Ident, SourceSpan, Fixity, Maybe (Qualified FixityAlias)) +type FixityRecord op alias = (Qualified op, SourceSpan, Fixity, Qualified alias) +type ValueFixityRecord = FixityRecord (OpName 'ValueOpName) (Either Ident (ProperName 'ConstructorName)) +type TypeFixityRecord = FixityRecord (OpName 'TypeOpName) (ProperName 'TypeName) -- | --- Remove explicit parentheses and reorder binary operator applications +-- Remove explicit parentheses and reorder binary operator applications. -- +-- This pass requires name desugaring and export elaboration to have run first. +-- rebracket :: forall m . MonadError MultipleErrors m => [ExternsFile] -> [Module] -> m [Module] -rebracket externs ms = do - let (typeFixities, valueFixities) = partition isTypeFixity $ - concatMap externsFixities externs ++ concatMap collectFixities ms +rebracket externs modules = do + let (valueFixities, typeFixities) = + partitionEithers + $ concatMap externsFixities externs + ++ concatMap collectFixities modules - ensureNoDuplicates' $ valueFixities - ensureNoDuplicates' $ typeFixities + ensureNoDuplicates' MultipleValueOpFixities valueFixities + ensureNoDuplicates' MultipleTypeOpFixities typeFixities let valueOpTable = customOperatorTable' valueFixities - typeOpTable = customOperatorTable' typeFixities - ms' <- traverse (rebracketModule valueOpTable typeOpTable) ms + let valueAliased = M.fromList (map makeLookupEntry valueFixities) + let typeOpTable = customOperatorTable' typeFixities + let typeAliased = M.fromList (map makeLookupEntry typeFixities) - let valueAliased = M.fromList (mapMaybe makeLookupEntry valueFixities) - typeAliased = M.fromList (mapMaybe makeLookupEntry typeFixities) - mapM (renameAliasedOperators valueAliased typeAliased) ms' + for modules + $ renameAliasedOperators valueAliased typeAliased + <=< rebracketModule valueOpTable typeOpTable where - isTypeFixity :: FixityRecord -> Bool - -- Nothing case for FixityAlias can only ever be a value fixity, as it's not - -- possible to define types with operator names aside through aliasing. - -- TODO: This comment is redundant after 0.9. - isTypeFixity (_, _, _, Just (Qualified _ (AliasType _))) = True - isTypeFixity _ = False - - ensureNoDuplicates' :: [FixityRecord] -> m () - ensureNoDuplicates' = - ensureNoDuplicates . map (\(i, pos, _, _) -> (i, pos)) + ensureNoDuplicates' + :: Ord op + => (op -> SimpleErrorMessage) + -> [FixityRecord op alias] + -> m () + ensureNoDuplicates' toError = + ensureNoDuplicates toError . map (\(i, pos, _, _) -> (i, pos)) - customOperatorTable' :: [FixityRecord] -> [[(Qualified Ident, Associativity)]] - customOperatorTable' = - customOperatorTable . map (\(i, _, f, _) -> (i, f)) + customOperatorTable' + :: [FixityRecord op alias] + -> [[(Qualified op, Associativity)]] + customOperatorTable' = customOperatorTable . map (\(i, _, f, _) -> (i, f)) - makeLookupEntry :: FixityRecord -> Maybe (Qualified Ident, Qualified FixityAlias) - makeLookupEntry (qname, _, _, alias) = (qname, ) <$> alias + makeLookupEntry :: FixityRecord op alias -> (Qualified op, Qualified alias) + makeLookupEntry (qname, _, _, alias) = (qname, alias) renameAliasedOperators - :: M.Map (Qualified Ident) (Qualified FixityAlias) - -> M.Map (Qualified Ident) (Qualified FixityAlias) + :: M.Map (Qualified (OpName 'ValueOpName)) (Qualified (Either Ident (ProperName 'ConstructorName))) + -> M.Map (Qualified (OpName 'TypeOpName)) (Qualified (ProperName 'TypeName)) -> Module -> m Module renameAliasedOperators valueAliased typeAliased (Module ss coms mn ds exts) = Module ss coms mn <$> mapM f' ds <*> pure exts where - (goDecl', goExpr') = updateTypes goType + (goDecl', goExpr', goBinder') = updateTypes goType (f', _, _, _, _) = everywhereWithContextOnValuesM Nothing (\pos -> uncurry goDecl <=< goDecl' pos) (\pos -> uncurry goExpr <=< goExpr' pos) - goBinder + (\pos -> uncurry goBinder <=< goBinder' pos) defS defS @@ -118,52 +128,51 @@ goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr) goExpr _ e@(PositionedValue pos _ _) = return (Just pos, e) - goExpr pos (Var name) = return (pos, case name `M.lookup` valueAliased of - Just (Qualified mn' (AliasValue alias)) -> Var (Qualified mn' alias) - Just (Qualified mn' (AliasConstructor alias)) -> Constructor (Qualified mn' alias) - _ -> Var name) + goExpr pos (Op op) = + (pos, ) <$> case op `M.lookup` valueAliased of + Just (Qualified mn' (Left alias)) -> + return $ Var (Qualified mn' alias) + Just (Qualified mn' (Right alias)) -> + return $ Constructor (Qualified mn' alias) + Nothing -> + maybe id rethrowWithPosition pos $ + throwError . errorMessage . UnknownName $ fmap ValOpName op goExpr pos other = return (pos, other) goBinder :: Maybe SourceSpan -> Binder -> m (Maybe SourceSpan, Binder) goBinder _ b@(PositionedBinder pos _ _) = return (Just pos, b) - goBinder pos (BinaryNoParensBinder (OpBinder name) lhs rhs) = case name `M.lookup` valueAliased of - Just (Qualified _ (AliasValue alias)) -> - maybe id rethrowWithPosition pos $ - throwError . errorMessage $ InvalidOperatorInBinder (disqualify name) alias - Just (Qualified mn' (AliasConstructor alias)) -> - return (pos, ConstructorBinder (Qualified mn' alias) [lhs, rhs]) - _ -> - maybe id rethrowWithPosition pos $ - throwError . errorMessage $ UnknownValue name - goBinder _ (BinaryNoParensBinder {}) = + goBinder pos (BinaryNoParensBinder (OpBinder op) lhs rhs) = + case op `M.lookup` valueAliased of + Just (Qualified mn' (Left alias)) -> + maybe id rethrowWithPosition pos $ + throwError . errorMessage $ + InvalidOperatorInBinder op (Qualified mn' alias) + Just (Qualified mn' (Right alias)) -> + return (pos, ConstructorBinder (Qualified mn' alias) [lhs, rhs]) + Nothing -> + maybe id rethrowWithPosition pos $ + throwError . errorMessage . UnknownName $ fmap ValOpName op + goBinder _ BinaryNoParensBinder{} = internalError "BinaryNoParensBinder has no OpBinder" goBinder pos other = return (pos, other) goType :: Maybe SourceSpan -> Type -> m Type - goType pos = everywhereOnTypesM go + goType pos = maybe id rethrowWithPosition pos . everywhereOnTypesM go where go :: Type -> m Type - go (BinaryNoParensType (TypeOp name) lhs rhs) = case name `M.lookup` typeAliased of - Just (Qualified mn' (AliasType alias)) -> - return $ TypeApp (TypeApp (TypeConstructor (Qualified mn' alias)) lhs) rhs - _ -> - maybe id rethrowWithPosition pos $ - throwError . errorMessage $ UnknownTypeOp name + go (BinaryNoParensType (TypeOp op) lhs rhs) = + case op `M.lookup` typeAliased of + Just alias -> + return $ TypeApp (TypeApp (TypeConstructor alias) lhs) rhs + Nothing -> + throwError . errorMessage $ UnknownName $ fmap TyOpName op go other = return other -removeSignedLiterals :: Module -> Module -removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts - where - (f', _, _) = everywhereOnValues id go id - - go (UnaryMinus val) = App (Var (Qualified Nothing (Ident C.negate))) val - go other = other - rebracketModule :: forall m . (MonadError MultipleErrors m) - => [[(Qualified Ident, Associativity)]] - -> [[(Qualified Ident, Associativity)]] + => [[(Qualified (OpName 'ValueOpName), Associativity)]] + -> [[(Qualified (OpName 'TypeOpName), Associativity)]] -> Module -> m Module rebracketModule valueOpTable typeOpTable (Module ss coms mn ds exts) = @@ -173,9 +182,9 @@ everywhereOnValuesTopDownM (decontextify goDecl) (goExpr <=< decontextify goExpr') - goBinder + (goBinder <=< decontextify goBinder') - (goDecl, goExpr') = updateTypes (\_ -> goType) + (goDecl, goExpr', goBinder') = updateTypes (const goType) goExpr :: Expr -> m Expr goExpr = return . matchExprOperators valueOpTable @@ -196,9 +205,9 @@ everywhereOnValues (decontextify goDecl) (goExpr . decontextify goExpr') - goBinder + (goBinder . decontextify goBinder') - (goDecl, goExpr') = updateTypes (\_ -> return . goType) + (goDecl, goExpr', goBinder') = updateTypes (\_ -> return . goType) goExpr :: Expr -> Expr goExpr (Parens val) = val @@ -218,40 +227,61 @@ -> a decontextify ctxf = snd . runIdentity . ctxf Nothing -externsFixities - :: ExternsFile - -> [FixityRecord] +externsFixities :: ExternsFile -> [Either ValueFixityRecord TypeFixityRecord] externsFixities ExternsFile{..} = - [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec, alias) - | ExternsFixity assoc prec op alias <- efFixities - ] + map fromFixity efFixities ++ map fromTypeFixity efTypeFixities + where -collectFixities :: Module -> [FixityRecord] + fromFixity + :: ExternsFixity + -> Either ValueFixityRecord TypeFixityRecord + fromFixity (ExternsFixity assoc prec op name) = + Left + ( Qualified (Just efModuleName) op + , internalModuleSourceSpan "" + , Fixity assoc prec + , name + ) + + fromTypeFixity + :: ExternsTypeFixity + -> Either ValueFixityRecord TypeFixityRecord + fromTypeFixity (ExternsTypeFixity assoc prec op name) = + Right + ( Qualified (Just efModuleName) op + , internalModuleSourceSpan "" + , Fixity assoc prec + , name + ) + +collectFixities :: Module -> [Either ValueFixityRecord TypeFixityRecord] collectFixities (Module _ _ moduleName ds _) = concatMap collect ds where - collect :: Declaration -> [FixityRecord] - collect (PositionedDeclaration pos _ (FixityDeclaration fixity name alias)) = - [(Qualified (Just moduleName) (Op name), pos, fixity, alias)] + collect :: Declaration -> [Either ValueFixityRecord TypeFixityRecord] + collect (PositionedDeclaration pos _ (ValueFixityDeclaration fixity name op)) = + [Left (Qualified (Just moduleName) op, pos, fixity, name)] + collect (PositionedDeclaration pos _ (TypeFixityDeclaration fixity name op)) = + [Right (Qualified (Just moduleName) op, pos, fixity, name)] collect FixityDeclaration{} = internalError "Fixity without srcpos info" collect _ = [] ensureNoDuplicates - :: MonadError MultipleErrors m - => [(Qualified Ident, SourceSpan)] + :: (Ord a, MonadError MultipleErrors m) + => (a -> SimpleErrorMessage) + -> [(Qualified a, SourceSpan)] -> m () -ensureNoDuplicates m = go $ sortBy (compare `on` fst) m +ensureNoDuplicates toError m = go $ sortBy (compare `on` fst) m where go [] = return () go [_] = return () - go ((x@(Qualified (Just mn) name), _) : (y, pos) : _) | x == y = + go ((x@(Qualified (Just mn) op), _) : (y, pos) : _) | x == y = rethrow (addHint (ErrorInModule mn)) $ - rethrowWithPosition pos $ - throwError . errorMessage $ MultipleFixities name + rethrowWithPosition pos $ throwError . errorMessage $ toError op go (_ : rest) = go rest customOperatorTable - :: [(Qualified Ident, Fixity)] - -> [[(Qualified Ident, Associativity)]] + :: [(Qualified op, Fixity)] + -> [[(Qualified op, Associativity)]] customOperatorTable fixities = let userOps = map (\(name, Fixity a p) -> (name, p, a)) fixities @@ -260,36 +290,15 @@ in map (map (\(name, _, a) -> (name, a))) groups -desugarOperatorSections - :: forall m - . (MonadSupply m, MonadError MultipleErrors m) - => Module - -> m Module -desugarOperatorSections (Module ss coms mn ds exts) = - Module ss coms mn <$> traverse goDecl ds <*> pure exts - where - - goDecl :: Declaration -> m Declaration - (goDecl, _, _) = everywhereOnValuesM return goExpr return - - goExpr :: Expr -> m Expr - goExpr (OperatorSection op eVal) = do - arg <- freshIdent' - let var = Var (Qualified Nothing arg) - f2 a b = Abs (Left arg) $ App (App op a) b - return $ case eVal of - Left val -> f2 val var - Right val -> f2 var val - goExpr other = return other - updateTypes :: forall m . Monad m => (Maybe SourceSpan -> Type -> m Type) - -> ( Maybe SourceSpan -> Declaration -> m (Maybe SourceSpan, Declaration) - , Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr) + -> ( Maybe SourceSpan -> Declaration -> m (Maybe SourceSpan, Declaration) + , Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr) + , Maybe SourceSpan -> Binder -> m (Maybe SourceSpan, Binder) ) -updateTypes goType = (goDecl, goExpr) +updateTypes goType = (goDecl, goExpr, goBinder) where goType' :: Maybe SourceSpan -> Type -> m Type @@ -304,10 +313,10 @@ ty' <- goType' pos ty return (pos, ExternDeclaration name ty') goDecl pos (TypeClassDeclaration name args implies decls) = do - implies' <- traverse (sndM (traverse (goType' pos))) implies + implies' <- traverse (overConstraintArgs (traverse (goType' pos))) implies return (pos, TypeClassDeclaration name args implies' decls) goDecl pos (TypeInstanceDeclaration name cs className tys impls) = do - cs' <- traverse (sndM (traverse (goType' pos))) cs + cs' <- traverse (overConstraintArgs (traverse (goType' pos))) cs tys' <- traverse (goType' pos) tys return (pos, TypeInstanceDeclaration name cs' className tys' impls) goDecl pos (TypeSynonymDeclaration name args ty) = do @@ -320,9 +329,9 @@ goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr) goExpr _ e@(PositionedValue pos _ _) = return (Just pos, e) - goExpr pos (TypeClassDictionary (name, tys) dicts) = do + goExpr pos (TypeClassDictionary (Constraint name tys info) dicts) = do tys' <- traverse (goType' pos) tys - return (pos, TypeClassDictionary (name, tys') dicts) + return (pos, TypeClassDictionary (Constraint name tys' info) dicts) goExpr pos (SuperClassDictionary cls tys) = do tys' <- traverse (goType' pos) tys return (pos, SuperClassDictionary cls tys') @@ -330,3 +339,77 @@ ty' <- goType' pos ty return (pos, TypedValue check v ty') goExpr pos other = return (pos, other) + + goBinder :: Maybe SourceSpan -> Binder -> m (Maybe SourceSpan, Binder) + goBinder _ e@(PositionedBinder pos _ _) = return (Just pos, e) + goBinder pos (TypedBinder ty b) = do + ty' <- goType' pos ty + return (pos, TypedBinder ty' b) + goBinder pos other = return (pos, other) + +-- | +-- Checks all the fixity exports within a module to ensure that members aliased +-- by the operators are also exported from the module. +-- +-- This pass requires name desugaring and export elaboration to have run first. +-- +checkFixityExports + :: forall m + . MonadError MultipleErrors m + => Module + -> m Module +checkFixityExports (Module _ _ _ _ Nothing) = + internalError "exports should have been elaborated before checkFixityExports" +checkFixityExports m@(Module ss _ mn ds (Just exps)) = + rethrow (addHint (ErrorInModule mn)) + $ rethrowWithPosition ss (traverse_ checkRef exps) + *> return m + where + + checkRef :: DeclarationRef -> m () + checkRef (PositionedDeclarationRef pos _ d) = + rethrowWithPosition pos $ checkRef d + checkRef dr@(ValueOpRef op) = + for_ (getValueOpAlias op) $ \case + Left ident -> + unless (ValueRef ident `elem` exps) + . throwError . errorMessage + $ TransitiveExportError dr [ValueRef ident] + Right ctor -> + unless (anyTypeRef (maybe False (elem ctor) . snd)) + . throwError . errorMessage + $ TransitiveDctorExportError dr ctor + checkRef dr@(TypeOpRef op) = + for_ (getTypeOpAlias op) $ \ty -> + unless (anyTypeRef ((== ty) . fst)) + . throwError . errorMessage + $ TransitiveExportError dr [TypeRef ty Nothing] + checkRef _ = return () + + -- Finds the name associated with a type operator when that type is also + -- defined in the current module. + getTypeOpAlias :: OpName 'TypeOpName -> Maybe (ProperName 'TypeName) + getTypeOpAlias op = + listToMaybe (mapMaybe (either (const Nothing) go <=< getFixityDecl) ds) + where + go (TypeFixity _ (Qualified (Just mn') ident) op') + | mn == mn' && op == op' = Just ident + go _ = Nothing + + -- Finds the value or data constructor associated with an operator when that + -- declaration is also in the current module. + getValueOpAlias + :: OpName 'ValueOpName + -> Maybe (Either Ident (ProperName 'ConstructorName)) + getValueOpAlias op = + listToMaybe (mapMaybe (either go (const Nothing) <=< getFixityDecl) ds) + where + go (ValueFixity _ (Qualified (Just mn') ident) op') + | mn == mn' && op == op' = Just ident + go _ = Nothing + + -- Tests the exported `TypeRef` entries with a predicate. + anyTypeRef + :: ((ProperName 'TypeName, Maybe [ProperName 'ConstructorName]) -> Bool) + -> Bool + anyTypeRef f = any (maybe False f . getTypeRef) exps diff --git a/src/Language/PureScript/Sugar/Operators/Binders.hs b/src/Language/PureScript/Sugar/Operators/Binders.hs --- a/src/Language/PureScript/Sugar/Operators/Binders.hs +++ b/src/Language/PureScript/Sugar/Operators/Binders.hs @@ -1,13 +1,12 @@ module Language.PureScript.Sugar.Operators.Binders where -import Prelude () import Prelude.Compat import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Sugar.Operators.Common -matchBinderOperators :: [[(Qualified Ident, Associativity)]] -> Binder -> Binder +matchBinderOperators :: [[(Qualified (OpName 'ValueOpName), Associativity)]] -> Binder -> Binder matchBinderOperators = matchOperators isBinOp extractOp fromOp reapply id where @@ -19,9 +18,9 @@ extractOp (BinaryNoParensBinder op l r) = Just (op, l, r) extractOp _ = Nothing - fromOp :: Binder -> Maybe (Qualified Ident) - fromOp (OpBinder q@(Qualified _ (Op _))) = Just q + fromOp :: Binder -> Maybe (Qualified (OpName 'ValueOpName)) + fromOp (OpBinder q@(Qualified _ (OpName _))) = Just q fromOp _ = Nothing - reapply :: Qualified Ident -> Binder -> Binder -> Binder + reapply :: Qualified (OpName 'ValueOpName) -> Binder -> Binder -> Binder reapply = BinaryNoParensBinder . OpBinder diff --git a/src/Language/PureScript/Sugar/Operators/Common.hs b/src/Language/PureScript/Sugar/Operators/Common.hs --- a/src/Language/PureScript/Sugar/Operators/Common.hs +++ b/src/Language/PureScript/Sugar/Operators/Common.hs @@ -1,10 +1,5 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE PatternGuards #-} - module Language.PureScript.Sugar.Operators.Common where -import Prelude () import Prelude.Compat import Control.Monad.State @@ -33,36 +28,36 @@ parseValue = token (either Just (const Nothing)) P. "expression" parseOp - :: (a -> (Maybe (Qualified Ident))) - -> P.Parsec (Chain a) () (Qualified Ident) + :: (a -> (Maybe (Qualified (OpName nameType)))) + -> P.Parsec (Chain a) () (Qualified (OpName nameType)) parseOp fromOp = token (either (const Nothing) fromOp) P. "operator" matchOp - :: (a -> (Maybe (Qualified Ident))) - -> Qualified Ident + :: (a -> (Maybe (Qualified (OpName nameType)))) + -> Qualified (OpName nameType) -> P.Parsec (Chain a) () () matchOp fromOp op = do ident <- parseOp fromOp guard $ ident == op opTable - :: [[(Qualified Ident, Associativity)]] - -> (a -> Maybe (Qualified Ident)) - -> (Qualified Ident -> a -> a -> a) + :: [[(Qualified (OpName nameType), Associativity)]] + -> (a -> Maybe (Qualified (OpName nameType))) + -> (Qualified (OpName nameType) -> a -> a -> a) -> [[P.Operator (Chain a) () Identity a]] opTable ops fromOp reapply = map (map (\(name, a) -> P.Infix (P.try (matchOp fromOp name) >> return (reapply name)) (toAssoc a))) ops ++ [[ P.Infix (P.try (parseOp fromOp >>= \ident -> return (reapply ident))) P.AssocLeft ]] matchOperators - :: forall a + :: forall a nameType . Show a => (a -> Bool) -> (a -> Maybe (a, a, a)) - -> (a -> Maybe (Qualified Ident)) - -> (Qualified Ident -> a -> a -> a) + -> (a -> Maybe (Qualified (OpName nameType))) + -> (Qualified (OpName nameType) -> a -> a -> a) -> ([[P.Operator (Chain a) () Identity a]] -> P.OperatorTable (Chain a) () Identity a) - -> [[(Qualified Ident, Associativity)]] + -> [[(Qualified (OpName nameType), Associativity)]] -> a -> a matchOperators isBinOp extractOp fromOp reapply modOpTable ops = parseChains diff --git a/src/Language/PureScript/Sugar/Operators/Expr.hs b/src/Language/PureScript/Sugar/Operators/Expr.hs --- a/src/Language/PureScript/Sugar/Operators/Expr.hs +++ b/src/Language/PureScript/Sugar/Operators/Expr.hs @@ -1,9 +1,5 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - module Language.PureScript.Sugar.Operators.Expr where -import Prelude () import Prelude.Compat import Data.Functor.Identity @@ -15,7 +11,7 @@ import Language.PureScript.Names import Language.PureScript.Sugar.Operators.Common -matchExprOperators :: [[(Qualified Ident, Associativity)]] -> Expr -> Expr +matchExprOperators :: [[(Qualified (OpName 'ValueOpName), Associativity)]] -> Expr -> Expr matchExprOperators = matchOperators isBinOp extractOp fromOp reapply modOpTable where @@ -27,12 +23,12 @@ extractOp (BinaryNoParens op l r) = Just (op, l, r) extractOp _ = Nothing - fromOp :: Expr -> Maybe (Qualified Ident) - fromOp (Var q@(Qualified _ (Op _))) = Just q + fromOp :: Expr -> Maybe (Qualified (OpName 'ValueOpName)) + fromOp (Op q@(Qualified _ (OpName _))) = Just q fromOp _ = Nothing - reapply :: Qualified Ident -> Expr -> Expr -> Expr - reapply op t1 t2 = App (App (Var op) t1) t2 + reapply :: Qualified (OpName 'ValueOpName) -> Expr -> Expr -> Expr + reapply op t1 t2 = App (App (Op op) t1) t2 modOpTable :: [[P.Operator (Chain Expr) () Identity Expr]] @@ -44,5 +40,5 @@ parseTicks :: P.Parsec (Chain Expr) () Expr parseTicks = token (either (const Nothing) fromOther) P. "infix function" where - fromOther (Var (Qualified _ (Op _))) = Nothing + fromOther (Op _) = Nothing fromOther v = Just v diff --git a/src/Language/PureScript/Sugar/Operators/Types.hs b/src/Language/PureScript/Sugar/Operators/Types.hs --- a/src/Language/PureScript/Sugar/Operators/Types.hs +++ b/src/Language/PureScript/Sugar/Operators/Types.hs @@ -1,6 +1,5 @@ module Language.PureScript.Sugar.Operators.Types where -import Prelude () import Prelude.Compat import Language.PureScript.AST @@ -8,7 +7,7 @@ import Language.PureScript.Sugar.Operators.Common import Language.PureScript.Types -matchTypeOperators :: [[(Qualified Ident, Associativity)]] -> Type -> Type +matchTypeOperators :: [[(Qualified (OpName 'TypeOpName), Associativity)]] -> Type -> Type matchTypeOperators = matchOperators isBinOp extractOp fromOp reapply id where @@ -20,9 +19,9 @@ extractOp (BinaryNoParensType op l r) = Just (op, l, r) extractOp _ = Nothing - fromOp :: Type -> Maybe (Qualified Ident) - fromOp (TypeOp q@(Qualified _ (Op _))) = Just q + fromOp :: Type -> Maybe (Qualified (OpName 'TypeOpName)) + fromOp (TypeOp q@(Qualified _ (OpName _))) = Just q fromOp _ = Nothing - reapply :: Qualified Ident -> Type -> Type -> Type + reapply :: Qualified (OpName 'TypeOpName) -> Type -> Type -> Type reapply = BinaryNoParensType . TypeOp diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - -- | -- This module implements the desugaring pass which creates type synonyms for type class dictionaries -- and dictionary expressions for type class instances. @@ -12,7 +8,6 @@ , superClassDictionaryNames ) where -import Prelude () import Prelude.Compat import Language.PureScript.Crash @@ -52,7 +47,8 @@ desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModule where initialState :: MemberMap - initialState = M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations) + initialState = M.singleton (ModuleName [ProperName C.prim], ProperName C.partial) ([], [], []) + `M.union` M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations) fromExternsDecl :: ModuleName @@ -233,11 +229,11 @@ typeClassDictionaryDeclaration name args implies members = let superclassTypes = superClassDictionaryNames implies `zip` [ function unit (foldl TypeApp (TypeConstructor (fmap coerceProperName superclass)) tyArgs) - | (superclass, tyArgs) <- implies + | (Constraint superclass tyArgs _) <- implies ] members' = map (first runIdent . memberToNameAndType) members mtys = members' ++ superclassTypes - in TypeSynonymDeclaration (coerceProperName name) args (TypeApp tyObject $ rowFromList (mtys, REmpty)) + in TypeSynonymDeclaration (coerceProperName name) args (TypeApp tyRecord $ rowFromList (mtys, REmpty)) typeClassMemberToDictionaryAccessor :: ModuleName @@ -249,13 +245,13 @@ let className = Qualified (Just mn) name in ValueDeclaration ident Private [] $ Right $ TypedValue False (TypeClassDictionaryAccessor className ident) $ - moveQuantifiersToFront (quantify (ConstrainedType [(className, map (TypeVar . fst) args)] ty)) + moveQuantifiersToFront (quantify (ConstrainedType [Constraint className (map (TypeVar . fst) args) Nothing] ty)) typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com d) = PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration in type class definition" unit :: Type -unit = TypeApp tyObject REmpty +unit = TypeApp tyRecord REmpty typeInstanceDictionaryDeclaration :: forall m @@ -273,7 +269,7 @@ -- Lookup the type arguments and member types for the type class (args, implies, tyDecls) <- - maybe (throwError . errorMessage $ UnknownTypeClass className) return $ + maybe (throwError . errorMessage . UnknownName $ fmap TyClassName className) return $ M.lookup (qualify mn className) m case mapMaybe declName tyDecls \\ mapMaybe declName decls of @@ -289,11 +285,11 @@ members <- zip (map typeClassMemberName decls) <$> traverse (memberToValue memberTypes) decls -- Create the type of the dictionary - -- The type is an object type, but depending on type instance dependencies, may be constrained. - -- The dictionary itself is an object literal. + -- The type is a record type, but depending on type instance dependencies, may be constrained. + -- The dictionary itself is a record literal. let superclasses = superClassDictionaryNames implies `zip` [ Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs) - | (superclass, suTyArgs) <- implies + | (Constraint superclass suTyArgs _) <- implies , let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs ] @@ -330,5 +326,5 @@ superClassDictionaryNames :: [Constraint] -> [String] superClassDictionaryNames supers = [ C.__superclass_ ++ showQualified runProperName pn ++ "_" ++ show (index :: Integer) - | (index, (pn, _)) <- zip [0..] supers + | (index, Constraint pn _ _) <- zip [0..] supers ] diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -1,29 +1,23 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -- | -- This module implements the generic deriving elaboration that takes place during desugaring. -- module Language.PureScript.Sugar.TypeClasses.Deriving (deriveInstances) where -import Prelude () import Prelude.Compat -import Data.List (foldl', find, sortBy) -import Data.Maybe (fromMaybe) -import Data.Ord (comparing) - import Control.Arrow (second) import Control.Monad (replicateM) -import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Supply.Class (MonadSupply) -import Language.PureScript.Crash +import Data.List (foldl', find, sortBy) +import Data.Maybe (fromMaybe) +import Data.Ord (comparing) + import Language.PureScript.AST +import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Names @@ -50,11 +44,11 @@ , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args - | className == Qualified (Just (ModuleName [ ProperName "Prelude" ])) (ProperName "Eq") + | className == Qualified (Just (ModuleName [ ProperName "Data", ProperName "Eq" ])) (ProperName "Eq") , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn ds tyCon - | className == Qualified (Just (ModuleName [ ProperName "Prelude" ])) (ProperName "Ord") + | className == Qualified (Just (ModuleName [ ProperName "Data", ProperName "Ord" ])) (ProperName "Ord") , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon @@ -218,8 +212,8 @@ = App (lamCase (Ident "r") [ mkRecCase (decomposeRec rec) , CaseAlternative [NullBinder] (Right mkNothing) ]) - (App e (mkPrelVar (Ident "unit"))) - fromSpineFun e _ = App (mkGenVar (Ident C.fromSpine)) (App e (mkPrelVar (Ident "unit"))) + (App e unitVal) + fromSpineFun e _ = App (mkGenVar (Ident C.fromSpine)) (App e unitVal) mkRecCase :: [(String, Type)] -> CaseAlternative mkRecCase rs = @@ -237,11 +231,14 @@ -- Helpers liftApplicative :: Expr -> [Expr] -> Expr - liftApplicative = foldl' (\x e -> App (App (mkPrelVar (Ident "apply")) x) e) + liftApplicative = foldl' (\x e -> App (App applyFn x) e) - mkPrelVar :: Ident -> Expr - mkPrelVar = mkVarMn (Just (ModuleName [ProperName C.prelude])) + unitVal :: Expr + unitVal = mkVarMn (Just (ModuleName [ProperName "Data", ProperName "Unit"])) (Ident "unit") + applyFn :: Expr + applyFn = mkVarMn (Just (ModuleName [ProperName "Control", ProperName "Apply"])) (Ident "apply") + mkGenVar :: Ident -> Expr mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic])) @@ -265,10 +262,10 @@ mkEqFunction _ = internalError "mkEqFunction: expected DataDeclaration" preludeConj :: Expr -> Expr -> Expr - preludeConj = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.conj))) + preludeConj = App . App (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "HeytingAlgebra"])) (Ident C.conj))) preludeEq :: Expr -> Expr -> Expr - preludeEq = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.eq))) + preludeEq = App . App (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Eq"])) (Ident C.eq))) addCatch :: [CaseAlternative] -> [CaseAlternative] addCatch xs @@ -326,14 +323,20 @@ | null xs = [catchAll] -- No type constructors | otherwise = xs where - catchAll = CaseAlternative [NullBinder, NullBinder] (Right (preludeCtor "EQ")) + catchAll = CaseAlternative [NullBinder, NullBinder] (Right (orderingCtor "EQ")) - preludeCtor :: String -> Expr - preludeCtor = Constructor . Qualified (Just (ModuleName [ProperName C.prelude])) . ProperName + orderingName :: String -> Qualified (ProperName a) + orderingName = Qualified (Just (ModuleName [ProperName "Data", ProperName "Ordering"])) . ProperName - preludeCompare :: Expr -> Expr -> Expr - preludeCompare = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.compare))) + orderingCtor :: String -> Expr + orderingCtor = Constructor . orderingName + orderingBinder :: String -> Binder + orderingBinder name = ConstructorBinder (orderingName name) [] + + ordCompare :: Expr -> Expr -> Expr + ordCompare = App . App (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Ord"])) (Ident C.compare))) + mkCtorClauses :: ((ProperName 'ConstructorName, [Type]), Bool) -> m [CaseAlternative] mkCtorClauses ((ctorName, tys), isLast) = do identsL <- replicateM (length tys) (freshIdent "l") @@ -342,11 +345,11 @@ extras | not isLast = [ CaseAlternative [ ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder) , NullBinder ] - (Right (preludeCtor "LT")) + (Right (orderingCtor "LT")) , CaseAlternative [ NullBinder , ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder) ] - (Right (preludeCtor "GT")) + (Right (orderingCtor "GT")) ] | otherwise = [] return $ CaseAlternative [ caseBinder identsL @@ -359,12 +362,12 @@ caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents) appendAll :: [Expr] -> Expr - appendAll [] = preludeCtor "EQ" + appendAll [] = orderingCtor "EQ" appendAll [x] = x - appendAll (x : xs) = Case [x] [ CaseAlternative [ ConstructorBinder (Qualified (Just (ModuleName [ProperName C.prelude])) (ProperName "LT")) [] ] - (Right (preludeCtor "LT")) - , CaseAlternative [ ConstructorBinder (Qualified (Just (ModuleName [ProperName C.prelude])) (ProperName "GT")) [] ] - (Right (preludeCtor "GT")) + appendAll (x : xs) = Case [x] [ CaseAlternative [orderingBinder "LT"] + (Right (orderingCtor "LT")) + , CaseAlternative [orderingBinder "GT"] + (Right (orderingCtor "GT")) , CaseAlternative [ NullBinder ] (Right (appendAll xs)) ] @@ -374,7 +377,7 @@ appendAll . map (\(str, typ) -> toOrdering (Accessor str l) (Accessor str r) typ) $ decomposeRec rec - toOrdering l r _ = preludeCompare l r + toOrdering l r _ = ordCompare l r findTypeDecl :: (MonadError MultipleErrors m) @@ -407,7 +410,7 @@ mkVar = mkVarMn Nothing objectType :: Type -> Maybe Type -objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Object"))) rec) = Just rec +objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Record"))) rec) = Just rec objectType _ = Nothing decomposeRec :: Type -> [(String, Type)] diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -1,30 +1,13 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Sugar.TypeDeclarations --- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | --- This module implements the desugaring pass which replaces top-level type declarations with --- type annotations on the corresponding expression. +-- This module implements the desugaring pass which replaces top-level type +-- declarations with type annotations on the corresponding expression. -- ------------------------------------------------------------------------------ - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.PureScript.Sugar.TypeDeclarations ( - desugarTypeDeclarationsModule -) where +module Language.PureScript.Sugar.TypeDeclarations + ( desugarTypeDeclarationsModule + ) where -import Prelude () import Prelude.Compat -import Control.Monad (forM) import Control.Monad.Error.Class (MonadError(..)) import Language.PureScript.AST @@ -36,38 +19,45 @@ -- | -- Replace all top level type declarations in a module with type annotations -- -desugarTypeDeclarationsModule :: forall m. (MonadError MultipleErrors m) => [Module] -> m [Module] -desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) -> +desugarTypeDeclarationsModule + :: forall m + . MonadError MultipleErrors m + => Module + -> m Module +desugarTypeDeclarationsModule (Module ss coms name ds exps) = rethrow (addHint (ErrorInModule name)) $ Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps where desugarTypeDeclarations :: [Declaration] -> m [Declaration] - desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do - (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds) - return (PositionedDeclaration pos com d' : ds') - desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do + desugarTypeDeclarations (PositionedDeclaration pos com d : rest) = do + (d' : rest') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : rest) + return (PositionedDeclaration pos com d' : rest') + desugarTypeDeclarations (TypeDeclaration name' ty : d : rest) = do (_, nameKind, val) <- fromValueDeclaration d - desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest) + desugarTypeDeclarations (ValueDeclaration name' nameKind [] (Right (TypedValue True val ty)) : rest) where fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr) - fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val) + fromValueDeclaration (ValueDeclaration name'' nameKind [] (Right val)) + | name' == name'' = return (name'', nameKind, val) fromValueDeclaration (PositionedDeclaration pos com d') = do (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d' return (ident, nameKind, PositionedValue pos com val) - fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name - desugarTypeDeclarations [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name - desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do + fromValueDeclaration _ = + throwError . errorMessage $ OrphanTypeDeclaration name' + desugarTypeDeclarations [TypeDeclaration name' _] = + throwError . errorMessage $ OrphanTypeDeclaration name' + desugarTypeDeclarations (ValueDeclaration name' nameKind bs val : rest) = do let (_, f, _) = everywhereOnValuesTopDownM return go return f' (Left gs) = Left <$> mapM (pairM return f) gs f' (Right v) = Right <$> f v - (:) <$> (ValueDeclaration name nameKind bs <$> f' val) + (:) <$> (ValueDeclaration name' nameKind bs <$> f' val) <*> desugarTypeDeclarations rest where - go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val' + go (Let ds' val') = Let <$> desugarTypeDeclarations ds' <*> pure val' go other = return other - desugarTypeDeclarations (TypeInstanceDeclaration nm deps cls args (ExplicitInstance ds) : rest) = - (:) <$> (TypeInstanceDeclaration nm deps cls args . ExplicitInstance <$> desugarTypeDeclarations ds) + desugarTypeDeclarations (TypeInstanceDeclaration nm deps cls args (ExplicitInstance ds') : rest) = + (:) <$> (TypeInstanceDeclaration nm deps cls args . ExplicitInstance <$> desugarTypeDeclarations ds') <*> desugarTypeDeclarations rest - desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds + desugarTypeDeclarations (d:rest) = (:) d <$> desugarTypeDeclarations rest desugarTypeDeclarations [] = return [] diff --git a/src/Language/PureScript/Traversals.hs b/src/Language/PureScript/Traversals.hs --- a/src/Language/PureScript/Traversals.hs +++ b/src/Language/PureScript/Traversals.hs @@ -1,42 +1,27 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Traversals --- Copyright : (c) 2014 Phil Freeman --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | Common functions for implementing generic traversals --- ------------------------------------------------------------------------------ - -module Language.PureScript.Traversals where - -import Prelude () -import Prelude.Compat - -fstM :: (Functor f) => (a -> f c) -> (a, b) -> f (c, b) -fstM f (a, b) = flip (,) b <$> f a - -sndM :: (Functor f) => (b -> f c) -> (a, b) -> f (a, c) -sndM f (a, b) = (,) a <$> f b - -thirdM :: (Functor f) => (c -> f d) -> (a, b, c) -> f (a, b, d) -thirdM f (a, b, c) = (,,) a b <$> f c - -pairM :: (Applicative f) => (a -> f c) -> (b -> f d) -> (a, b) -> f (c, d) -pairM f g (a, b) = (,) <$> f a <*> g b - -maybeM :: (Applicative f) => (a -> f b) -> Maybe a -> f (Maybe b) -maybeM _ Nothing = pure Nothing -maybeM f (Just a) = Just <$> f a - -eitherM :: (Applicative f) => (a -> f c) -> (b -> f d) -> Either a b -> f (Either c d) -eitherM f _ (Left a) = Left <$> f a -eitherM _ g (Right b) = Right <$> g b - -defS :: (Monad m) => st -> val -> m (st, val) -defS s val = return (s, val) - +-- | Common functions for implementing generic traversals +module Language.PureScript.Traversals where + +import Prelude.Compat + +fstM :: (Functor f) => (a -> f c) -> (a, b) -> f (c, b) +fstM f (a, b) = flip (,) b <$> f a + +sndM :: (Functor f) => (b -> f c) -> (a, b) -> f (a, c) +sndM f (a, b) = (,) a <$> f b + +thirdM :: (Functor f) => (c -> f d) -> (a, b, c) -> f (a, b, d) +thirdM f (a, b, c) = (,,) a b <$> f c + +pairM :: (Applicative f) => (a -> f c) -> (b -> f d) -> (a, b) -> f (c, d) +pairM f g (a, b) = (,) <$> f a <*> g b + +maybeM :: (Applicative f) => (a -> f b) -> Maybe a -> f (Maybe b) +maybeM _ Nothing = pure Nothing +maybeM f (Just a) = Just <$> f a + +eitherM :: (Applicative f) => (a -> f c) -> (b -> f d) -> Either a b -> f (Either c d) +eitherM f _ (Left a) = Left <$> f a +eitherM _ g (Right b) = Right <$> g b + +defS :: (Monad m) => st -> val -> m (st, val) +defS s val = return (s, val) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -1,42 +1,38 @@ -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PatternGuards #-} -- | -- The top-level type checker, which checks all declarations in a module. -- -module Language.PureScript.TypeChecker ( - module T, - typeCheckModule -) where +module Language.PureScript.TypeChecker + ( module T + , typeCheckModule + ) where -import Prelude () import Prelude.Compat -import Language.PureScript.TypeChecker.Monad as T -import Language.PureScript.TypeChecker.Kinds as T -import Language.PureScript.TypeChecker.Types as T -import Language.PureScript.TypeChecker.Synonyms as T - -import Data.Maybe -import Data.List (nub, nubBy, (\\), sort, group) -import Data.Foldable (for_, traverse_) - -import qualified Data.Map as M - import Control.Monad (when, unless, void, forM, forM_) -import Control.Monad.Supply.Class (MonadSupply) -import Control.Monad.State.Class (MonadState(..), modify) import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.State.Class (MonadState(..), modify) +import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.Writer.Class (MonadWriter(..)) +import Data.Foldable (for_, traverse_) +import Data.List (nub, nubBy, (\\), sort, group) +import Data.Maybe +import qualified Data.Map as M + import Language.PureScript.AST import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Kinds +import Language.PureScript.Linter import Language.PureScript.Names +import Language.PureScript.Traversals +import Language.PureScript.TypeChecker.Kinds as T +import Language.PureScript.TypeChecker.Monad as T +import Language.PureScript.TypeChecker.Synonyms as T +import Language.PureScript.TypeChecker.Types as T import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types @@ -151,6 +147,7 @@ -> Type -> m () checkTypeClassInstance _ (TypeVar _) = return () +checkTypeClassInstance _ (TypeLevelString _) = return () checkTypeClassInstance _ (TypeConstructor ctor) = do env <- getEnv when (ctor `M.member` typeSynonyms env) . throwError . errorMessage $ TypeSynonymInstance @@ -187,7 +184,7 @@ -> [DeclarationRef] -> [Declaration] -> m [Declaration] -typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds +typeCheckAll moduleName _ = traverse go where go :: Declaration -> m Declaration go (DataDeclaration dtype name args dctors) = do @@ -227,27 +224,32 @@ let args' = args `withKinds` kind addTypeSynonym moduleName name args' ty kind return $ TypeSynonymDeclaration name args ty - go TypeDeclaration{} = internalError "Type declarations should have been removed" - go (ValueDeclaration name nameKind [] (Right val)) = + go TypeDeclaration{} = + internalError "Type declarations should have been removed before typeCheckAlld" + go (ValueDeclaration name nameKind [] (Right val)) = do + env <- getEnv warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do + val' <- checkExhaustiveExpr env moduleName val valueIsNotDefined moduleName name - [(_, (val', ty))] <- typesOf NonRecursiveBindingGroup moduleName [(name, val)] + [(_, (val'', ty))] <- typesOf NonRecursiveBindingGroup moduleName [(name, val')] addValue moduleName name ty nameKind - return $ ValueDeclaration name nameKind [] $ Right val' + return $ ValueDeclaration name nameKind [] $ Right val'' go ValueDeclaration{} = internalError "Binders were not desugared" - go (BindingGroupDeclaration vals) = + go (BindingGroupDeclaration vals) = do + env <- getEnv warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do - for_ (map (\(ident, _, _) -> ident) vals) $ \name -> - valueIsNotDefined moduleName name - tys <- typesOf RecursiveBindingGroup moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals - vals' <- forM [ (name, val, nameKind, ty) - | (name, nameKind, _) <- vals - , (name', (val, ty)) <- tys - , name == name' - ] $ \(name, val, nameKind, ty) -> do + for_ vals $ \(ident, _, _) -> + valueIsNotDefined moduleName ident + vals' <- mapM (thirdM (checkExhaustiveExpr env moduleName)) vals + tys <- typesOf RecursiveBindingGroup moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals' + vals'' <- forM [ (name, val, nameKind, ty) + | (name, nameKind, _) <- vals' + , (name', (val, ty)) <- tys + , name == name' + ] $ \(name, val, nameKind, ty) -> do addValue moduleName name ty nameKind return (name, nameKind, val) - return $ BindingGroupDeclaration vals' + return $ BindingGroupDeclaration vals'' go (d@(ExternDataDeclaration name kind)) = do env <- getEnv putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) } @@ -261,14 +263,14 @@ Just _ -> throwError . errorMessage $ RedefinedIdent name Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) }) return d - go (d@FixityDeclaration{}) = return d - go (d@ImportDeclaration{}) = return d - go (d@(TypeClassDeclaration pn args implies tys)) = do + go d@FixityDeclaration{} = return d + go d@ImportDeclaration{} = return d + go d@(TypeClassDeclaration pn args implies tys) = do addTypeClass moduleName pn args implies tys return d go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do traverse_ (checkTypeClassInstance moduleName) tys - forM_ deps $ traverse_ (checkTypeClassInstance moduleName) . snd + forM_ deps $ traverse_ (checkTypeClassInstance moduleName) . constraintArgs checkOrphanInstance dictName className tys _ <- traverseTypeInstanceBody checkInstanceMembers body let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps) @@ -277,23 +279,6 @@ go (PositionedDeclaration pos com d) = warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d - checkFixities :: Declaration -> m () - checkFixities (FixityDeclaration _ name (Just (Qualified mn' (AliasValue ident)))) = do - ty <- lookupVariable moduleName (Qualified mn' ident) - addValue moduleName (Op name) ty Public - checkFixities (FixityDeclaration _ name (Just (Qualified mn' (AliasConstructor ctor)))) = do - env <- getEnv - let alias = Qualified mn' ctor - case M.lookup alias (dataConstructors env) of - Nothing -> throwError . errorMessage $ UnknownDataConstructor alias Nothing - Just (_, _, ty, _) -> addValue moduleName (Op name) ty Public - checkFixities (FixityDeclaration _ name Nothing) = do - env <- getEnv - guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env - checkFixities (PositionedDeclaration pos _ d) = - warnAndRethrowWithPosition pos $ checkFixities d - checkFixities _ = return () - checkInstanceMembers :: [Declaration] -> m [Declaration] checkInstanceMembers instDecls = do let idents = sort . map head . group . map memberName $ instDecls @@ -348,16 +333,17 @@ . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> m Module -typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated" -typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do - modify (\s -> s { checkCurrentModule = Just mn }) - decls' <- typeCheckAll mn exps decls - for_ exps $ \e -> do - checkTypesAreExported e - checkClassMembersAreExported e - checkClassesAreExported e - checkNonAliasesAreExported (exportedDataConstructors exps) e - return $ Module ss coms mn decls' (Just exps) +typeCheckModule (Module _ _ _ _ Nothing) = + internalError "exports should have been elaborated before typeCheckModule" +typeCheckModule (Module ss coms mn decls (Just exps)) = + warnAndRethrow (addHint (ErrorInModule mn)) $ do + modify (\s -> s { checkCurrentModule = Just mn }) + decls' <- typeCheckAll mn exps decls + for_ exps $ \e -> do + checkTypesAreExported e + checkClassMembersAreExported e + checkClassesAreExported e + return $ Module ss coms mn decls' (Just exps) where checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> m () @@ -415,7 +401,7 @@ findClasses :: Type -> [DeclarationRef] findClasses = everythingOnTypes (++) go where - go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . fst) cs + go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . constraintClass) cs go _ = [] extractCurrentModuleClass :: Qualified (ProperName 'ClassName) -> Maybe (ProperName 'ClassName) extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name @@ -436,38 +422,3 @@ extractMemberName (TypeDeclaration memberName _) = memberName extractMemberName _ = internalError "Unexpected declaration in typeclass member list" checkClassMembersAreExported _ = return () - - checkNonAliasesAreExported :: [ProperName 'ConstructorName] -> DeclarationRef -> m () - checkNonAliasesAreExported exportedDctors dr@(ValueRef (Op name)) = - case listToMaybe (mapMaybe (getAlias getValueAlias name) decls) of - Just (Left ident) -> - unless (ValueRef ident `elem` exps) $ - throwError . errorMessage $ TransitiveExportError dr [ValueRef ident] - Just (Right ctor) -> - unless (ctor `elem` exportedDctors) $ - throwError . errorMessage $ TransitiveDctorExportError dr ctor - _ -> return () - checkNonAliasesAreExported _ dr@(TypeOpRef (Op name)) = - case listToMaybe (mapMaybe (getAlias getTypeAlias name) decls) of - Just ty -> - unless (any (isTypeRefFor ty) exps) $ - throwError . errorMessage $ TransitiveExportError dr [TypeRef ty Nothing] - _ -> return () - where - isTypeRefFor :: ProperName 'TypeName -> DeclarationRef -> Bool - isTypeRefFor ty (TypeRef ty' _) = ty == ty' - isTypeRefFor _ _ = False - checkNonAliasesAreExported _ _ = return () - - getAlias :: (FixityAlias -> Maybe a) -> String -> Declaration -> Maybe a - getAlias match name (PositionedDeclaration _ _ d) = getAlias match name d - getAlias match name (FixityDeclaration _ name' (Just (Qualified (Just mn') a))) - | Just alias <- match a, name == name' && mn == mn' = Just alias - getAlias _ _ _ = Nothing - - exportedDataConstructors :: [DeclarationRef] -> [ProperName 'ConstructorName] - exportedDataConstructors = foldMap extractCtor - where - extractCtor :: DeclarationRef -> [ProperName 'ConstructorName] - extractCtor (TypeRef _ (Just ctors)) = ctors - extractCtor _ = [] diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -1,27 +1,25 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} - -- | -- Type class entailment -- -module Language.PureScript.TypeChecker.Entailment (Context, replaceTypeClassDictionaries) where +module Language.PureScript.TypeChecker.Entailment + ( Context + , replaceTypeClassDictionaries + ) where -import Prelude () import Prelude.Compat +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.State +import Control.Monad.Supply.Class (MonadSupply(..)) +import Control.Monad.Writer + import Data.Function (on) import Data.List (minimumBy, sortBy, groupBy) import Data.Maybe (maybeToList, mapMaybe) import qualified Data.Map as M -import Control.Arrow (Arrow(..)) -import Control.Monad.State -import Control.Monad.Writer -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Supply.Class (MonadSupply(..)) - -import Language.PureScript.Crash import Language.PureScript.AST +import Language.PureScript.Crash import Language.PureScript.Errors import Language.PureScript.Names import Language.PureScript.TypeChecker.Unify @@ -81,13 +79,13 @@ findDicts ctx cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup ctx solve :: Constraint -> StateT Context m (Expr, [(Ident, Constraint)]) - solve (className, tys) = do - (dict, unsolved) <- go 0 className tys + solve con = do + (dict, unsolved) <- go 0 con return (dictionaryValueToValue dict, unsolved) where - go :: Int -> Qualified (ProperName 'ClassName) -> [Type] -> StateT Context m (DictionaryValue, [(Ident, Constraint)]) - go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys' - go work className' tys' = do + go :: Int -> Constraint -> StateT Context m (DictionaryValue, [(Ident, Constraint)]) + go work (Constraint className' tys' _) | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys' + go work con'@(Constraint className' tys' _) = do -- Get the inferred constraint context so far, and merge it with the global context inferred <- get let instances = do @@ -104,7 +102,7 @@ (mkDictionary (tcdName tcd) args) (tcdPath tcd) return (match, unsolved) - Right unsolved@(unsolvedClassName@(Qualified _ pn), unsolvedTys) -> do + Right unsolved@(Constraint unsolvedClassName@(Qualified _ pn) unsolvedTys _) -> do -- Generate a fresh name for the unsolved constraint's new dictionary ident <- freshIdent ("dict" ++ runProperName pn) let qident = Qualified Nothing ident @@ -117,8 +115,8 @@ where unique :: [(a, TypeClassDictionaryInScope)] -> m (Either (a, TypeClassDictionaryInScope) Constraint) - unique [] | shouldGeneralize && all canBeGeneralized tys' = return $ Right (className, tys) - | otherwise = throwError . errorMessage $ NoInstanceFound className' tys' + unique [] | shouldGeneralize && all canBeGeneralized tys' = return (Right con') + | otherwise = throwError . errorMessage $ NoInstanceFound con' unique [a] = return $ Left a unique tcds | pairwise overlapping (map snd tcds) = do tell . errorMessage $ OverlappingInstances className' tys' (map (tcdName . snd) tcds) @@ -148,7 +146,7 @@ solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> StateT Context m (Maybe [DictionaryValue], [(Ident, Constraint)]) solveSubgoals _ Nothing = return (Nothing, []) solveSubgoals subst (Just subgoals) = do - zipped <- traverse (uncurry (go (work + 1)) . second (map (replaceAllTypeVars subst))) subgoals + zipped <- traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars subst))) subgoals let (dicts, unsolved) = unzip zipped return (Just dicts, concat unsolved) @@ -186,6 +184,7 @@ typeHeadsAreEqual _ (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = Just [] typeHeadsAreEqual _ t (TypeVar v) = Just [(v, t)] typeHeadsAreEqual _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just [] +typeHeadsAreEqual _ (TypeLevelString s1) (TypeLevelString s2) | s1 == s2 = Just [] typeHeadsAreEqual m (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m h1 h2 <*> typeHeadsAreEqual m t1 t2 typeHeadsAreEqual _ REmpty REmpty = Just [] diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -1,9 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} -- | -- This module implements the kind checker @@ -15,17 +10,16 @@ , kindsOfAll ) where -import Prelude () import Prelude.Compat -import qualified Data.Map as M - import Control.Arrow (second) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.State +import Control.Monad.Writer.Class (MonadWriter(..)) +import qualified Data.Map as M + import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors @@ -93,6 +87,7 @@ go k (KUnknown u) = solveKind u k go Star Star = return () go Bang Bang = return () + go Symbol Symbol = return () go (Row k1') (Row k2') = go k1' k2' go (FunKind k1' k2') (FunKind k3 k4) = do go k1' k3 @@ -235,7 +230,8 @@ k' <- go ty unifyKinds k k' return k' - go TypeWildcard = freshKind + go TypeWildcard{} = freshKind + go (TypeLevelString _) = return Symbol go (TypeVar v) = do Just moduleName <- checkCurrentModule <$> get lookupTypeVariable moduleName (Qualified Nothing (ProperName v)) @@ -245,7 +241,7 @@ go (TypeConstructor v) = do env <- getEnv case M.lookup v (types env) of - Nothing -> throwError . errorMessage $ UnknownTypeConstructor v + Nothing -> throwError . errorMessage . UnknownName $ fmap TyName v Just (kind, _) -> return kind go (TypeApp t1 t2) = do k0 <- freshKind @@ -262,7 +258,7 @@ unifyKinds k2 (Row k1) return $ Row k1 go (ConstrainedType deps ty) = do - forM_ deps $ \(className, tys) -> do + forM_ deps $ \(Constraint className tys _) -> do k <- go $ foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys unifyKinds k Star k <- go ty diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -1,7 +1,4 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -- | @@ -9,16 +6,15 @@ -- module Language.PureScript.TypeChecker.Monad where -import Prelude () import Prelude.Compat -import Data.Maybe -import qualified Data.Map as M - import Control.Arrow (second) -import Control.Monad.State import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.State import Control.Monad.Writer.Class (MonadWriter(..), listen, censor) + +import Data.Maybe +import qualified Data.Map as M import Language.PureScript.Environment import Language.PureScript.Errors diff --git a/src/Language/PureScript/TypeChecker/Rows.hs b/src/Language/PureScript/TypeChecker/Rows.hs --- a/src/Language/PureScript/TypeChecker/Rows.hs +++ b/src/Language/PureScript/TypeChecker/Rows.hs @@ -1,35 +1,18 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.TypeChecker.Rows --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- Functions relating to type checking for rows -- ------------------------------------------------------------------------------ - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} - -module Language.PureScript.TypeChecker.Rows ( - checkDuplicateLabels -) where +module Language.PureScript.TypeChecker.Rows + ( checkDuplicateLabels + ) where -import Data.List +import Prelude.Compat -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..)) +import Data.List + import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.TypeChecker.Monad @@ -54,7 +37,7 @@ checkDups (TypeApp t1 t2) = checkDups t1 >> checkDups t2 checkDups (ForAll _ t _) = checkDups t checkDups (ConstrainedType args t) = do - mapM_ checkDups $ concatMap snd args + mapM_ checkDups $ concatMap constraintArgs args checkDups t checkDups r@RCons{} = let (ls, _) = rowToList r in diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -1,45 +1,30 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.TypeChecker.Skolems --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- Functions relating to skolemization used during typechecking -- ------------------------------------------------------------------------------ - -{-# LANGUAGE FlexibleContexts #-} - -module Language.PureScript.TypeChecker.Skolems ( - newSkolemConstant, - introduceSkolemScope, - newSkolemScope, - skolemize, - skolemizeTypesInValue, - skolemEscapeCheck -) where +module Language.PureScript.TypeChecker.Skolems + ( newSkolemConstant + , introduceSkolemScope + , newSkolemScope + , skolemize + , skolemizeTypesInValue + , skolemEscapeCheck + ) where -import Prelude () import Prelude.Compat -import Data.List (nub, (\\)) -import Data.Monoid -import Data.Functor.Identity (Identity(), runIdentity) - import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), gets, modify) -import Language.PureScript.Crash +import Data.Functor.Identity (Identity(), runIdentity) +import Data.List (nub, (\\)) +import Data.Monoid + import Language.PureScript.AST +import Language.PureScript.Crash import Language.PureScript.Errors +import Language.PureScript.Traversals (defS) import Language.PureScript.TypeChecker.Monad import Language.PureScript.Types -import Language.PureScript.Traversals (defS) -- | -- Generate a new skolem constant diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -1,36 +1,20 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.TypeChecker.Subsumption --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- Subsumption checking -- ------------------------------------------------------------------------------ +module Language.PureScript.TypeChecker.Subsumption + ( subsumes + ) where -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} +import Prelude.Compat -module Language.PureScript.TypeChecker.Subsumption ( - subsumes -) where +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.State.Class (MonadState(..)) import Data.List (sortBy) import Data.Ord (comparing) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.State.Class (MonadState(..)) - -import Language.PureScript.Crash import Language.PureScript.AST +import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.TypeChecker.Monad @@ -69,7 +53,7 @@ subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do dicts <- getTypeClassDictionaries subsumes' (Just $ foldl App val (map (flip TypeClassDictionary dicts) constraints)) ty1 ty2 -subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyObject && f2 == tyObject = do +subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyRecord && f2 == tyRecord = do let (ts1, r1') = rowToList r1 (ts2, r2') = rowToList r2 @@ -96,7 +80,7 @@ REmpty -> throwError . errorMessage $ PropertyIsMissing p2 _ -> unifyTypes r1' (RCons p2 ty2 rest) go ((p1, ty1) : ts1) ts2 rest r2' -subsumes' val ty1 ty2@(TypeApp obj _) | obj == tyObject = subsumes val ty2 ty1 +subsumes' val ty1 ty2@(TypeApp obj _) | obj == tyRecord = subsumes val ty2 ty1 subsumes' val ty1 ty2 = do unifyTypes ty1 ty2 return val diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs --- a/src/Language/PureScript/TypeChecker/Synonyms.hs +++ b/src/Language/PureScript/TypeChecker/Synonyms.hs @@ -1,35 +1,19 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.TypeChecker.Synonyms --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- +{-# LANGUAGE GADTs #-} + -- | -- Functions for replacing fully applied type synonyms -- ------------------------------------------------------------------------------ - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE GADTs #-} - -module Language.PureScript.TypeChecker.Synonyms ( - replaceAllTypeSynonyms -) where +module Language.PureScript.TypeChecker.Synonyms + ( replaceAllTypeSynonyms + ) where -import Prelude () import Prelude.Compat -import Data.Maybe (fromMaybe) -import qualified Data.Map as M - import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State + +import Data.Maybe (fromMaybe) +import qualified Data.Map as M import Language.PureScript.Environment import Language.PureScript.Errors diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -1,8 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -- | -- This module implements the type checker @@ -28,22 +24,22 @@ Check a function of a given type returns a value of another type when applied to its arguments -} -import Prelude () import Prelude.Compat -import Data.Either (lefts, rights) -import Data.List (transpose, nub, (\\), partition, delete) -import Data.Maybe (fromMaybe) -import qualified Data.Map as M - +import Control.Arrow (second) import Control.Monad +import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), gets) import Control.Monad.Supply.Class (MonadSupply) -import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class (MonadWriter(..)) -import Language.PureScript.Crash +import Data.Either (lefts, rights) +import Data.List (transpose, nub, (\\), partition, delete) +import Data.Maybe (fromMaybe) +import qualified Data.Map as M + import Language.PureScript.AST +import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Kinds @@ -98,10 +94,10 @@ $ CannotGeneralizeRecursiveFunction ident generalized -- Make sure any unsolved type constraints only use type variables which appear -- unknown in the inferred type. - forM_ unsolved $ \(_, (className, classTys)) -> do - let constraintTypeVars = nub $ foldMap unknownsInType classTys + forM_ unsolved $ \(_, con) -> do + let constraintTypeVars = nub $ foldMap unknownsInType (constraintArgs con) when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $ - throwError . errorMessage $ NoInstanceFound className classTys + throwError . errorMessage $ NoInstanceFound con -- Check skolem variables did not escape their scope skolemEscapeCheck val' @@ -123,8 +119,9 @@ -- Replace all the wildcards types with their inferred types replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints . WildcardInferredType $ substituteType sub ty - replace sub (ErrorMessage hints (HoleInferredType name ty)) = - ErrorMessage hints . HoleInferredType name $ substituteType sub ty + replace sub (ErrorMessage hints (HoleInferredType name ty env)) = + ErrorMessage hints $ HoleInferredType name (substituteType sub ty) + (map (second (substituteType sub)) env) replace _ em = em isHoleError :: ErrorMessage -> Bool @@ -204,7 +201,7 @@ where g :: Expr -> Expr g (TypedValue checkTy val t) = TypedValue checkTy val (f t) - g (TypeClassDictionary (nm, tys) sco) = TypeClassDictionary (nm, map f tys) sco + g (TypeClassDictionary c sco) = TypeClassDictionary (mapConstraintArgs (map f) c) sco g other = other -- | Check the kind of a type, failing if it is not of kind *. @@ -259,7 +256,7 @@ ensureNoDuplicateProperties ps ts <- traverse (infer . snd) ps let fields = zipWith (\name (TypedValue _ _ t) -> (name, t)) (map fst ps) ts - ty = TypeApp tyObject $ rowFromList (fields, REmpty) + ty = TypeApp tyRecord $ rowFromList (fields, REmpty) return $ TypedValue True (Literal (ObjectLiteral (zip (map fst ps) ts))) ty infer' (ObjectUpdate o ps) = do ensureNoDuplicateProperties ps @@ -267,13 +264,13 @@ newVals <- zipWith (\(name, _) t -> (name, t)) ps <$> traverse (infer . snd) ps let newTys = map (\(name, TypedValue _ _ ty) -> (name, ty)) newVals oldTys <- zip (map fst ps) <$> replicateM (length ps) freshType - let oldTy = TypeApp tyObject $ rowFromList (oldTys, row) + let oldTy = TypeApp tyRecord $ rowFromList (oldTys, row) o' <- TypedValue True <$> check o oldTy <*> pure oldTy - return $ TypedValue True (ObjectUpdate o' newVals) $ TypeApp tyObject $ rowFromList (newTys, row) + return $ TypedValue True (ObjectUpdate o' newVals) $ TypeApp tyRecord $ rowFromList (newTys, row) infer' (Accessor prop val) = rethrow (addHint (ErrorCheckingAccessor val prop)) $ do field <- freshType rest <- freshType - typed <- check val (TypeApp tyObject (RCons prop field rest)) + typed <- check val (TypeApp tyRecord (RCons prop field rest)) return $ TypedValue True (Accessor prop typed) field infer' (Abs (Left arg) ret) = do ty <- freshType @@ -298,7 +295,7 @@ infer' v@(Constructor c) = do env <- getEnv case M.lookup c (dataConstructors env) of - Nothing -> throwError . errorMessage $ UnknownDataConstructor c Nothing + Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c Just (_, _, ty, _) -> do (v', ty') <- sndM (introduceSkolemScope <=< replaceAllTypeSynonyms) <=< instantiatePolyTypeWithUnknowns v $ ty return $ TypedValue True v' ty' infer' (Case vals binders) = do @@ -319,7 +316,7 @@ return $ TypedValue True (Let ds' val') valTy infer' (SuperClassDictionary className tys) = do dicts <- getTypeClassDictionaries - return $ TypeClassDictionary (className, tys) dicts + return $ TypeClassDictionary (Constraint className tys Nothing) dicts infer' (TypedValue checkType val ty) = do Just moduleName <- checkCurrentModule <$> get (kind, args) <- kindOfWithScopedVars ty @@ -329,7 +326,10 @@ return $ TypedValue True val' ty' infer' (Hole name) = do ty <- freshType - tell . errorMessage $ HoleInferredType name ty + env <- M.toList . names <$> getEnv + Just moduleName <- checkCurrentModule <$> get + let ctx = [ (ident, ty') | ((mn, ident@Ident{}), (ty', _, Defined)) <- env, mn == moduleName ] + tell . errorMessage $ HoleInferredType name ty ctx return $ TypedValue True (Hole name) ty infer' (PositionedValue pos c val) = warnAndRethrowWithPosition pos $ do TypedValue t v ty <- infer' val @@ -396,7 +396,7 @@ unless (length args == length binders) . throwError . errorMessage $ IncorrectConstructorArity ctor unifyTypes ret val M.unions <$> zipWithM inferBinder (reverse args) binders - _ -> throwError . errorMessage $ UnknownDataConstructor ctor Nothing + _ -> throwError . errorMessage . UnknownName . fmap DctorName $ ctor where peelArgs :: Type -> ([Type], Type) peelArgs = go [] @@ -407,7 +407,7 @@ row <- freshType rest <- freshType m1 <- inferRowProperties row rest props - unifyTypes val (TypeApp tyObject row) + unifyTypes val (TypeApp tyRecord row) return m1 where inferRowProperties :: Type -> Type -> [(String, Binder)] -> m (M.Map Ident Type) @@ -527,7 +527,7 @@ val' <- check skVal sk return $ TypedValue True val' (ForAll ident ty (Just scope)) check' val t@(ConstrainedType constraints ty) = do - dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> + dictNames <- forM constraints $ \(Constraint (Qualified _ (ProperName className)) _ _) -> freshIdent ("dict" ++ className) dicts <- join <$> zipWithM (newDictionaries []) (map (Qualified Nothing) dictNames) constraints val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty @@ -538,15 +538,15 @@ newDictionaries :: [(Qualified (ProperName 'ClassName), Integer)] -> Qualified Ident - -> (Qualified (ProperName 'ClassName), [Type]) + -> Constraint -> m [TypeClassDictionaryInScope] - newDictionaries path name (className, instanceTy) = do + newDictionaries path name (Constraint className instanceTy _) = do tcs <- gets (typeClasses . checkEnv) let (args, _, superclasses) = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs - supDicts <- join <$> zipWithM (\(supName, supArgs) index -> + supDicts <- join <$> zipWithM (\(Constraint supName supArgs _) index -> newDictionaries ((supName, index) : path) name - (supName, instantiateSuperclass (map fst args) supArgs instanceTy) + (Constraint supName (instantiateSuperclass (map fst args) supArgs instanceTy) Nothing) ) superclasses [0..] return (TypeClassDictionaryInScope name path className instanceTy Nothing : supDicts) @@ -599,7 +599,7 @@ -- declaration gets desugared. -} dicts <- getTypeClassDictionaries - return $ TypeClassDictionary (className, tys) dicts + return $ TypeClassDictionary (Constraint className tys Nothing) dicts check' (TypedValue checkType val ty1) ty2 = do Just moduleName <- checkCurrentModule <$> get (kind, args) <- kindOfWithScopedVars ty1 @@ -621,31 +621,31 @@ th' <- check th ty el' <- check el ty return $ TypedValue True (IfThenElse cond' th' el') ty -check' e@(Literal (ObjectLiteral ps)) t@(TypeApp obj row) | obj == tyObject = do +check' e@(Literal (ObjectLiteral ps)) t@(TypeApp obj row) | obj == tyRecord = do ensureNoDuplicateProperties ps ps' <- checkProperties e ps row False return $ TypedValue True (Literal (ObjectLiteral ps')) t check' (TypeClassDictionaryConstructorApp name ps) t = do ps' <- check' ps t return $ TypedValue True (TypeClassDictionaryConstructorApp name ps') t -check' e@(ObjectUpdate obj ps) t@(TypeApp o row) | o == tyObject = do +check' e@(ObjectUpdate obj ps) t@(TypeApp o row) | o == tyRecord = do ensureNoDuplicateProperties ps -- We need to be careful to avoid duplicate labels here. -- We check _obj_ against the type _t_ with the types in _ps_ replaced with unknowns. let (propsToCheck, rest) = rowToList row (removedProps, remainingProps) = partition (\(p, _) -> p `elem` map fst ps) propsToCheck us <- zip (map fst removedProps) <$> replicateM (length ps) freshType - obj' <- check obj (TypeApp tyObject (rowFromList (us ++ remainingProps, rest))) + obj' <- check obj (TypeApp tyRecord (rowFromList (us ++ remainingProps, rest))) ps' <- checkProperties e ps row True return $ TypedValue True (ObjectUpdate obj' ps') t check' (Accessor prop val) ty = rethrow (addHint (ErrorCheckingAccessor val prop)) $ do rest <- freshType - val' <- check val (TypeApp tyObject (RCons prop ty rest)) + val' <- check val (TypeApp tyRecord (RCons prop ty rest)) return $ TypedValue True (Accessor prop val') ty check' v@(Constructor c) ty = do env <- getEnv case M.lookup c (dataConstructors env) of - Nothing -> throwError . errorMessage $ UnknownDataConstructor c Nothing + Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c Just (_, _, ty1, _) -> do repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1 mv <- subsumes (Just v) repl ty @@ -703,7 +703,7 @@ v' <- check v ty ps'' <- go ps' (delete (p, ty) ts) r return $ (p, v') : ps'' - go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType expr (TypeApp tyObject row) + go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType expr (TypeApp tyRecord row) -- | Check the type of a function application, rethrowing errors to provide a better error message checkFunctionApplication :: diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -1,48 +1,31 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.TypeChecker.Unify --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- +{-# LANGUAGE FlexibleInstances #-} + -- | -- Functions and instances relating to unification -- ------------------------------------------------------------------------------ - -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} - -module Language.PureScript.TypeChecker.Unify ( - freshType, - solveType, - substituteType, - unknownsInType, - unifyTypes, - unifyRows, - unifiesWith, - replaceVarWithUnknown, - replaceTypeWildcards, - varIfUnknown -) where +module Language.PureScript.TypeChecker.Unify + ( freshType + , solveType + , substituteType + , unknownsInType + , unifyTypes + , unifyRows + , unifiesWith + , replaceVarWithUnknown + , replaceTypeWildcards + , varIfUnknown + ) where -import Data.List (nub, sort) -import qualified Data.Map as M +import Prelude.Compat -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.State.Class (MonadState(..), gets, modify) +import Control.Monad.Writer.Class (MonadWriter(..)) +import Data.List (nub, sort) +import qualified Data.Map as M + import Language.PureScript.Crash import Language.PureScript.Errors import Language.PureScript.TypeChecker.Monad @@ -170,13 +153,14 @@ -- Check that two types unify -- unifiesWith :: Type -> Type -> Bool -unifiesWith (TUnknown u1) (TUnknown u2) | u1 == u2 = True -unifiesWith (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = True -unifiesWith (TypeVar v1) (TypeVar v2) | v1 == v2 = True -unifiesWith (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = True -unifiesWith (TypeApp h1 t1) (TypeApp h2 t2) = h1 `unifiesWith` h2 && t1 `unifiesWith` t2 -unifiesWith REmpty REmpty = True -unifiesWith r1@RCons{} r2@RCons{} = +unifiesWith (TUnknown u1) (TUnknown u2) = u1 == u2 +unifiesWith (Skolem _ s1 _ _) (Skolem _ s2 _ _) = s1 == s2 +unifiesWith (TypeVar v1) (TypeVar v2) = v1 == v2 +unifiesWith (TypeLevelString s1) (TypeLevelString s2) = s1 == s2 +unifiesWith (TypeConstructor c1) (TypeConstructor c2) = c1 == c2 +unifiesWith (TypeApp h1 t1) (TypeApp h2 t2) = h1 `unifiesWith` h2 && t1 `unifiesWith` t2 +unifiesWith REmpty REmpty = True +unifiesWith r1@RCons{} r2@RCons{} = let (s1, r1') = rowToList r1 (s2, r2') = rowToList r2 @@ -209,9 +193,9 @@ replaceTypeWildcards :: (MonadWriter MultipleErrors m, MonadState CheckState m) => Type -> m Type replaceTypeWildcards = everywhereOnTypesM replace where - replace TypeWildcard = do + replace (TypeWildcard ss) = do t <- freshType - tell . errorMessage $ WildcardInferredType t + warnWithPosition ss $ tell . errorMessage $ WildcardInferredType t return t replace other = return other diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs --- a/src/Language/PureScript/TypeClassDictionaries.hs +++ b/src/Language/PureScript/TypeClassDictionaries.hs @@ -1,5 +1,7 @@ module Language.PureScript.TypeClassDictionaries where +import Prelude.Compat + import Language.PureScript.Names import Language.PureScript.Types diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -6,21 +6,18 @@ -- module Language.PureScript.Types where -import Prelude () import Prelude.Compat +import Control.Monad ((<=<)) + import Data.List (nub) import Data.Maybe (fromMaybe) import qualified Data.Aeson as A import qualified Data.Aeson.TH as A -import Control.Arrow (second) -import Control.Monad ((<=<)) - -import Language.PureScript.Names -import Language.PureScript.Kinds -import Language.PureScript.Traversals import Language.PureScript.AST.SourcePos +import Language.PureScript.Kinds +import Language.PureScript.Names -- | -- An identifier for the scope of a skolem variable @@ -32,89 +29,79 @@ -- The type of types -- data Type - -- | - -- A unification variable of type Type - -- + -- | A unification variable of type Type = TUnknown Int - -- | - -- A named type variable - -- + -- | A named type variable | TypeVar String - -- | - -- A type wildcard, as would appear in a partial type synonym - -- - | TypeWildcard - -- | - -- A type constructor - -- + -- | A type-level string + | TypeLevelString String + -- | A type wildcard, as would appear in a partial type synonym + | TypeWildcard SourceSpan + -- | A type constructor | TypeConstructor (Qualified (ProperName 'TypeName)) - -- | - -- A type operator. This will be desugared into a type constructor during the + -- | A type operator. This will be desugared into a type constructor during the -- "operators" phase of desugaring. - -- - | TypeOp (Qualified Ident) - -- | - -- A type application - -- + | TypeOp (Qualified (OpName 'TypeOpName)) + -- | A type application | TypeApp Type Type - -- | - -- Forall quantifier - -- + -- | Forall quantifier | ForAll String Type (Maybe SkolemScope) - -- | - -- A type with a set of type class constraints - -- + -- | A type with a set of type class constraints | ConstrainedType [Constraint] Type - -- | - -- A skolem constant - -- + -- | A skolem constant | Skolem String Int SkolemScope (Maybe SourceSpan) - -- | - -- An empty row - -- + -- | An empty row | REmpty - -- | - -- A non-empty row - -- + -- | A non-empty row | RCons String Type Type - -- | - -- A type with a kind annotation - -- + -- | A type with a kind annotation | KindedType Type Kind - -- - -- | - -- A placeholder used in pretty printing - -- + -- | A placeholder used in pretty printing | PrettyPrintFunction Type Type - -- | - -- A placeholder used in pretty printing - -- + -- | A placeholder used in pretty printing | PrettyPrintObject Type - -- | - -- A placeholder used in pretty printing - -- + -- | A placeholder used in pretty printing | PrettyPrintForAll [String] Type - -- | - -- Binary operator application. During the rebracketing phase of desugaring, + -- | Binary operator application. During the rebracketing phase of desugaring, -- this data constructor will be removed. - -- | BinaryNoParensType Type Type Type - -- | - -- Explicit parentheses. During the rebracketing phase of desugaring, this + -- | Explicit parentheses. During the rebracketing phase of desugaring, this -- data constructor will be removed. -- -- Note: although it seems this constructor is not used, it _is_ useful, -- since it prevents certain traversals from matching. - -- | ParensInType Type deriving (Show, Read, Eq, Ord) --- | --- A typeclass constraint --- -type Constraint = (Qualified (ProperName 'ClassName), [Type]) +-- | Additional data relevant to type class constraints +data ConstraintData + = PartialConstraintData [[String]] Bool + -- ^ Data to accompany a Partial constraint generated by the exhaustivity checker. + -- It contains (rendered) binder information for those binders which were + -- not matched, and a flag indicating whether the list was truncated or not. + -- Note: we use 'String' here because using 'Binder' would introduce a cyclic + -- dependency in the module graph. + deriving (Show, Read, Eq, Ord) +-- | A typeclass constraint +data Constraint = Constraint + { constraintClass :: Qualified (ProperName 'ClassName) + -- ^ constraint class name + , constraintArgs :: [Type] + -- ^ type arguments + , constraintData :: Maybe ConstraintData + -- ^ additional data relevant to this constraint + } deriving (Show, Read, Eq, Ord) + +mapConstraintArgs :: ([Type] -> [Type]) -> Constraint -> Constraint +mapConstraintArgs f c = c { constraintArgs = f (constraintArgs c) } + +overConstraintArgs :: Functor f => ([Type] -> f [Type]) -> Constraint -> f Constraint +overConstraintArgs f c = (\args -> c { constraintArgs = args }) <$> f (constraintArgs c) + $(A.deriveJSON A.defaultOptions ''Type) +$(A.deriveJSON A.defaultOptions ''Constraint) +$(A.deriveJSON A.defaultOptions ''ConstraintData) -- | -- Convert a row to a list of pairs of labels and types @@ -169,7 +156,7 @@ where keys = map fst m usedVars = concatMap (usedTypeVariables . snd) m - go bs m (ConstrainedType cs t) = ConstrainedType (map (second $ map (go bs m)) cs) (go bs m t) + go bs m (ConstrainedType cs t) = ConstrainedType (map (mapConstraintArgs (map (go bs m))) cs) (go bs m t) go bs m (RCons name' t r) = RCons name' (go bs m t) (go bs m r) go bs m (KindedType t k) = KindedType (go bs m t) k go bs m (BinaryNoParensType t1 t2 t3) = BinaryNoParensType (go bs m t1) (go bs m t2) (go bs m t3) @@ -201,7 +188,7 @@ go bound (TypeVar v) | v `notElem` bound = [v] go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2 go bound (ForAll v t _) = go (v : bound) t - go bound (ConstrainedType cs t) = concatMap (concatMap (go bound) . snd) cs ++ go bound t + go bound (ConstrainedType cs t) = concatMap (concatMap (go bound) . constraintArgs) cs ++ go bound t go bound (RCons _ t r) = go bound t ++ go bound r go bound (KindedType t _) = go bound t go bound (BinaryNoParensType t1 t2 t3) = go bound t1 ++ go bound t2 ++ go bound t3 @@ -237,7 +224,7 @@ containsWildcards = everythingOnTypes (||) go where go :: Type -> Bool - go TypeWildcard = True + go TypeWildcard{} = True go _ = False -- @@ -249,7 +236,7 @@ where go (TypeApp t1 t2) = f (TypeApp (go t1) (go t2)) go (ForAll arg ty sco) = f (ForAll arg (go ty) sco) - go (ConstrainedType cs ty) = f (ConstrainedType (map (fmap (map go)) cs) (go ty)) + go (ConstrainedType cs ty) = f (ConstrainedType (map (mapConstraintArgs (map go)) cs) (go ty)) go (RCons name ty rest) = f (RCons name (go ty) (go rest)) go (KindedType ty k) = f (KindedType (go ty) k) go (PrettyPrintFunction t1 t2) = f (PrettyPrintFunction (go t1) (go t2)) @@ -264,7 +251,7 @@ where go (TypeApp t1 t2) = TypeApp (go (f t1)) (go (f t2)) go (ForAll arg ty sco) = ForAll arg (go (f ty)) sco - go (ConstrainedType cs ty) = ConstrainedType (map (fmap (map (go . f))) cs) (go (f ty)) + go (ConstrainedType cs ty) = ConstrainedType (map (mapConstraintArgs (map (go . f))) cs) (go (f ty)) go (RCons name ty rest) = RCons name (go (f ty)) (go (f rest)) go (KindedType ty k) = KindedType (go (f ty)) k go (PrettyPrintFunction t1 t2) = PrettyPrintFunction (go (f t1)) (go (f t2)) @@ -279,7 +266,7 @@ where go (TypeApp t1 t2) = (TypeApp <$> go t1 <*> go t2) >>= f go (ForAll arg ty sco) = (ForAll arg <$> go ty <*> pure sco) >>= f - go (ConstrainedType cs ty) = (ConstrainedType <$> mapM (sndM (mapM go)) cs <*> go ty) >>= f + go (ConstrainedType cs ty) = (ConstrainedType <$> mapM (overConstraintArgs (mapM go)) cs <*> go ty) >>= f go (RCons name ty rest) = (RCons name <$> go ty <*> go rest) >>= f go (KindedType ty k) = (KindedType <$> go ty <*> pure k) >>= f go (PrettyPrintFunction t1 t2) = (PrettyPrintFunction <$> go t1 <*> go t2) >>= f @@ -294,7 +281,7 @@ where go (TypeApp t1 t2) = TypeApp <$> (f t1 >>= go) <*> (f t2 >>= go) go (ForAll arg ty sco) = ForAll arg <$> (f ty >>= go) <*> pure sco - go (ConstrainedType cs ty) = ConstrainedType <$> mapM (sndM (mapM (go <=< f))) cs <*> (f ty >>= go) + go (ConstrainedType cs ty) = ConstrainedType <$> mapM (overConstraintArgs (mapM (go <=< f))) cs <*> (f ty >>= go) go (RCons name ty rest) = RCons name <$> (f ty >>= go) <*> (f rest >>= go) go (KindedType ty k) = KindedType <$> (f ty >>= go) <*> pure k go (PrettyPrintFunction t1 t2) = PrettyPrintFunction <$> (f t1 >>= go) <*> (f t2 >>= go) @@ -309,7 +296,7 @@ where go t@(TypeApp t1 t2) = f t <> go t1 <> go t2 go t@(ForAll _ ty _) = f t <> go ty - go t@(ConstrainedType cs ty) = foldl (<>) (f t) (map go $ concatMap snd cs) <> go ty + go t@(ConstrainedType cs ty) = foldl (<>) (f t) (map go $ concatMap constraintArgs cs) <> go ty go t@(RCons _ ty rest) = f t <> go ty <> go rest go t@(KindedType ty _) = f t <> go ty go t@(PrettyPrintFunction t1 t2) = f t <> go t1 <> go t2 @@ -325,7 +312,7 @@ go' s t = let (s', r) = f s t in r <> go s' t go s (TypeApp t1 t2) = go' s t1 <> go' s t2 go s (ForAll _ ty _) = go' s ty - go s (ConstrainedType cs ty) = foldl (<>) r0 (map (go' s) $ concatMap snd cs) <> go' s ty + go s (ConstrainedType cs ty) = foldl (<>) r0 (map (go' s) $ concatMap constraintArgs cs) <> go' s ty go s (RCons _ ty rest) = go' s ty <> go' s rest go s (KindedType ty _) = go' s ty go s (PrettyPrintFunction t1 t2) = go' s t1 <> go' s t2 diff --git a/src/System/IO/UTF8.hs b/src/System/IO/UTF8.hs --- a/src/System/IO/UTF8.hs +++ b/src/System/IO/UTF8.hs @@ -1,6 +1,6 @@ -module System.IO.UTF8 +module System.IO.UTF8 where -where +import Prelude.Compat import System.IO ( IOMode(..) , hGetContents diff --git a/stack-lts-5.yaml b/stack-lts-5.yaml deleted file mode 100644 --- a/stack-lts-5.yaml +++ /dev/null @@ -1,7 +0,0 @@ -resolver: lts-5.4 -packages: -- '.' -extra-deps: -- bower-json-0.8.0 -- language-javascript-0.6.0.4 -flags: {} diff --git a/stack-nightly.yaml b/stack-nightly.yaml deleted file mode 100644 --- a/stack-nightly.yaml +++ /dev/null @@ -1,6 +0,0 @@ -flags: {} -packages: -- '.' -extra-deps: -- language-javascript-0.6.0.4 -resolver: nightly-2016-03-17 diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -4,4 +4,5 @@ extra-deps: - bower-json-0.8.0 - language-javascript-0.6.0.4 +- parsec-3.1.11 flags: {} diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs --- a/tests/Language/PureScript/Ide/FilterSpec.hs +++ b/tests/Language/PureScript/Ide/FilterSpec.hs @@ -8,7 +8,7 @@ import Test.Hspec value :: Text -> ExternDecl -value s = ValueDeclaration s P.TypeWildcard +value s = ValueDeclaration s $ P.TypeWildcard $ P.SourceSpan "" (P.SourcePos 0 0) (P.SourcePos 0 0) modules :: [Module] modules = diff --git a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs --- a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs +++ b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Ide.Imports.IntegrationSpec where -import Control.Monad +import Control.Monad (void) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as TIO @@ -13,16 +13,9 @@ setup :: IO () setup = do - Integration.deleteOutputFolder - s <- Integration.compileTestProject - unless s $ fail "Failed to compile .purs sources" - Integration.quitServer -- kill a eventually running psc-ide-server instance - _ <- Integration.startServer + Integration.reset mapM_ Integration.loadModuleWithDeps ["ImportsSpec", "ImportsSpec1"] -teardown :: IO () -teardown = Integration.quitServer - withSupportFiles :: (FilePath -> FilePath -> IO a) -> IO () withSupportFiles test = do pdir <- Integration.projectDirectory @@ -38,15 +31,15 @@ shouldBe (T.lines outRes) expectation spec :: Spec -spec = beforeAll_ setup $ afterAll_ teardown $ describe "Adding imports" $ do +spec = beforeAll_ setup . describe "Adding imports" $ do let sourceFileSkeleton :: [Text] -> [Text] sourceFileSkeleton importSection = [ "module ImportsSpec where" , ""] ++ importSection ++ [ "" , "myId = id"] it "adds an implicit import" $ do - withSupportFiles (Integration.addImplicitImport "Prelude") + withSupportFiles (Integration.addImplicitImport "ImportsSpec1") outputFileShouldBe (sourceFileSkeleton - [ "import Prelude" + [ "import ImportsSpec1" , "import Main (id)" ]) it "adds an explicit unqualified import" $ do diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -36,6 +36,9 @@ consoleImport = testParseImport "import Control.Monad.Eff.Console (log) as Console" maybeImport = testParseImport "import Data.Maybe (Maybe(Just))" +wildcard :: P.Type +wildcard = P.TypeWildcard $ P.SourceSpan "" (P.SourcePos 0 0) (P.SourcePos 0 0) + spec :: Spec spec = do describe "determining the importsection" $ do @@ -65,9 +68,11 @@ describe "import commands" $ do let simpleFileImports = let (_, _, i, _) = splitSimpleFile in i addValueImport i mn is = - prettyPrintImportSection (addExplicitImport' (ValueDeclaration i P.TypeWildcard) mn is) + prettyPrintImportSection (addExplicitImport' (ValueDeclaration i wildcard) mn is) + addOpImport op mn is = + prettyPrintImportSection (addExplicitImport' (ValueOperator op "" 2 P.Infix) mn is) addDtorImport i t mn is = - prettyPrintImportSection (addExplicitImport' (DataConstructor i t P.TypeWildcard) mn is) + prettyPrintImportSection (addExplicitImport' (DataConstructor i t wildcard) mn is) it "adds an implicit unqualified import" $ shouldBe (addImplicitImport' simpleFileImports (P.moduleNameFromString "Data.Map")) @@ -93,7 +98,7 @@ ] it "adds an operator to an explicit import list" $ shouldBe - (addValueImport "<~>" (P.moduleNameFromString "Data.Array") explicitImports) + (addOpImport (P.OpName "<~>") (P.moduleNameFromString "Data.Array") explicitImports) [ "import Prelude" , "import Data.Array ((<~>), tail)" ] diff --git a/tests/Language/PureScript/Ide/Integration.hs b/tests/Language/PureScript/Ide/Integration.hs --- a/tests/Language/PureScript/Ide/Integration.hs +++ b/tests/Language/PureScript/Ide/Integration.hs @@ -27,33 +27,37 @@ , projectDirectory , deleteFileIfExists -- sending commands + , addImport + , addImplicitImport , loadModule , loadModuleWithDeps + , getCwd , getFlexCompletions + , getFlexCompletionsInModule , getType - , addImport - , addImplicitImport , rebuildModule + , reset -- checking results , resultIsSuccess , parseCompletions , parseTextResult ) where -import Control.Concurrent (threadDelay) +import Control.Concurrent (threadDelay) import Control.Exception -import Control.Monad (join, when) +import Control.Monad (join, when) import Data.Aeson import Data.Aeson.Types -import qualified Data.ByteString.Lazy.UTF8 as BSL -import Data.Either (isRight) -import Data.Maybe (fromJust) -import qualified Data.Text as T -import qualified Data.Vector as V +import qualified Data.ByteString.Lazy.UTF8 as BSL +import Data.Either (isRight) +import Data.Maybe (fromJust, isNothing, fromMaybe) +import qualified Data.Text as T +import qualified Data.Vector as V import Language.PureScript.Ide.Util import System.Directory import System.Exit import System.FilePath +import System.IO.Error (mkIOError, userErrorType) import System.Process projectDirectory :: IO FilePath @@ -64,7 +68,9 @@ startServer :: IO ProcessHandle startServer = do pdir <- projectDirectory - (_, _, _, procHandle) <- createProcess $ (shell "psc-ide-server") {cwd=Just pdir} + -- Turn off filewatching since it creates race condition in a testing environment + (_, _, _, procHandle) <- createProcess $ + (shell "psc-ide-server --no-watch") {cwd = Just pdir} threadDelay 500000 -- give the server 500ms to start up return procHandle @@ -74,22 +80,39 @@ withServer :: IO a -> IO a withServer s = do _ <- startServer + started <- tryNTimes 5 (shush <$> (try getCwd :: IO (Either SomeException String))) + when (isNothing started) $ + throwIO (mkIOError userErrorType "psc-ide-server didn't start in time" Nothing Nothing) r <- s quitServer - return r + pure r +shush :: Either a b -> Maybe b +shush = either (const Nothing) Just + -- project management utils compileTestProject :: IO Bool compileTestProject = do pdir <- projectDirectory (_, _, _, procHandle) <- createProcess $ - (shell $ "psc " ++ fileGlob) {cwd=Just pdir - ,std_out=CreatePipe - ,std_err=CreatePipe + (shell $ "psc " ++ fileGlob) { cwd = Just pdir + , std_out = CreatePipe + , std_err = CreatePipe } - isSuccess <$> waitForProcess procHandle + r <- tryNTimes 5 (getProcessExitCode procHandle) + pure (fromMaybe False (isSuccess <$> r)) +tryNTimes :: Int -> IO (Maybe a) -> IO (Maybe a) +tryNTimes 0 _ = pure Nothing +tryNTimes n action = do + r <- action + case r of + Nothing -> do + threadDelay 500000 + tryNTimes (n - 1) action + Just a -> pure (Just a) + deleteOutputFolder :: IO () deleteOutputFolder = do odir <- fmap ( "output") projectDirectory @@ -110,9 +133,6 @@ fileGlob :: String fileGlob = unwords [ "\"src/**/*.purs\"" - , "\"src/**/*.js\"" - , "\"bower_components/purescript-*/**/*.purs\"" - , "\"bower_components/purescript-*/**/*.js\"" ] -- Integration Testing API @@ -130,6 +150,17 @@ _ <- try $ sendCommand quitCommand :: IO (Either SomeException String) return () +reset :: IO () +reset = do + let resetCommand = object ["command" .= ("reset" :: String)] + _ <- try $ sendCommand resetCommand :: IO (Either SomeException String) + return () + +getCwd :: IO String +getCwd = do + let cwdCommand = object ["command" .= ("cwd" :: String)] + sendCommand cwdCommand + loadModuleWithDeps :: String -> IO String loadModuleWithDeps m = sendCommand $ load [] [m] @@ -137,8 +168,11 @@ loadModule m = sendCommand $ load [m] [] getFlexCompletions :: String -> IO [(String, String, String)] -getFlexCompletions q = parseCompletions <$> sendCommand (completion [] (Just (flexMatcher q))) +getFlexCompletions q = parseCompletions <$> sendCommand (completion [] (Just (flexMatcher q)) Nothing) +getFlexCompletionsInModule :: String -> String -> IO [(String, String, String)] +getFlexCompletionsInModule q m = parseCompletions <$> sendCommand (completion [] (Just (flexMatcher q)) (Just m)) + getType :: String -> IO [(String, String, String)] getType q = parseCompletions <$> sendCommand (typeC q []) @@ -188,14 +222,17 @@ ]) -completion :: [Value] -> Maybe Value -> Value -completion filters matcher = +completion :: [Value] -> Maybe Value -> Maybe String -> Value +completion filters matcher currentModule = let matcher' = case matcher of Nothing -> [] Just m -> ["matcher" .= m] + currentModule' = case currentModule of + Nothing -> [] + Just cm -> ["currentModule" .= cm] in - commandWrapper "complete" (object $ "filters" .= filters : matcher') + commandWrapper "complete" (object $ "filters" .= filters : matcher' ++ currentModule' ) flexMatcher :: String -> Value flexMatcher q = object [ "matcher" .= ("flex" :: String) diff --git a/tests/Language/PureScript/Ide/MatcherSpec.hs b/tests/Language/PureScript/Ide/MatcherSpec.hs --- a/tests/Language/PureScript/Ide/MatcherSpec.hs +++ b/tests/Language/PureScript/Ide/MatcherSpec.hs @@ -2,21 +2,22 @@ module Language.PureScript.Ide.MatcherSpec where +import Control.Monad (void) import Data.Text (Text) +import qualified Language.PureScript as P import Language.PureScript.Ide.Integration import Language.PureScript.Ide.Matcher import Language.PureScript.Ide.Types -import qualified Language.PureScript as P import Test.Hspec value :: Text -> ExternDecl -value s = ValueDeclaration s P.TypeWildcard +value s = ValueDeclaration s $ P.TypeWildcard $ P.SourceSpan "" (P.SourcePos 0 0) (P.SourcePos 0 0) completions :: [Match] -completions = [ - Match "" $ value "firstResult", - Match "" $ value "secondResult", - Match "" $ value "fiult" +completions = + [ Match "" (value "firstResult") + , Match "" (value "secondResult") + , Match "" (value "fiult") ] mkResult :: [Int] -> [Match] @@ -26,15 +27,7 @@ runFlex s = runMatcher (flexMatcher s) completions setup :: IO () -setup = do - deleteOutputFolder - _ <- compileTestProject - _ <- startServer - _ <- loadModuleWithDeps "Main" - return () - -teardown :: IO () -teardown = quitServer +setup = reset *> void (loadModuleWithDeps "Main") spec :: Spec spec = do @@ -46,8 +39,7 @@ it "scores short matches higher and sorts accordingly" $ runFlex "filt" `shouldBe` mkResult [2, 0] - beforeAll_ setup $ afterAll_ teardown $ - describe "Integration Tests: Flex Matcher" $ do + beforeAll_ setup . describe "Integration Tests: Flex Matcher" $ do it "doesn't match on an empty string" $ do cs <- getFlexCompletions "" cs `shouldBe` [] diff --git a/tests/Language/PureScript/Ide/RebuildSpec.hs b/tests/Language/PureScript/Ide/RebuildSpec.hs --- a/tests/Language/PureScript/Ide/RebuildSpec.hs +++ b/tests/Language/PureScript/Ide/RebuildSpec.hs @@ -1,22 +1,8 @@ module Language.PureScript.Ide.RebuildSpec where -import Control.Monad import qualified Language.PureScript.Ide.Integration as Integration -import Test.Hspec - import System.FilePath - -compile :: IO () -compile = do - Integration.deleteOutputFolder - s <- Integration.compileTestProject - unless s $ fail "Failed to compile .purs sources" - -teardown :: IO () -teardown = Integration.quitServer - -restart :: IO () -restart = Integration.quitServer *> (void Integration.startServer) +import Test.Hspec shouldBeSuccess :: String -> IO () shouldBeSuccess = shouldBe True . Integration.resultIsSuccess @@ -25,8 +11,7 @@ shouldBeFailure = shouldBe False . Integration.resultIsSuccess spec :: Spec -spec = beforeAll_ compile $ afterAll_ teardown $ before_ restart $ do - describe "Rebuilding single modules" $ do +spec = before_ Integration.reset . describe "Rebuilding single modules" $ do it "rebuilds a correct module without dependencies successfully" $ do _ <- Integration.loadModuleWithDeps "RebuildSpecSingleModule" pdir <- Integration.projectDirectory @@ -60,3 +45,9 @@ pdir <- Integration.projectDirectory let file = pdir "src" "RebuildSpecWithMissingForeign.fail" Integration.rebuildModule file >>= shouldBeFailure + it "completes a hidden identifier after rebuilding" $ do + pdir <- Integration.projectDirectory + let file = pdir "src" "RebuildSpecWithHiddenIdent.purs" + Integration.rebuildModule file >>= shouldBeSuccess + res <- Integration.getFlexCompletionsInModule "hid" "RebuildSpecWithHiddenIdent" + shouldBe False (null res) diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs --- a/tests/Language/PureScript/Ide/ReexportsSpec.hs +++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs @@ -9,12 +9,15 @@ import qualified Language.PureScript as P import Test.Hspec +wildcard :: P.Type +wildcard = P.TypeWildcard $ P.SourceSpan "" (P.SourcePos 0 0) (P.SourcePos 0 0) + decl1 :: ExternDecl -decl1 = ValueDeclaration "filter" P.TypeWildcard +decl1 = ValueDeclaration "filter" wildcard decl2 :: ExternDecl -decl2 = ValueDeclaration "map" P.TypeWildcard +decl2 = ValueDeclaration "map" wildcard decl3 :: ExternDecl -decl3 = ValueDeclaration "catMaybe" P.TypeWildcard +decl3 = ValueDeclaration "catMaybe" wildcard dep1 :: ExternDecl dep1 = Dependency "Test.Foo" [] (Just "T") dep2 :: ExternDecl diff --git a/tests/Language/PureScript/IdeSpec.hs b/tests/Language/PureScript/IdeSpec.hs --- a/tests/Language/PureScript/IdeSpec.hs +++ b/tests/Language/PureScript/IdeSpec.hs @@ -11,7 +11,7 @@ import Test.Hspec testState :: PscIdeState -testState = PscIdeState (Map.fromList [("Data.Array", []), ("Control.Monad.Eff", [])]) Map.empty +testState = PscIdeState (Map.fromList [("Data.Array", []), ("Control.Monad.Eff", [])]) Map.empty Nothing defaultConfig :: Configuration defaultConfig = diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -9,10 +9,11 @@ import Prelude.Compat import qualified TestCompiler -import qualified TestPscPublish import qualified TestDocs import qualified TestPsci import qualified TestPscIde +import qualified TestPscPublish +import qualified TestUtils import System.IO (hSetEncoding, stdout, stderr, utf8) @@ -21,6 +22,8 @@ hSetEncoding stdout utf8 hSetEncoding stderr utf8 + heading "Updating support code" + TestUtils.updateSupportCode heading "Main compiler test suite" TestCompiler.main heading "Documentation test suite" diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -26,14 +26,16 @@ import qualified Language.PureScript as P import Data.Char (isSpace) -import Data.Maybe (mapMaybe, fromMaybe) -import Data.List (isSuffixOf, sort, stripPrefix) +import Data.Function (on) +import Data.List (sort, stripPrefix, intercalate, groupBy, sortBy, minimumBy) +import Data.Maybe (mapMaybe) import Data.Time.Clock (UTCTime()) +import Data.Tuple (swap) import qualified Data.Map as M import Control.Monad -import Control.Arrow ((>>>)) +import Control.Arrow ((***), (>>>)) import Control.Monad.Reader import Control.Monad.Writer.Strict @@ -44,43 +46,117 @@ import System.FilePath import System.Directory import System.IO.UTF8 +import System.IO.Silently import qualified System.FilePath.Glob as Glob import TestUtils +import Test.Hspec main :: IO () -main = do - cwd <- getCurrentDirectory +main = hspec spec - let supportDir = cwd "tests" "support" "flattened" - let supportFiles ext = Glob.globDir1 (Glob.compile ("*." ++ ext)) supportDir +spec :: Spec +spec = do - supportPurs <- supportFiles "purs" - supportJS <- supportFiles "js" + (supportExterns, passingTestCases, warningTestCases, failingTestCases) <- runIO $ do + cwd <- getCurrentDirectory + let passing = cwd "examples" "passing" + let warning = cwd "examples" "warning" + let failing = cwd "examples" "failing" + let supportDir = cwd "tests" "support" "bower_components" + let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir + passingFiles <- getTestFiles passing <$> testGlob passing + warningFiles <- getTestFiles warning <$> testGlob warning + failingFiles <- getTestFiles failing <$> testGlob failing + supportPurs <- supportFiles "purs" + supportPursFiles <- readInput supportPurs + supportExterns <- runExceptT $ do + modules <- ExceptT . return $ P.parseModulesFromFiles id supportPursFiles + foreigns <- inferForeignModules modules + externs <- ExceptT . fmap fst . runTest $ P.make (makeActions foreigns) (map snd modules) + return (zip (map snd modules) externs) + case supportExterns of + Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) + Right externs -> return (externs, passingFiles, warningFiles, failingFiles) - foreignFiles <- forM supportJS (\f -> (f,) <$> readUTF8File f) - Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles + context "Passing examples" $ + forM_ passingTestCases $ \testPurs -> + it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $ + assertCompiles supportExterns testPurs - let passing = cwd "examples" "passing" - passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passing - let failing = cwd "examples" "failing" - failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing + context "Warning examples" $ + forM_ warningTestCases $ \testPurs -> do + let mainPath = getTestMain testPurs + expectedWarnings <- runIO $ getShouldWarnWith mainPath + it ("'" <> takeFileName mainPath <> "' should compile with warning(s) '" <> intercalate "', '" expectedWarnings <> "'") $ + assertCompilesWithWarnings supportExterns testPurs expectedWarnings - failures <- execWriterT $ do - forM_ passingTestCases $ \inputFile -> - assertCompiles (supportPurs ++ [passing inputFile]) foreigns - forM_ failingTestCases $ \inputFile -> - assertDoesNotCompile (supportPurs ++ [failing inputFile]) foreigns + context "Failing examples" $ + forM_ failingTestCases $ \testPurs -> do + let mainPath = getTestMain testPurs + expectedFailures <- runIO $ getShouldFailWith mainPath + it ("'" <> takeFileName mainPath <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $ + assertDoesNotCompile supportExterns testPurs expectedFailures - if null failures - then pure () - else do - putStrLn "Failures:" - forM_ failures $ \(fp, err) -> - let fp' = fromMaybe fp $ stripPrefix (failing ++ [pathSeparator]) fp - in putStrLn $ fp' ++ ": " ++ err - exitFailure + where + -- A glob for all purs and js files within a test directory + testGlob :: FilePath -> IO [FilePath] + testGlob = Glob.globDir1 (Glob.compile "**/*.purs") + + -- Groups the test files so that a top-level file can have dependencies in a + -- subdirectory of the same name. The inner tuple contains a list of the + -- .purs files and the .js files for the test case. + getTestFiles :: FilePath -> [FilePath] -> [[FilePath]] + getTestFiles baseDir + = map (filter ((== ".purs") . takeExtensions) . map (baseDir )) + . groupBy ((==) `on` extractPrefix) + . sortBy (compare `on` extractPrefix) + . map (makeRelative baseDir) + + -- Takes the test entry point from a group of purs files - this is determined + -- by the file with the shortest path name, as everything but the main file + -- will be under a subdirectory. + getTestMain :: [FilePath] -> FilePath + getTestMain = minimumBy (compare `on` length) + + -- Extracts the filename part of a .purs file, or if the file is in a + -- subdirectory, the first part of that directory path. + extractPrefix :: FilePath -> FilePath + extractPrefix fp = + let dir = takeDirectory fp + ext = reverse ".purs" + in if dir == "." + then maybe fp reverse $ stripPrefix ext $ reverse fp + else dir + + -- Scans a file for @shouldFailWith directives in the comments, used to + -- determine expected failures + getShouldFailWith :: FilePath -> IO [String] + getShouldFailWith = extractPragma "shouldFailWith" + + -- Scans a file for @shouldWarnWith directives in the comments, used to + -- determine expected warnings + getShouldWarnWith :: FilePath -> IO [String] + getShouldWarnWith = extractPragma "shouldWarnWith" + + extractPragma :: String -> FilePath -> IO [String] + extractPragma pragma = fmap go . readUTF8File + where + go = lines >>> mapMaybe (stripPrefix ("-- @" ++ pragma ++ " ")) >>> map trim + +inferForeignModules + :: MonadIO m + => [(FilePath, P.Module)] + -> m (M.Map P.ModuleName FilePath) +inferForeignModules = P.inferForeignModules . fromList + where + fromList :: [(FilePath, P.Module)] -> M.Map P.ModuleName (Either P.RebuildPolicy FilePath) + fromList = M.fromList . map ((P.getModuleName *** Right) . swap) + +trim :: String -> String +trim = dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse + modulesDir :: FilePath modulesDir = ".test_modules" "node_modules" @@ -108,53 +184,96 @@ text <- readUTF8File inputFile return (inputFile, text) -type TestM = WriterT [(FilePath, String)] IO - -runTest :: P.Make a -> IO (Either P.MultipleErrors a) -runTest = fmap fst . P.runMake P.defaultOptions +runTest :: P.Make a -> IO (Either P.MultipleErrors a, P.MultipleErrors) +runTest = P.runMake P.defaultOptions -compile :: [FilePath] -> M.Map P.ModuleName FilePath -> IO (Either P.MultipleErrors P.Environment) -compile inputFiles foreigns = runTest $ do +compile + :: [(P.Module, P.ExternsFile)] + -> [FilePath] + -> ([P.Module] -> IO ()) + -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors) +compile supportExterns inputFiles check = silence $ runTest $ do fs <- liftIO $ readInput inputFiles ms <- P.parseModulesFromFiles id fs - P.make (makeActions foreigns) (map snd ms) + foreigns <- inferForeignModules ms + liftIO (check (map snd ms)) + let actions = makeActions foreigns + case ms of + [singleModule] -> pure <$> P.rebuildModule actions (map snd supportExterns) (snd singleModule) + _ -> P.make actions (map fst supportExterns ++ map snd ms) -assert :: [FilePath] -> - M.Map P.ModuleName FilePath -> - (Either P.MultipleErrors P.Environment -> IO (Maybe String)) -> - TestM () -assert inputFiles foreigns f = do - e <- liftIO $ compile inputFiles foreigns - maybeErr <- liftIO $ f e - case maybeErr of - Just err -> tell [(last inputFiles, err)] - Nothing -> return () +assert + :: [(P.Module, P.ExternsFile)] + -> [FilePath] + -> ([P.Module] -> IO ()) + -> (Either P.MultipleErrors P.MultipleErrors -> IO (Maybe String)) + -> Expectation +assert supportExterns inputFiles check f = do + (e, w) <- compile supportExterns inputFiles check + maybeErr <- f (const w <$> e) + maybe (return ()) expectationFailure maybeErr -assertCompiles :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM () -assertCompiles inputFiles foreigns = do - liftIO . putStrLn $ "Assert " ++ last inputFiles ++ " compiles successfully" - assert inputFiles foreigns $ \e -> +checkMain :: [P.Module] -> IO () +checkMain ms = + unless (any ((== P.moduleNameFromString "Main") . P.getModuleName) ms) + (fail "Main module missing") + +checkShouldFailWith :: [String] -> P.MultipleErrors -> Maybe String +checkShouldFailWith expected errs = + let actual = map P.errorCode $ P.runMultipleErrors errs + in if sort expected == sort actual + then Nothing + else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual + +assertCompiles + :: [(P.Module, P.ExternsFile)] + -> [FilePath] + -> Expectation +assertCompiles supportExterns inputFiles = + assert supportExterns inputFiles checkMain $ \e -> case e of - Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs + Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs Right _ -> do process <- findNodeProcess let entryPoint = modulesDir "index.js" writeFile entryPoint "require('Main').main()" result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process case result of - Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing + Just (ExitSuccess, out, err) + | not (null err) -> return $ Just $ "Test wrote to stderr:\n\n" <> err + | not (null out) && trim (last (lines out)) == "Done" -> return Nothing + | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out Just (ExitFailure _, _, err) -> return $ Just err Nothing -> return $ Just "Couldn't find node.js executable" -assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM () -assertDoesNotCompile inputFiles foreigns = do - let testFile = last inputFiles - liftIO . putStrLn $ "Assert " ++ testFile ++ " does not compile" - shouldFailWith <- getShouldFailWith testFile - assert inputFiles foreigns $ \e -> +assertCompilesWithWarnings + :: [(P.Module, P.ExternsFile)] + -> [FilePath] + -> [String] + -> Expectation +assertCompilesWithWarnings supportExterns inputFiles shouldWarnWith = + assert supportExterns inputFiles checkMain $ \e -> case e of - Left errs -> do - putStrLn (P.prettyPrintMultipleErrors False errs) + Left errs -> + return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs + Right warnings -> + return + . fmap (printAllWarnings warnings) + $ checkShouldFailWith shouldWarnWith warnings + + where + printAllWarnings warnings = + (<> "\n\n" <> P.prettyPrintMultipleErrors P.defaultPPEOptions warnings) + +assertDoesNotCompile + :: [(P.Module, P.ExternsFile)] + -> [FilePath] + -> [String] + -> Expectation +assertDoesNotCompile supportExterns inputFiles shouldFailWith = + assert supportExterns inputFiles noPreCheck $ \e -> + case e of + Left errs -> return $ if null shouldFailWith then Just $ "shouldFailWith declaration is missing (errors were: " ++ show (map P.errorCode (P.runMultipleErrors errs)) @@ -164,31 +283,4 @@ return $ Just "Should not have compiled" where - getShouldFailWith = - readUTF8File - >>> liftIO - >>> fmap ( lines - >>> mapMaybe (stripPrefix "-- @shouldFailWith ") - >>> map trim - ) - - checkShouldFailWith expected errs = - let actual = map P.errorCode $ P.runMultipleErrors errs - in if sort expected == sort actual - then Nothing - else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual - - trim = - dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse - -supportModules :: [String] -supportModules = - [ "Control.Monad.Eff.Class" - , "Control.Monad.Eff.Console" - , "Control.Monad.Eff" - , "Control.Monad.Eff.Unsafe" - , "Control.Monad.ST" - , "Data.Function" - , "Prelude" - , "Test.Assert" - ] + noPreCheck = const (return ()) diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -197,7 +197,7 @@ False where matches className = - (==) className . P.runProperName . P.disqualify . fst + (==) className . P.runProperName . P.disqualify . P.constraintClass runAssertionIO :: Assertion -> Docs.Module -> IO () runAssertionIO assertion mdl = do @@ -266,13 +266,8 @@ ]) , ("TypeClassWithoutMembers", - [ ShouldBeDocumented (n "Intermediate") "SomeClass" [] - , ChildShouldNotBeDocumented (n "Intermediate") "SomeClass" "member" - ]) - - -- Remove this after 0.9. - , ("OldOperators", - [ ShouldBeDocumented (n "OldOperators2") "(>>)" [] + [ ShouldBeDocumented (n "TypeClassWithoutMembersIntermediate") "SomeClass" [] + , ChildShouldNotBeDocumented (n "TypeClassWithoutMembersIntermediate") "SomeClass" "member" ]) , ("NewOperators", diff --git a/tests/TestPscIde.hs b/tests/TestPscIde.hs --- a/tests/TestPscIde.hs +++ b/tests/TestPscIde.hs @@ -1,7 +1,14 @@ module TestPscIde where +import Control.Monad (unless) +import Language.PureScript.Ide.Integration import qualified PscIdeSpec -import Test.Hspec +import Test.Hspec main :: IO () -main = hspec PscIdeSpec.spec +main = do + deleteOutputFolder + s <- compileTestProject + unless s $ fail "Failed to compile .purs sources" + + withServer (hspec PscIdeSpec.spec) diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs --- a/tests/TestPscPublish.hs +++ b/tests/TestPscPublish.hs @@ -24,7 +24,7 @@ import TestUtils main :: IO () -main = testPackage "tests/support/prelude" +main = testPackage "tests/support/bower_components/purescript-prelude" data TestResult = ParseFailed String diff --git a/tests/TestPsci.hs b/tests/TestPsci.hs --- a/tests/TestPsci.hs +++ b/tests/TestPsci.hs @@ -6,10 +6,8 @@ import Prelude () import Prelude.Compat -import Control.Monad.Trans.State.Strict (runStateT) -import Control.Monad (when, forM) -import Control.Monad.Writer.Strict (runWriterT) -import Control.Monad.Trans.Except (runExceptT) +import Control.Monad.Trans.State.Strict (evalStateT) +import Control.Monad (when) import Data.List (sort) @@ -17,17 +15,18 @@ import System.Console.Haskeline import System.FilePath (()) import System.Directory (getCurrentDirectory) -import System.IO.UTF8 (readUTF8File) import qualified System.FilePath.Glob as Glob import Test.HUnit import qualified Language.PureScript as P -import PSCi.Module (loadAllModules) -import PSCi.Completion -import PSCi.Types +import Language.PureScript.Interactive.Module (loadAllModules) +import Language.PureScript.Interactive.Completion +import Language.PureScript.Interactive.Types +import TestUtils (supportModules) + main :: IO () main = do Counts{..} <- runTestTT allTests @@ -47,11 +46,10 @@ completionTestData :: [(String, [String])] completionTestData = -- basic directives - [ (":h", [":help"]) + [ (":h", [":help"]) , (":re", [":reset"]) - , (":q", [":quit"]) - , (":mo", [":module"]) - , (":b", [":browse"]) + , (":q", [":quit"]) + , (":b", [":browse"]) -- :browse should complete module names , (":b Control.Monad.E", map (":b Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console"]) @@ -60,12 +58,7 @@ -- import should complete module names , ("import Control.Monad.E", map ("import Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console"]) , ("import Control.Monad.Eff.", map ("import Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"]) - , ("import qualified Control.Monad.Eff.", map ("import qualified Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"]) - -- :load, :module should complete file paths - , (":l tests/support/psci/", [":l tests/support/psci/Sample.purs"]) - , (":module tests/support/psci/", [":module tests/support/psci/Sample.purs"]) - -- :quit, :help, :reset should not complete , (":help ", []) , (":quit ", []) @@ -76,13 +69,13 @@ , (":show a", []) -- :type should complete values and data constructors in scope - , (":type Control.Monad.Eff.Console.lo", [":type Control.Monad.Eff.Console.log"]) - , (":type uni", [":type unit"]) - , (":type E", [":type EQ"]) + , (":type Control.Monad.Eff.Console.lo", [":type Control.Monad.Eff.Console.log", ":type Control.Monad.Eff.Console.logShow"]) + --, (":type uni", [":type unit"]) + --, (":type E", [":type EQ"]) -- :kind should complete types in scope - , (":kind C", [":kind Control.Monad.Eff.Pure"]) - , (":kind O", [":kind Ordering"]) + --, (":kind C", [":kind Control.Monad.Eff.Pure"]) + --, (":kind O", [":kind Ordering"]) -- Only one argument for directives should be completed , (":show import ", []) @@ -91,8 +84,7 @@ -- a few other import tests , ("impor", ["import"]) - , ("import q", ["import qualified"]) - , ("import ", map ("import " ++) supportModules ++ ["import qualified"]) + , ("import ", map ("import " ++) supportModules) , ("import Prelude ", []) -- String and number literals should not be completed @@ -100,10 +92,10 @@ , ("34", []) -- Identifiers and data constructors should be completed - , ("uni", ["unit"]) + --, ("uni", ["unit"]) , ("Control.Monad.Eff.Class.", ["Control.Monad.Eff.Class.liftEff"]) - , ("G", ["GT"]) - , ("Prelude.L", ["Prelude.LT"]) + --, ("G", ["GT"]) + , ("Data.Ordering.L", ["Data.Ordering.LT"]) -- if a module is imported qualified, values should complete under the -- qualified name, as well as the original name. @@ -122,39 +114,25 @@ runCM :: CompletionM a -> IO a runCM act = do psciState <- getPSCiState - fmap fst (runStateT (liftCompletionM act) psciState) + evalStateT (liftCompletionM act) psciState getPSCiState :: IO PSCiState getPSCiState = do cwd <- getCurrentDirectory - let supportDir = cwd "tests" "support" "flattened" - let supportFiles ext = Glob.globDir1 (Glob.compile ("*." ++ ext)) supportDir + let supportDir = cwd "tests" "support" "bower_components" + let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir pursFiles <- supportFiles "purs" - jsFiles <- supportFiles "js" modulesOrFirstError <- loadAllModules pursFiles - foreignFiles <- forM jsFiles (\f -> (f,) <$> readUTF8File f) - Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles case modulesOrFirstError of Left err -> print err >> exitFailure Right modules -> let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName "Prelude"], P.Implicit, Nothing)] - in return (mkPSCiState imports modules foreigns [] []) + dummyExterns = P.internalError "TestPsci: dummyExterns should not be used" + in return (PSCiState imports [] (zip (map snd modules) (repeat dummyExterns))) controlMonadSTasST :: ImportedModule controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST")) where s = P.moduleNameFromString - -supportModules :: [String] -supportModules = - [ "Control.Monad.Eff.Class" - , "Control.Monad.Eff.Console" - , "Control.Monad.Eff" - , "Control.Monad.Eff.Unsafe" - , "Control.Monad.ST" - , "Data.Function" - , "Prelude" - , "Test.Assert" - ] diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -1,15 +1,3 @@ ------------------------------------------------------------------------------ --- --- Module : Main --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ {-# LANGUAGE ScopedTypeVariables #-} module TestUtils where @@ -17,7 +5,6 @@ import Prelude () import Prelude.Compat -import Data.Maybe (fromMaybe) import Control.Monad import Control.Monad.Trans.Maybe import Control.Exception @@ -26,8 +13,6 @@ import System.Directory import System.Info -import Language.PureScript.Crash - findNodeProcess :: IO (Maybe String) findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names where @@ -43,7 +28,6 @@ -- updateSupportCode :: IO () updateSupportCode = do - node <- fromMaybe (internalError "cannot find node executable") <$> findNodeProcess setCurrentDirectory "tests/support" if System.Info.os == "mingw32" then callProcess "setup-win.cmd" [] @@ -52,9 +36,51 @@ -- Sometimes we run as a root (e.g. in simple docker containers) -- And we are non-interactive: https://github.com/bower/bower/issues/1162 callProcess "node_modules/.bin/bower" ["--allow-root", "install", "--config.interactive=false"] - callProcess node ["setup.js"] setCurrentDirectory "../.." +-- | +-- The support modules that should be cached between test cases, to avoid +-- excessive rebuilding. +-- +supportModules :: [String] +supportModules = + [ "Control.Applicative" + , "Control.Apply" + , "Control.Bind" + , "Control.Category" + , "Control.Monad.Eff.Class" + , "Control.Monad.Eff.Console" + , "Control.Monad.Eff.Unsafe" + , "Control.Monad.Eff" + , "Control.Monad.ST" + , "Control.Monad" + , "Control.Semigroupoid" + , "Data.Boolean" + , "Data.BooleanAlgebra" + , "Data.Bounded" + , "Data.CommutativeRing" + , "Data.Eq" + , "Data.EuclideanRing" + , "Data.Field" + , "Data.Function.Uncurried" + , "Data.Function" + , "Data.Functor" + , "Data.HeytingAlgebra" + , "Data.Ord.Unsafe" + , "Data.Ord" + , "Data.Ordering" + , "Data.Ring" + , "Data.Semigroup" + , "Data.Semiring" + , "Data.Show" + , "Data.Unit" + , "Data.Void" + , "Partial" + , "Partial.Unsafe" + , "Prelude" + , "Test.Assert" + ] + pushd :: forall a. FilePath -> IO a -> IO a pushd dir act = do original <- getCurrentDirectory @@ -62,4 +88,3 @@ result <- try act :: IO (Either IOException a) setCurrentDirectory original either throwIO return result - diff --git a/tests/support/bower.json b/tests/support/bower.json --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -1,11 +1,12 @@ { "name": "purescript-test-suite-support", "dependencies": { - "purescript-eff": "0.1.0", - "purescript-prelude": "0.1.3", - "purescript-assert": "0.1.1", - "purescript-st": "0.1.0", - "purescript-console": "0.1.0", - "purescript-functions": "0.1.0" + "purescript-assert": "1.0.0-rc.1", + "purescript-console": "1.0.0-rc.1", + "purescript-eff": "1.0.0-rc.1", + "purescript-functions": "1.0.0-rc.1", + "purescript-prelude": "1.0.0-rc.3", + "purescript-st": "1.0.0-rc.1", + "purescript-partial": "1.1.2" } } diff --git a/tests/support/flattened/Control-Monad-Eff-Class.purs b/tests/support/flattened/Control-Monad-Eff-Class.purs deleted file mode 100644 --- a/tests/support/flattened/Control-Monad-Eff-Class.purs +++ /dev/null @@ -1,24 +0,0 @@ -module Control.Monad.Eff.Class - ( MonadEff - , liftEff - ) where - -import Prelude - -import Control.Monad.Eff - --- | The `MonadEff` class captures those monads which support native effects. --- | --- | Instances are provided for `Eff` itself, and the standard monad transformers. --- | --- | `liftEff` can be used in any appropriate monad transformer stack to lift an action --- | of type `Eff eff a` into the monad. --- | --- | Note that `MonadEff` is parameterized by the row of effects, so type inference can be --- | tricky. It is generally recommended to either work with a polymorphic row of effects, --- | or a concrete, closed row of effects such as `(trace :: Trace)`. -class (Monad m) <= MonadEff eff m where - liftEff :: forall a. Eff eff a -> m a - -instance monadEffEff :: MonadEff eff (Eff eff) where - liftEff = id diff --git a/tests/support/flattened/Control-Monad-Eff-Console.js b/tests/support/flattened/Control-Monad-Eff-Console.js deleted file mode 100644 --- a/tests/support/flattened/Control-Monad-Eff-Console.js +++ /dev/null @@ -1,18 +0,0 @@ -/* global exports, console */ -"use strict"; - -// module Control.Monad.Eff.Console - -exports.log = function (s) { - return function () { - console.log(s); - return {}; - }; -}; - -exports.error = function (s) { - return function () { - console.error(s); - return {}; - }; -}; diff --git a/tests/support/flattened/Control-Monad-Eff-Console.purs b/tests/support/flattened/Control-Monad-Eff-Console.purs deleted file mode 100644 --- a/tests/support/flattened/Control-Monad-Eff-Console.purs +++ /dev/null @@ -1,18 +0,0 @@ -module Control.Monad.Eff.Console where - -import Prelude - -import Control.Monad.Eff - --- | The `CONSOLE` effect represents those computations which write to the console. -foreign import data CONSOLE :: ! - --- | Write a message to the console. -foreign import log :: forall eff. String -> Eff (console :: CONSOLE | eff) Unit - --- | Write an error to the console. -foreign import error :: forall eff. String -> Eff (console :: CONSOLE | eff) Unit - --- | Write a value to the console, using its `Show` instance to produce a `String`. -print :: forall a eff. (Show a) => a -> Eff (console :: CONSOLE | eff) Unit -print = log <<< show diff --git a/tests/support/flattened/Control-Monad-Eff-Unsafe.js b/tests/support/flattened/Control-Monad-Eff-Unsafe.js deleted file mode 100644 --- a/tests/support/flattened/Control-Monad-Eff-Unsafe.js +++ /dev/null @@ -1,8 +0,0 @@ -/* global exports */ -"use strict"; - -// module Control.Monad.Eff.Unsafe - -exports.unsafeInterleaveEff = function (f) { - return f; -}; diff --git a/tests/support/flattened/Control-Monad-Eff-Unsafe.purs b/tests/support/flattened/Control-Monad-Eff-Unsafe.purs deleted file mode 100644 --- a/tests/support/flattened/Control-Monad-Eff-Unsafe.purs +++ /dev/null @@ -1,10 +0,0 @@ -module Control.Monad.Eff.Unsafe where - -import Prelude - -import Control.Monad.Eff - --- | Change the type of an effectful computation, allowing it to be run in another context. --- | --- | Note: use of this function can result in arbitrary side-effects. -foreign import unsafeInterleaveEff :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a diff --git a/tests/support/flattened/Control-Monad-Eff.js b/tests/support/flattened/Control-Monad-Eff.js deleted file mode 100644 --- a/tests/support/flattened/Control-Monad-Eff.js +++ /dev/null @@ -1,62 +0,0 @@ -/* global exports */ -"use strict"; - -// module Control.Monad.Eff - -exports.returnE = function (a) { - return function () { - return a; - }; -}; - -exports.bindE = function (a) { - return function (f) { - return function () { - return f(a())(); - }; - }; -}; - -exports.runPure = function (f) { - return f(); -}; - -exports.untilE = function (f) { - return function () { - while (!f()); - return {}; - }; -}; - -exports.whileE = function (f) { - return function (a) { - return function () { - while (f()) { - a(); - } - return {}; - }; - }; -}; - -exports.forE = function (lo) { - return function (hi) { - return function (f) { - return function () { - for (var i = lo; i < hi; i++) { - f(i)(); - } - }; - }; - }; -}; - -exports.foreachE = function (as) { - return function (f) { - return function () { - for (var i = 0, l = as.length; i < l; i++) { - f(as[i])(); - } - }; - }; -}; diff --git a/tests/support/flattened/Control-Monad-Eff.purs b/tests/support/flattened/Control-Monad-Eff.purs deleted file mode 100644 --- a/tests/support/flattened/Control-Monad-Eff.purs +++ /dev/null @@ -1,67 +0,0 @@ -module Control.Monad.Eff - ( Eff() - , Pure() - , runPure - , untilE, whileE, forE, foreachE - ) where - -import Prelude - --- | The `Eff` type constructor is used to represent _native_ effects. --- | --- | See [Handling Native Effects with the Eff Monad](https://github.com/purescript/purescript/wiki/Handling-Native-Effects-with-the-Eff-Monad) for more details. --- | --- | The first type parameter is a row of effects which represents the contexts in which a computation can be run, and the second type parameter is the return type. -foreign import data Eff :: # ! -> * -> * - -foreign import returnE :: forall e a. a -> Eff e a - -foreign import bindE :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b - --- | The `Pure` type synonym represents _pure_ computations, i.e. ones in which all effects have been handled. --- | --- | The `runPure` function can be used to run pure computations and obtain their result. -type Pure a = forall e. Eff e a - --- | Run a pure computation and return its result. --- | --- | Note: since this function has a rank-2 type, it may cause problems to apply this function using the `$` operator. The recommended approach --- | is to use parentheses instead. -foreign import runPure :: forall a. Pure a -> a - -instance functorEff :: Functor (Eff e) where - map = liftA1 - -instance applyEff :: Apply (Eff e) where - apply = ap - -instance applicativeEff :: Applicative (Eff e) where - pure = returnE - -instance bindEff :: Bind (Eff e) where - bind = bindE - -instance monadEff :: Monad (Eff e) - --- | Loop until a condition becomes `true`. --- | --- | `untilE b` is an effectful computation which repeatedly runs the effectful computation `b`, --- | until its return value is `true`. -foreign import untilE :: forall e. Eff e Boolean -> Eff e Unit - --- | Loop while a condition is `true`. --- | --- | `whileE b m` is effectful computation which runs the effectful computation `b`. If its result is --- | `true`, it runs the effectful computation `m` and loops. If not, the computation ends. -foreign import whileE :: forall e a. Eff e Boolean -> Eff e a -> Eff e Unit - --- | Loop over a consecutive collection of numbers. --- | --- | `forE lo hi f` runs the computation returned by the function `f` for each of the inputs --- | between `lo` (inclusive) and `hi` (exclusive). -foreign import forE :: forall e. Number -> Number -> (Number -> Eff e Unit) -> Eff e Unit - --- | Loop over an array of values. --- | --- | `foreach xs f` runs the computation returned by the function `f` for each of the inputs `xs`. -foreign import foreachE :: forall e a. Array a -> (a -> Eff e Unit) -> Eff e Unit diff --git a/tests/support/flattened/Control-Monad-ST.js b/tests/support/flattened/Control-Monad-ST.js deleted file mode 100644 --- a/tests/support/flattened/Control-Monad-ST.js +++ /dev/null @@ -1,38 +0,0 @@ -/* global exports */ -"use strict"; - -// module Control.Monad.ST - -exports.newSTRef = function (val) { - return function () { - return { value: val }; - }; -}; - -exports.readSTRef = function (ref) { - return function () { - return ref.value; - }; -}; - -exports.modifySTRef = function (ref) { - return function (f) { - return function () { - /* jshint boss: true */ - return ref.value = f(ref.value); - }; - }; -}; - -exports.writeSTRef = function (ref) { - return function (a) { - return function () { - /* jshint boss: true */ - return ref.value = a; - }; - }; -}; - -exports.runST = function (f) { - return f; -}; diff --git a/tests/support/flattened/Control-Monad-ST.purs b/tests/support/flattened/Control-Monad-ST.purs deleted file mode 100644 --- a/tests/support/flattened/Control-Monad-ST.purs +++ /dev/null @@ -1,42 +0,0 @@ -module Control.Monad.ST where - -import Prelude - -import Control.Monad.Eff (Eff(), runPure) - --- | The `ST` effect represents _local mutation_, i.e. mutation which does not "escape" into the surrounding computation. --- | --- | An `ST` computation is parameterized by a phantom type which is used to restrict the set of reference cells it is allowed to access. --- | --- | The `runST` function can be used to handle the `ST` effect. -foreign import data ST :: * -> ! - --- | The type `STRef s a` represents a mutable reference holding a value of type `a`, which can be used with the `ST s` effect. -foreign import data STRef :: * -> * -> * - --- | Create a new mutable reference. -foreign import newSTRef :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a) - --- | Read the current value of a mutable reference. -foreign import readSTRef :: forall a h r. STRef h a -> Eff (st :: ST h | r) a - --- | Modify the value of a mutable reference by applying a function to the current value. -foreign import modifySTRef :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a - --- | Set the value of a mutable reference. -foreign import writeSTRef :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a - --- | Run an `ST` computation. --- | --- | Note: the type of `runST` uses a rank-2 type to constrain the phantom type `s`, such that the computation must not leak any mutable references --- | to the surrounding computation. --- | --- | It may cause problems to apply this function using the `$` operator. The recommended approach is to use parentheses instead. -foreign import runST :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a - --- | A convenience function which combines `runST` with `runPure`, which can be used when the only required effect is `ST`. --- | --- | Note: since this function has a rank-2 type, it may cause problems to apply this function using the `$` operator. The recommended approach --- | is to use parentheses instead. -pureST :: forall a. (forall h r. Eff (st :: ST h | r) a) -> a -pureST st = runPure (runST st) diff --git a/tests/support/flattened/Data-Function.js b/tests/support/flattened/Data-Function.js deleted file mode 100644 --- a/tests/support/flattened/Data-Function.js +++ /dev/null @@ -1,233 +0,0 @@ -/* global exports */ -"use strict"; - -// module Data.Function - -exports.mkFn0 = function (fn) { - return function () { - return fn({}); - }; -}; - -exports.mkFn1 = function (fn) { - return function (a) { - return fn(a); - }; -}; - -exports.mkFn2 = function (fn) { - /* jshint maxparams: 2 */ - return function (a, b) { - return fn(a)(b); - }; -}; - -exports.mkFn3 = function (fn) { - /* jshint maxparams: 3 */ - return function (a, b, c) { - return fn(a)(b)(c); - }; -}; - -exports.mkFn4 = function (fn) { - /* jshint maxparams: 4 */ - return function (a, b, c, d) { - return fn(a)(b)(c)(d); - }; -}; - -exports.mkFn5 = function (fn) { - /* jshint maxparams: 5 */ - return function (a, b, c, d, e) { - return fn(a)(b)(c)(d)(e); - }; -}; - -exports.mkFn6 = function (fn) { - /* jshint maxparams: 6 */ - return function (a, b, c, d, e, f) { - return fn(a)(b)(c)(d)(e)(f); - }; -}; - -exports.mkFn7 = function (fn) { - /* jshint maxparams: 7 */ - return function (a, b, c, d, e, f, g) { - return fn(a)(b)(c)(d)(e)(f)(g); - }; -}; - -exports.mkFn8 = function (fn) { - /* jshint maxparams: 8 */ - return function (a, b, c, d, e, f, g, h) { - return fn(a)(b)(c)(d)(e)(f)(g)(h); - }; -}; - -exports.mkFn9 = function (fn) { - /* jshint maxparams: 9 */ - return function (a, b, c, d, e, f, g, h, i) { - return fn(a)(b)(c)(d)(e)(f)(g)(h)(i); - }; -}; - -exports.mkFn10 = function (fn) { - /* jshint maxparams: 10 */ - return function (a, b, c, d, e, f, g, h, i, j) { - return fn(a)(b)(c)(d)(e)(f)(g)(h)(i)(j); - }; -}; - -exports.runFn0 = function (fn) { - return fn(); -}; - -exports.runFn1 = function (fn) { - return function (a) { - return fn(a); - }; -}; - -exports.runFn2 = function (fn) { - return function (a) { - return function (b) { - return fn(a, b); - }; - }; -}; - -exports.runFn3 = function (fn) { - return function (a) { - return function (b) { - return function (c) { - return fn(a, b, c); - }; - }; - }; -}; - -exports.runFn4 = function (fn) { - return function (a) { - return function (b) { - return function (c) { - return function (d) { - return fn(a, b, c, d); - }; - }; - }; - }; -}; - -exports.runFn5 = function (fn) { - return function (a) { - return function (b) { - return function (c) { - return function (d) { - return function (e) { - return fn(a, b, c, d, e); - }; - }; - }; - }; - }; -}; - -exports.runFn6 = function (fn) { - return function (a) { - return function (b) { - return function (c) { - return function (d) { - return function (e) { - return function (f) { - return fn(a, b, c, d, e, f); - }; - }; - }; - }; - }; - }; -}; - -exports.runFn7 = function (fn) { - return function (a) { - return function (b) { - return function (c) { - return function (d) { - return function (e) { - return function (f) { - return function (g) { - return fn(a, b, c, d, e, f, g); - }; - }; - }; - }; - }; - }; - }; -}; - -exports.runFn8 = function (fn) { - return function (a) { - return function (b) { - return function (c) { - return function (d) { - return function (e) { - return function (f) { - return function (g) { - return function (h) { - return fn(a, b, c, d, e, f, g, h); - }; - }; - }; - }; - }; - }; - }; - }; -}; - -exports.runFn9 = function (fn) { - return function (a) { - return function (b) { - return function (c) { - return function (d) { - return function (e) { - return function (f) { - return function (g) { - return function (h) { - return function (i) { - return fn(a, b, c, d, e, f, g, h, i); - }; - }; - }; - }; - }; - }; - }; - }; - }; -}; - -exports.runFn10 = function (fn) { - return function (a) { - return function (b) { - return function (c) { - return function (d) { - return function (e) { - return function (f) { - return function (g) { - return function (h) { - return function (i) { - return function (j) { - return fn(a, b, c, d, e, f, g, h, i, j); - }; - }; - }; - }; - }; - }; - }; - }; - }; - }; -}; diff --git a/tests/support/flattened/Data-Function.purs b/tests/support/flattened/Data-Function.purs deleted file mode 100644 --- a/tests/support/flattened/Data-Function.purs +++ /dev/null @@ -1,113 +0,0 @@ -module Data.Function where - -import Prelude - --- | The `on` function is used to change the domain of a binary operator. --- | --- | For example, we can create a function which compares two records based on the values of their `x` properties: --- | --- | ```purescript --- | compareX :: forall r. { x :: Number | r } -> { x :: Number | r } -> Ordering --- | compareX = compare `on` _.x --- | ``` -on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c -on f g x y = g x `f` g y - --- | A function of zero arguments -foreign import data Fn0 :: * -> * - --- | A function of one argument -foreign import data Fn1 :: * -> * -> * - --- | A function of two arguments -foreign import data Fn2 :: * -> * -> * -> * - --- | A function of three arguments -foreign import data Fn3 :: * -> * -> * -> * -> * - --- | A function of four arguments -foreign import data Fn4 :: * -> * -> * -> * -> * -> * - --- | A function of five arguments -foreign import data Fn5 :: * -> * -> * -> * -> * -> * -> * - --- | A function of six arguments -foreign import data Fn6 :: * -> * -> * -> * -> * -> * -> * -> * - --- | A function of seven arguments -foreign import data Fn7 :: * -> * -> * -> * -> * -> * -> * -> * -> * - --- | A function of eight arguments -foreign import data Fn8 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * - --- | A function of nine arguments -foreign import data Fn9 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * - --- | A function of ten arguments -foreign import data Fn10 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * - --- | Create a function of no arguments -foreign import mkFn0 :: forall a. (Unit -> a) -> Fn0 a - --- | Create a function of one argument -foreign import mkFn1 :: forall a b. (a -> b) -> Fn1 a b - --- | Create a function of two arguments from a curried function -foreign import mkFn2 :: forall a b c. (a -> b -> c) -> Fn2 a b c - --- | Create a function of three arguments from a curried function -foreign import mkFn3 :: forall a b c d. (a -> b -> c -> d) -> Fn3 a b c d - --- | Create a function of four arguments from a curried function -foreign import mkFn4 :: forall a b c d e. (a -> b -> c -> d -> e) -> Fn4 a b c d e - --- | Create a function of five arguments from a curried function -foreign import mkFn5 :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Fn5 a b c d e f - --- | Create a function of six arguments from a curried function -foreign import mkFn6 :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> Fn6 a b c d e f g - --- | Create a function of seven arguments from a curried function -foreign import mkFn7 :: forall a b c d e f g h. (a -> b -> c -> d -> e -> f -> g -> h) -> Fn7 a b c d e f g h - --- | Create a function of eight arguments from a curried function -foreign import mkFn8 :: forall a b c d e f g h i. (a -> b -> c -> d -> e -> f -> g -> h -> i) -> Fn8 a b c d e f g h i - --- | Create a function of nine arguments from a curried function -foreign import mkFn9 :: forall a b c d e f g h i j. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) -> Fn9 a b c d e f g h i j - --- | Create a function of ten arguments from a curried function -foreign import mkFn10 :: forall a b c d e f g h i j k. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) -> Fn10 a b c d e f g h i j k - --- | Apply a function of no arguments -foreign import runFn0 :: forall a. Fn0 a -> a - --- | Apply a function of one argument -foreign import runFn1 :: forall a b. Fn1 a b -> a -> b - --- | Apply a function of two arguments -foreign import runFn2 :: forall a b c. Fn2 a b c -> a -> b -> c - --- | Apply a function of three arguments -foreign import runFn3 :: forall a b c d. Fn3 a b c d -> a -> b -> c -> d - --- | Apply a function of four arguments -foreign import runFn4 :: forall a b c d e. Fn4 a b c d e -> a -> b -> c -> d -> e - --- | Apply a function of five arguments -foreign import runFn5 :: forall a b c d e f. Fn5 a b c d e f -> a -> b -> c -> d -> e -> f - --- | Apply a function of six arguments -foreign import runFn6 :: forall a b c d e f g. Fn6 a b c d e f g -> a -> b -> c -> d -> e -> f -> g - --- | Apply a function of seven arguments -foreign import runFn7 :: forall a b c d e f g h. Fn7 a b c d e f g h -> a -> b -> c -> d -> e -> f -> g -> h - --- | Apply a function of eight arguments -foreign import runFn8 :: forall a b c d e f g h i. Fn8 a b c d e f g h i -> a -> b -> c -> d -> e -> f -> g -> h -> i - --- | Apply a function of nine arguments -foreign import runFn9 :: forall a b c d e f g h i j. Fn9 a b c d e f g h i j -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j - --- | Apply a function of ten arguments -foreign import runFn10 :: forall a b c d e f g h i j k. Fn10 a b c d e f g h i j k -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k diff --git a/tests/support/flattened/Prelude.js b/tests/support/flattened/Prelude.js deleted file mode 100644 --- a/tests/support/flattened/Prelude.js +++ /dev/null @@ -1,228 +0,0 @@ -/* global exports */ -"use strict"; - -// module Prelude - -//- Functor -------------------------------------------------------------------- - -exports.arrayMap = function (f) { - return function (arr) { - var l = arr.length; - var result = new Array(l); - for (var i = 0; i < l; i++) { - result[i] = f(arr[i]); - } - return result; - }; -}; - -//- Bind ----------------------------------------------------------------------- - -exports.arrayBind = function (arr) { - return function (f) { - var result = []; - for (var i = 0, l = arr.length; i < l; i++) { - Array.prototype.push.apply(result, f(arr[i])); - } - return result; - }; -}; - -//- Monoid --------------------------------------------------------------------- - -exports.concatString = function (s1) { - return function (s2) { - return s1 + s2; - }; -}; - -exports.concatArray = function (xs) { - return function (ys) { - return xs.concat(ys); - }; -}; - -//- Semiring ------------------------------------------------------------------- - -exports.intAdd = function (x) { - return function (y) { - /* jshint bitwise: false */ - return x + y | 0; - }; -}; - -exports.intMul = function (x) { - return function (y) { - /* jshint bitwise: false */ - return x * y | 0; - }; -}; - -exports.numAdd = function (n1) { - return function (n2) { - return n1 + n2; - }; -}; - -exports.numMul = function (n1) { - return function (n2) { - return n1 * n2; - }; -}; - -//- ModuloSemiring ------------------------------------------------------------- - -exports.intDiv = function (x) { - return function (y) { - /* jshint bitwise: false */ - return x / y | 0; - }; -}; - -exports.intMod = function (x) { - return function (y) { - return x % y; - }; -}; - -exports.numDiv = function (n1) { - return function (n2) { - return n1 / n2; - }; -}; - -//- Ring ----------------------------------------------------------------------- - -exports.intSub = function (x) { - return function (y) { - /* jshint bitwise: false */ - return x - y | 0; - }; -}; - -exports.numSub = function (n1) { - return function (n2) { - return n1 - n2; - }; -}; - -//- Eq ------------------------------------------------------------------------- - -exports.refEq = function (r1) { - return function (r2) { - return r1 === r2; - }; -}; - -exports.refIneq = function (r1) { - return function (r2) { - return r1 !== r2; - }; -}; - -exports.eqArrayImpl = function (f) { - return function (xs) { - return function (ys) { - if (xs.length !== ys.length) return false; - for (var i = 0; i < xs.length; i++) { - if (!f(xs[i])(ys[i])) return false; - } - return true; - }; - }; -}; - -exports.ordArrayImpl = function (f) { - return function (xs) { - return function (ys) { - var i = 0; - var xlen = xs.length; - var ylen = ys.length; - while (i < xlen && i < ylen) { - var x = xs[i]; - var y = ys[i]; - var o = f(x)(y); - if (o !== 0) { - return o; - } - i++; - } - if (xlen === ylen) { - return 0; - } else if (xlen > ylen) { - return -1; - } else { - return 1; - } - }; - }; -}; - -//- Ord ------------------------------------------------------------------------ - -exports.unsafeCompareImpl = function (lt) { - return function (eq) { - return function (gt) { - return function (x) { - return function (y) { - return x < y ? lt : x > y ? gt : eq; - }; - }; - }; - }; -}; - -//- Bounded -------------------------------------------------------------------- - -exports.topInt = 2147483647; -exports.bottomInt = -2147483648; - -exports.topChar = String.fromCharCode(65535); -exports.bottomChar = String.fromCharCode(0); - -//- BooleanAlgebra ------------------------------------------------------------- - -exports.boolOr = function (b1) { - return function (b2) { - return b1 || b2; - }; -}; - -exports.boolAnd = function (b1) { - return function (b2) { - return b1 && b2; - }; -}; - -exports.boolNot = function (b) { - return !b; -}; - -//- Show ----------------------------------------------------------------------- - -exports.showIntImpl = function (n) { - return n.toString(); -}; - -exports.showNumberImpl = function (n) { - /* jshint bitwise: false */ - return n === (n | 0) ? n + ".0" : n.toString(); -}; - -exports.showCharImpl = function (c) { - return c === "'" ? "'\\''" : "'" + c + "'"; -}; - -exports.showStringImpl = function (s) { - return JSON.stringify(s); -}; - -exports.showArrayImpl = function (f) { - return function (xs) { - var ss = []; - for (var i = 0, l = xs.length; i < l; i++) { - ss[i] = f(xs[i]); - } - return "[" + ss.join(",") + "]"; - }; -}; diff --git a/tests/support/flattened/Prelude.purs b/tests/support/flattened/Prelude.purs deleted file mode 100644 --- a/tests/support/flattened/Prelude.purs +++ /dev/null @@ -1,872 +0,0 @@ -module Prelude - ( Unit(), unit - , ($), (#) - , flip - , const - , asTypeOf - , otherwise - , Semigroupoid, compose, (<<<), (>>>) - , Category, id - , Functor, map, (<$>), (<#>), void - , Apply, apply, (<*>) - , Applicative, pure, liftA1 - , Bind, bind, (>>=) - , Monad, return, liftM1, ap - , Semigroup, append, (<>), (++) - , Semiring, add, zero, mul, one, (+), (*) - , ModuloSemiring, div, mod, (/) - , Ring, sub, negate, (-) - , Num - , DivisionRing - , Eq, eq, (==), (/=) - , Ordering(..), Ord, compare, (<), (>), (<=), (>=) - , unsafeCompare - , Bounded, top, bottom - , BoundedOrd - , BooleanAlgebra, conj, disj, not, (&&), (||) - , Show, show - ) where - --- | The `Unit` type has a single inhabitant, called `unit`. It represents --- | values with no computational content. --- | --- | `Unit` is often used, wrapped in a monadic type constructor, as the --- | return type of a computation where only --- | the _effects_ are important. -newtype Unit = Unit {} - --- | `unit` is the sole inhabitant of the `Unit` type. -unit :: Unit -unit = Unit {} - -infixr 0 $ -infixl 1 # - --- | Applies a function to its argument. --- | --- | ```purescript --- | length $ groupBy productCategory $ filter isInStock $ products --- | ``` --- | --- | is equivalent to: --- | --- | ```purescript --- | length (groupBy productCategory (filter isInStock products)) --- | ``` --- | --- | `($)` is different from [`(#)`](#-2) because it is right-infix instead of --- | left: `a $ b $ c $ d x = a $ (b $ (c $ (d $ x))) = a (b (c (d x)))` -($) :: forall a b. (a -> b) -> a -> b -($) f x = f x - --- | Applies an argument to a function. --- | --- | ```purescript --- | products # filter isInStock # groupBy productCategory # length --- | ``` --- | --- | is equivalent to: --- | --- | ```purescript --- | length (groupBy productCategory (filter isInStock products)) --- | ``` --- | --- | `(#)` 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 --- | flip const 1 2 = const 2 1 = 2 --- | ``` -flip :: forall a b c. (a -> b -> c) -> b -> a -> c -flip f b a = f a b - --- | Returns its first argument and ignores its second. --- | --- | ```purescript --- | const 1 "hello" = 1 --- | ``` -const :: forall a b. a -> b -> a -const a _ = a - --- | This function returns its first argument, and can be used to assert type --- | equalities. This can be useful when types are otherwise ambiguous. --- | --- | ```purescript --- | main = print $ [] `asTypeOf` [0] --- | ``` --- | --- | If instead, we had written `main = print []`, the type of the argument --- | `[]` would have been ambiguous, resulting in a compile-time error. -asTypeOf :: forall a. a -> a -> a -asTypeOf x _ = x - --- | An alias for `true`, which can be useful in guard clauses: --- | --- | ```purescript --- | max x y | x >= y = x --- | | otherwise = y --- | ``` -otherwise :: Boolean -otherwise = true - --- | 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 - compose :: forall b c d. a c d -> a b c -> a b d - -instance semigroupoidFn :: Semigroupoid (->) where - compose f g x = f (g x) - -infixr 9 >>> -infixr 9 <<< - --- | `(<<<)` is an alias for `compose`. -(<<<) :: forall a b c d. (Semigroupoid a) => a c d -> a b c -> a b d -(<<<) = compose - --- | Forwards composition, or `(<<<)` with its arguments reversed. -(>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d -(>>>) = flip compose - --- | `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 categoryFn :: Category (->) where - id x = x - --- | 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. --- | --- | Instances must satisfy the following laws: --- | --- | - Identity: `(<$>) id = id` --- | - Composition: `(<$>) (f <<< g) = (f <$>) <<< (g <$>)` -class Functor f where - map :: forall a b. (a -> b) -> f a -> f b - -instance functorFn :: Functor ((->) r) where - map = compose - -instance functorArray :: Functor Array where - map = arrayMap - -foreign import arrayMap :: forall a b. (a -> b) -> Array a -> Array b - -infixl 4 <$> -infixl 1 <#> - --- | `(<$>)` is an alias for `map` -(<$>) :: forall f a b. (Functor f) => (a -> b) -> f a -> f b -(<$>) = map - --- | `(<#>)` is `(<$>)` with its arguments reversed. For example: --- | --- | ```purescript --- | [1, 2, 3] <#> \n -> n * n --- | ``` -(<#>) :: 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. --- | --- | `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 --- | print n --- | print (n * n) --- | ``` -void :: forall f a. (Functor f) => f a -> f Unit -void fa = const unit <$> fa - --- | 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: --- | --- | ```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`. --- | --- | Instances must satisfy the following law in addition to the `Functor` --- | laws: --- | --- | - Associative composition: `(<<<) <$> f <*> g <*> h = f <*> (g <*> h)` --- | --- | Formally, `Apply` represents a strong lax semi-monoidal endofunctor. -class (Functor f) <= Apply f where - apply :: forall a b. f (a -> b) -> f a -> f b - -instance applyFn :: Apply ((->) r) where - apply f g x = f x (g x) - -instance applyArray :: Apply Array where - apply = ap - -infixl 4 <*> - --- | `(<*>)` is an alias for `apply`. -(<*>) :: forall f a b. (Apply f) => f (a -> b) -> f a -> f b -(<*>) = apply - --- | 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. --- | --- | 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 - -instance applicativeFn :: Applicative ((->) r) where - pure = const - -instance applicativeArray :: Applicative Array where - pure x = [x] - --- | `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: --- | --- | ```purescript --- | instance functorF :: Functor F where --- | map = liftA1 --- | ``` -liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b -liftA1 f a = pure f <*> a - --- | 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: --- | --- | ```purescript --- | x >>= f = do y <- x --- | f y --- | ``` --- | --- | where the function argument of `f` is given the name `y`. --- | --- | Instances must satisfy the following law in addition to the `Apply` --- | laws: --- | --- | - Associativity: `(x >>= f) >>= g = x >>= (\k => f k >>= g)` --- | --- | Associativity tells us that we can regroup operations which use `do` --- | notation so that we can unambiguously write, for example: --- | --- | ```purescript --- | do x <- m1 --- | y <- m2 x --- | m3 x y --- | ``` -class (Apply m) <= Bind m where - bind :: forall a b. m a -> (a -> m b) -> m b - -instance bindFn :: Bind ((->) r) where - bind m f x = f (m x) x - -instance bindArray :: Bind Array where - bind = arrayBind - -foreign import arrayBind :: forall a b. Array a -> (a -> Array b) -> Array b - -infixl 1 >>= - --- | `(>>=)` is an alias for `bind`. -(>>=) :: forall m a b. (Bind m) => m a -> (a -> m b) -> m b -(>>=) = bind - --- | The `Monad` type class combines the operations of the `Bind` and --- | `Applicative` type classes. Therefore, `Monad` instances represent type --- | constructors which support sequential composition, and also lifting of --- | functions of arbitrary arity. --- | --- | Instances must satisfy the following laws in addition to the --- | `Applicative` and `Bind` laws: --- | --- | - Left Identity: `pure x >>= f = f x` --- | - Right Identity: `x >>= pure = x` -class (Applicative m, Bind m) <= Monad m - -instance monadFn :: Monad ((->) r) -instance monadArray :: Monad Array - --- | `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: --- | --- | ```purescript --- | instance functorF :: Functor F where --- | map = liftM1 --- | ``` -liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b -liftM1 f a = do - 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` can therefore be used to write [`Apply`](#apply) instances as --- | follows: --- | --- | ```purescript --- | instance applyF :: Apply F where --- | apply = ap --- | ``` -ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b -ap f a = do - f' <- f - a' <- a - return (f' a') - --- | 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 - append :: a -> a -> a - -infixr 5 <> -infixr 5 ++ - --- | `(<>)` is an alias for `append`. -(<>) :: forall s. (Semigroup s) => s -> s -> s -(<>) = append - --- | `(++)` is an alternative alias for `append`. -(++) :: forall s. (Semigroup s) => s -> s -> s -(++) = append - -instance semigroupString :: Semigroup String where - append = concatString - -instance semigroupUnit :: Semigroup Unit where - append _ _ = unit - -instance semigroupFn :: (Semigroup s') => Semigroup (s -> s') where - append f g = \x -> f x <> g x - -instance semigroupOrdering :: Semigroup Ordering where - append LT _ = LT - append GT _ = GT - append EQ y = y - -instance semigroupArray :: Semigroup (Array a) where - append = concatArray - -foreign import concatString :: String -> String -> String -foreign import concatArray :: forall a. Array a -> Array a -> Array 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 - add :: a -> a -> a - zero :: a - mul :: a -> a -> a - one :: a - -instance semiringInt :: Semiring Int where - add = intAdd - zero = 0 - mul = intMul - one = 1 - -instance semiringNumber :: Semiring Number where - add = numAdd - zero = 0.0 - mul = numMul - one = 1.0 - -instance semiringUnit :: Semiring Unit where - add _ _ = unit - zero = unit - mul _ _ = unit - one = unit - -infixl 6 + -infixl 7 * - --- | `(+)` is an alias for `add`. -(+) :: forall a. (Semiring a) => a -> a -> a -(+) = add - --- | `(*)` is an alias for `mul`. -(*) :: forall a. (Semiring a) => a -> a -> a -(*) = mul - -foreign import intAdd :: Int -> Int -> Int -foreign import intMul :: Int -> Int -> Int -foreign import numAdd :: Number -> Number -> Number -foreign import numMul :: Number -> Number -> Number - --- | The `Ring` class is for types that support addition, multiplication, --- | and subtraction operations. --- | --- | Instances must satisfy the following law in addition to the `Semiring` --- | laws: --- | --- | - Additive inverse: `a - a = (zero - a) + a = zero` -class (Semiring a) <= Ring a where - sub :: a -> a -> a - -instance ringInt :: Ring Int where - sub = intSub - -instance ringNumber :: Ring Number where - sub = numSub - -instance ringUnit :: Ring Unit where - sub _ _ = unit - -infixl 6 - - --- | `(-)` is an alias for `sub`. -(-) :: forall a. (Ring a) => a -> a -> a -(-) = sub - --- | `negate x` can be used as a shorthand for `zero - x`. -negate :: forall a. (Ring a) => a -> a -negate a = zero - a - -foreign import intSub :: Int -> Int -> Int -foreign import numSub :: Number -> Number -> Number - --- | The `ModuloSemiring` class is for types that support addition, --- | multiplication, division, and modulo (division remainder) operations. --- | --- | 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 - div :: a -> a -> a - mod :: a -> a -> a - -instance moduloSemiringInt :: ModuloSemiring Int where - div = intDiv - mod = intMod - -instance moduloSemiringNumber :: ModuloSemiring Number where - div = numDiv - mod _ _ = 0.0 - -instance moduloSemiringUnit :: ModuloSemiring Unit where - div _ _ = unit - mod _ _ = unit - -infixl 7 / - --- | `(/)` is an alias for `div`. -(/) :: forall a. (ModuloSemiring a) => a -> a -> a -(/) = div - -foreign import intDiv :: Int -> Int -> Int -foreign import numDiv :: Number -> Number -> Number -foreign import intMod :: Int -> Int -> Int - --- | 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 - -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 - --- | The `Eq` type class represents types which support decidable equality. --- | --- | `Eq` instances should satisfy the following laws: --- | --- | - Reflexivity: `x == x = true` --- | - Symmetry: `x == y = y == x` --- | - Transitivity: if `x == y` and `y == z` then `x == z` -class Eq a where - eq :: a -> a -> Boolean - -infix 4 == -infix 4 /= - --- | `(==)` is an alias for `eq`. Tests whether one value is equal to another. -(==) :: forall a. (Eq a) => a -> a -> Boolean -(==) = eq - --- | `(/=)` tests whether one value is _not equal_ to another. Shorthand for --- | `not (x == y)`. -(/=) :: forall a. (Eq a) => a -> a -> Boolean -(/=) x y = not (x == y) - -instance eqBoolean :: Eq Boolean where - eq = refEq - -instance eqInt :: Eq Int where - eq = refEq - -instance eqNumber :: Eq Number where - eq = refEq - -instance eqChar :: Eq Char where - eq = refEq - -instance eqString :: Eq String where - eq = refEq - -instance eqUnit :: Eq Unit where - eq _ _ = true - -instance eqArray :: (Eq a) => Eq (Array a) where - eq = eqArrayImpl (==) - -instance eqOrdering :: Eq Ordering where - eq LT LT = true - eq GT GT = true - eq EQ EQ = true - eq _ _ = false - -foreign import refEq :: forall a. a -> a -> Boolean -foreign import refIneq :: forall a. a -> a -> Boolean -foreign import eqArrayImpl :: forall a. (a -> a -> Boolean) -> Array a -> Array a -> Boolean - --- | 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_ the second. -data Ordering = LT | GT | EQ - --- | The `Ord` type class represents types which support comparisons with a --- | _total order_. --- | --- | `Ord` instances should satisfy the laws of total orderings: --- | --- | - 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 = unsafeCompare - -instance ordInt :: Ord Int where - compare = unsafeCompare - -instance ordNumber :: Ord Number where - compare = unsafeCompare - -instance ordString :: Ord String where - compare = unsafeCompare - -instance ordChar :: Ord Char where - compare = unsafeCompare - -instance ordUnit :: Ord Unit where - compare _ _ = EQ - -instance ordArray :: (Ord a) => Ord (Array a) where - compare xs ys = compare 0 $ ordArrayImpl (\x y -> case compare x y of - EQ -> 0 - LT -> 1 - GT -> -1) xs ys - -foreign import ordArrayImpl :: forall a. (a -> a -> Int) -> Array a -> Array a -> Int - -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 -(<) a1 a2 = case a1 `compare` a2 of - LT -> true - _ -> false - --- | 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 - --- | 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 - --- | 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 :: forall a. Ordering -> Ordering -> Ordering -> a -> a -> Ordering - --- | The `Bounded` type class represents types that are finite. --- | --- | Although there are no "internal" laws for `Bounded`, every value of `a` --- | should be considered less than or equal to `top` by some means, and greater --- | than or equal to `bottom`. --- | --- | The lack of explicit `Ord` constraint allows flexibility in the use of --- | `Bounded` so it can apply to total and partially ordered sets, boolean --- | algebras, etc. -class 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 - -instance boundedInt :: Bounded Int where - top = topInt - bottom = bottomInt - --- | Characters fall within the Unicode range. -instance boundedChar :: Bounded Char where - top = topChar - bottom = bottomChar - -instance boundedFn :: (Bounded b) => Bounded (a -> b) where - top _ = top - bottom _ = bottom - -foreign import topInt :: Int -foreign import bottomInt :: Int - -foreign import topChar :: Char -foreign import bottomChar :: Char - --- | The `BoundedOrd` type class represents totally ordered finite data types. --- | --- | Instances should satisfy the following law in addition to the `Ord` laws: --- | --- | - Ordering: `bottom <= a <= top` -class (Bounded a, Ord a) <= BoundedOrd a - -instance boundedOrdBoolean :: BoundedOrd Boolean where -instance boundedOrdUnit :: BoundedOrd Unit where -instance boundedOrdOrdering :: BoundedOrd Ordering where -instance boundedOrdInt :: BoundedOrd Int where -instance boundedOrdChar :: BoundedOrd Char where - --- | The `BooleanAlgebra` type class represents types that behave like boolean --- | values. --- | --- | Instances should satisfy the following laws in addition to the `Bounded` --- | laws: --- | --- | - Associativity: --- | - `a || (b || c) = (a || b) || c` --- | - `a && (b && c) = (a && b) && c` --- | - Commutativity: --- | - `a || b = b || a` --- | - `a && b = b && a` --- | - Distributivity: --- | - `a && (b || c) = (a && b) || (a && c)` --- | - `a || (b && c) = (a || b) && (a || c)` --- | - Identity: --- | - `a || bottom = a` --- | - `a && top = a` --- | - Idempotent: --- | - `a || a = a` --- | - `a && a = a` --- | - Absorption: --- | - `a || (a && b) = a` --- | - `a && (a || b) = a` --- | - Annhiliation: --- | - `a || top = top` --- | - Complementation: --- | - `a && not a = bottom` --- | - `a || not a = top` -class (Bounded a) <= BooleanAlgebra a where - conj :: a -> a -> a - disj :: a -> a -> a - not :: a -> a - -instance booleanAlgebraBoolean :: BooleanAlgebra Boolean where - conj = boolAnd - disj = boolOr - not = boolNot - -instance booleanAlgebraUnit :: BooleanAlgebra Unit where - conj _ _ = unit - disj _ _ = unit - not _ = unit - -instance booleanAlgebraFn :: (BooleanAlgebra b) => BooleanAlgebra (a -> b) where - conj fx fy a = fx a `conj` fy a - disj fx fy a = fx a `disj` fy a - not fx a = not (fx a) - -infixr 3 && -infixr 2 || - --- | `(&&)` is an alias for `conj`. -(&&) :: forall a. (BooleanAlgebra a) => a -> a -> a -(&&) = conj - --- | `(||)` is an alias for `disj`. -(||) :: forall a. (BooleanAlgebra a) => a -> a -> a -(||) = disj - -foreign import boolOr :: Boolean -> Boolean -> Boolean -foreign import boolAnd :: Boolean -> Boolean -> Boolean -foreign import boolNot :: Boolean -> Boolean - --- | The `Show` type class represents those types which can be converted into --- | a human-readable `String` representation. --- | --- | While not required, it is recommended that for any expression `x`, the --- | string `show x` be executable PureScript code which evaluates to the same --- | value as the expression `x`. -class Show a where - show :: a -> String - -instance showBoolean :: Show Boolean where - show true = "true" - show false = "false" - -instance showInt :: Show Int where - show = showIntImpl - -instance showNumber :: Show Number where - show = showNumberImpl - -instance showChar :: Show Char where - show = showCharImpl - -instance showString :: Show String where - show = showStringImpl - -instance showUnit :: Show Unit where - show _ = "unit" - -instance showArray :: (Show a) => Show (Array a) where - show = showArrayImpl show - -instance showOrdering :: Show Ordering where - show LT = "LT" - show GT = "GT" - show EQ = "EQ" - -foreign import showIntImpl :: Int -> String -foreign import showNumberImpl :: Number -> String -foreign import showCharImpl :: Char -> String -foreign import showStringImpl :: String -> String -foreign import showArrayImpl :: forall a. (a -> String) -> Array a -> String diff --git a/tests/support/flattened/Test-Assert.js b/tests/support/flattened/Test-Assert.js deleted file mode 100644 --- a/tests/support/flattened/Test-Assert.js +++ /dev/null @@ -1,27 +0,0 @@ -/* global exports */ -"use strict"; - -// module Test.Assert - -exports["assert'"] = function (message) { - return function (success) { - return function () { - if (!success) throw new Error(message); - return {}; - }; - }; -}; - -exports.checkThrows = function (fn) { - return function () { - try { - fn(); - return false; - } catch (e) { - if (e instanceof Error) return true; - var err = new Error("Threw something other than an Error"); - err.something = e; - throw err; - } - }; -}; diff --git a/tests/support/flattened/Test-Assert.purs b/tests/support/flattened/Test-Assert.purs deleted file mode 100644 --- a/tests/support/flattened/Test-Assert.purs +++ /dev/null @@ -1,46 +0,0 @@ -module Test.Assert - ( assert' - , assert - , assertThrows - , assertThrows' - , ASSERT() - ) where - -import Control.Monad.Eff (Eff()) -import Prelude - --- | Assertion effect type. -foreign import data ASSERT :: ! - --- | Throws a runtime exception with message "Assertion failed" when the boolean --- | value is false. -assert :: forall e. Boolean -> Eff (assert :: ASSERT | e) Unit -assert = assert' "Assertion failed" - --- | Throws a runtime exception with the specified message when the boolean --- | value is false. -foreign import assert' :: forall e. String -> Boolean -> Eff (assert :: ASSERT | e) Unit - --- | Throws a runtime exception with message "Assertion failed: An error should --- | have been thrown", unless the argument throws an exception when evaluated. --- | --- | This function is specifically for testing unsafe pure code; for example, --- | to make sure that an exception is thrown if a precondition is not --- | satisfied. Functions which use `Eff (err :: EXCEPTION | eff) a` can be --- | tested with `catchException` instead. -assertThrows :: forall e a. (Unit -> a) -> Eff (assert :: ASSERT | e) Unit -assertThrows = assertThrows' "Assertion failed: An error should have been thrown" - --- | Throws a runtime exception with the specified message, unless the argument --- | throws an exception when evaluated. --- | --- | This function is specifically for testing unsafe pure code; for example, --- | to make sure that an exception is thrown if a precondition is not --- | satisfied. Functions which use `Eff (err :: EXCEPTION | eff) a` can be --- | tested with `catchException` instead. -assertThrows' :: forall e a. String -> (Unit -> a) -> Eff (assert :: ASSERT | e) Unit -assertThrows' msg fn = - checkThrows fn >>= assert' msg - - -foreign import checkThrows :: forall e a. (Unit -> a) -> Eff (assert :: ASSERT | e) Boolean diff --git a/tests/support/package.json b/tests/support/package.json --- a/tests/support/package.json +++ b/tests/support/package.json @@ -2,6 +2,7 @@ "private": true, "dependencies": { "bower": "^1.4.1", - "glob": "^5.0.14" + "glob": "^5.0.14", + "rimraf": "^2.5.2" } } diff --git a/tests/support/prelude/LICENSE b/tests/support/prelude/LICENSE deleted file mode 100644 --- a/tests/support/prelude/LICENSE +++ /dev/null @@ -1,20 +0,0 @@ -The MIT License (MIT) - -Copyright (c) 2015 PureScript - -Permission is hereby granted, free of charge, to any person obtaining a copy of -this software and associated documentation files (the "Software"), to deal in -the Software without restriction, including without limitation the rights to -use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of -the Software, and to permit persons to whom the Software is furnished to do so, -subject to the following conditions: - -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS -FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR -COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER -IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/tests/support/prelude/bower.json b/tests/support/prelude/bower.json deleted file mode 100644 --- a/tests/support/prelude/bower.json +++ /dev/null @@ -1,23 +0,0 @@ -{ - "name": "purescript-prelude", - "homepage": "https://github.com/purescript/purescript-prelude", - "description": "The PureScript Prelude", - "keywords": [ - "purescript" - ], - "license": "MIT", - "repository": { - "type": "git", - "url": "git://github.com/purescript/purescript-prelude.git" - }, - "ignore": [ - "**/.*", - "bower_components", - "node_modules", - "output", - "test", - "bower.json", - "gulpfile.js", - "package.json" - ] -} diff --git a/tests/support/prelude/src/Prelude.js b/tests/support/prelude/src/Prelude.js deleted file mode 100644 --- a/tests/support/prelude/src/Prelude.js +++ /dev/null @@ -1,228 +0,0 @@ -/* global exports */ -"use strict"; - -// module Prelude - -//- Functor -------------------------------------------------------------------- - -exports.arrayMap = function (f) { - return function (arr) { - var l = arr.length; - var result = new Array(l); - for (var i = 0; i < l; i++) { - result[i] = f(arr[i]); - } - return result; - }; -}; - -//- Bind ----------------------------------------------------------------------- - -exports.arrayBind = function (arr) { - return function (f) { - var result = []; - for (var i = 0, l = arr.length; i < l; i++) { - Array.prototype.push.apply(result, f(arr[i])); - } - return result; - }; -}; - -//- Monoid --------------------------------------------------------------------- - -exports.concatString = function (s1) { - return function (s2) { - return s1 + s2; - }; -}; - -exports.concatArray = function (xs) { - return function (ys) { - return xs.concat(ys); - }; -}; - -//- Semiring ------------------------------------------------------------------- - -exports.intAdd = function (x) { - return function (y) { - /* jshint bitwise: false */ - return x + y | 0; - }; -}; - -exports.intMul = function (x) { - return function (y) { - /* jshint bitwise: false */ - return x * y | 0; - }; -}; - -exports.numAdd = function (n1) { - return function (n2) { - return n1 + n2; - }; -}; - -exports.numMul = function (n1) { - return function (n2) { - return n1 * n2; - }; -}; - -//- ModuloSemiring ------------------------------------------------------------- - -exports.intDiv = function (x) { - return function (y) { - /* jshint bitwise: false */ - return x / y | 0; - }; -}; - -exports.intMod = function (x) { - return function (y) { - return x % y; - }; -}; - -exports.numDiv = function (n1) { - return function (n2) { - return n1 / n2; - }; -}; - -//- Ring ----------------------------------------------------------------------- - -exports.intSub = function (x) { - return function (y) { - /* jshint bitwise: false */ - return x - y | 0; - }; -}; - -exports.numSub = function (n1) { - return function (n2) { - return n1 - n2; - }; -}; - -//- Eq ------------------------------------------------------------------------- - -exports.refEq = function (r1) { - return function (r2) { - return r1 === r2; - }; -}; - -exports.refIneq = function (r1) { - return function (r2) { - return r1 !== r2; - }; -}; - -exports.eqArrayImpl = function (f) { - return function (xs) { - return function (ys) { - if (xs.length !== ys.length) return false; - for (var i = 0; i < xs.length; i++) { - if (!f(xs[i])(ys[i])) return false; - } - return true; - }; - }; -}; - -exports.ordArrayImpl = function (f) { - return function (xs) { - return function (ys) { - var i = 0; - var xlen = xs.length; - var ylen = ys.length; - while (i < xlen && i < ylen) { - var x = xs[i]; - var y = ys[i]; - var o = f(x)(y); - if (o !== 0) { - return o; - } - i++; - } - if (xlen === ylen) { - return 0; - } else if (xlen > ylen) { - return -1; - } else { - return 1; - } - }; - }; -}; - -//- Ord ------------------------------------------------------------------------ - -exports.unsafeCompareImpl = function (lt) { - return function (eq) { - return function (gt) { - return function (x) { - return function (y) { - return x < y ? lt : x > y ? gt : eq; - }; - }; - }; - }; -}; - -//- Bounded -------------------------------------------------------------------- - -exports.topInt = 2147483647; -exports.bottomInt = -2147483648; - -exports.topChar = String.fromCharCode(65535); -exports.bottomChar = String.fromCharCode(0); - -//- BooleanAlgebra ------------------------------------------------------------- - -exports.boolOr = function (b1) { - return function (b2) { - return b1 || b2; - }; -}; - -exports.boolAnd = function (b1) { - return function (b2) { - return b1 && b2; - }; -}; - -exports.boolNot = function (b) { - return !b; -}; - -//- Show ----------------------------------------------------------------------- - -exports.showIntImpl = function (n) { - return n.toString(); -}; - -exports.showNumberImpl = function (n) { - /* jshint bitwise: false */ - return n === (n | 0) ? n + ".0" : n.toString(); -}; - -exports.showCharImpl = function (c) { - return c === "'" ? "'\\''" : "'" + c + "'"; -}; - -exports.showStringImpl = function (s) { - return JSON.stringify(s); -}; - -exports.showArrayImpl = function (f) { - return function (xs) { - var ss = []; - for (var i = 0, l = xs.length; i < l; i++) { - ss[i] = f(xs[i]); - } - return "[" + ss.join(",") + "]"; - }; -}; diff --git a/tests/support/prelude/src/Prelude.purs b/tests/support/prelude/src/Prelude.purs deleted file mode 100644 --- a/tests/support/prelude/src/Prelude.purs +++ /dev/null @@ -1,872 +0,0 @@ -module Prelude - ( Unit(), unit - , ($), (#) - , flip - , const - , asTypeOf - , otherwise - , Semigroupoid, compose, (<<<), (>>>) - , Category, id - , Functor, map, (<$>), (<#>), void - , Apply, apply, (<*>) - , Applicative, pure, liftA1 - , Bind, bind, (>>=) - , Monad, return, liftM1, ap - , Semigroup, append, (<>), (++) - , Semiring, add, zero, mul, one, (+), (*) - , ModuloSemiring, div, mod, (/) - , Ring, sub, negate, (-) - , Num - , DivisionRing - , Eq, eq, (==), (/=) - , Ordering(..), Ord, compare, (<), (>), (<=), (>=) - , unsafeCompare - , Bounded, top, bottom - , BoundedOrd - , BooleanAlgebra, conj, disj, not, (&&), (||) - , Show, show - ) where - --- | The `Unit` type has a single inhabitant, called `unit`. It represents --- | values with no computational content. --- | --- | `Unit` is often used, wrapped in a monadic type constructor, as the --- | return type of a computation where only --- | the _effects_ are important. -newtype Unit = Unit {} - --- | `unit` is the sole inhabitant of the `Unit` type. -unit :: Unit -unit = Unit {} - -infixr 0 $ -infixl 1 # - --- | Applies a function to its argument. --- | --- | ```purescript --- | length $ groupBy productCategory $ filter isInStock $ products --- | ``` --- | --- | is equivalent to: --- | --- | ```purescript --- | length (groupBy productCategory (filter isInStock products)) --- | ``` --- | --- | `($)` is different from [`(#)`](#-2) because it is right-infix instead of --- | left: `a $ b $ c $ d x = a $ (b $ (c $ (d $ x))) = a (b (c (d x)))` -($) :: forall a b. (a -> b) -> a -> b -($) f x = f x - --- | Applies an argument to a function. --- | --- | ```purescript --- | products # filter isInStock # groupBy productCategory # length --- | ``` --- | --- | is equivalent to: --- | --- | ```purescript --- | length (groupBy productCategory (filter isInStock products)) --- | ``` --- | --- | `(#)` 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 --- | flip const 1 2 = const 2 1 = 2 --- | ``` -flip :: forall a b c. (a -> b -> c) -> b -> a -> c -flip f b a = f a b - --- | Returns its first argument and ignores its second. --- | --- | ```purescript --- | const 1 "hello" = 1 --- | ``` -const :: forall a b. a -> b -> a -const a _ = a - --- | This function returns its first argument, and can be used to assert type --- | equalities. This can be useful when types are otherwise ambiguous. --- | --- | ```purescript --- | main = print $ [] `asTypeOf` [0] --- | ``` --- | --- | If instead, we had written `main = print []`, the type of the argument --- | `[]` would have been ambiguous, resulting in a compile-time error. -asTypeOf :: forall a. a -> a -> a -asTypeOf x _ = x - --- | An alias for `true`, which can be useful in guard clauses: --- | --- | ```purescript --- | max x y | x >= y = x --- | | otherwise = y --- | ``` -otherwise :: Boolean -otherwise = true - --- | 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 - compose :: forall b c d. a c d -> a b c -> a b d - -instance semigroupoidFn :: Semigroupoid (->) where - compose f g x = f (g x) - -infixr 9 >>> -infixr 9 <<< - --- | `(<<<)` is an alias for `compose`. -(<<<) :: forall a b c d. (Semigroupoid a) => a c d -> a b c -> a b d -(<<<) = compose - --- | Forwards composition, or `(<<<)` with its arguments reversed. -(>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d -(>>>) = flip compose - --- | `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 categoryFn :: Category (->) where - id x = x - --- | 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. --- | --- | Instances must satisfy the following laws: --- | --- | - Identity: `(<$>) id = id` --- | - Composition: `(<$>) (f <<< g) = (f <$>) <<< (g <$>)` -class Functor f where - map :: forall a b. (a -> b) -> f a -> f b - -instance functorFn :: Functor ((->) r) where - map = compose - -instance functorArray :: Functor Array where - map = arrayMap - -foreign import arrayMap :: forall a b. (a -> b) -> Array a -> Array b - -infixl 4 <$> -infixl 1 <#> - --- | `(<$>)` is an alias for `map` -(<$>) :: forall f a b. (Functor f) => (a -> b) -> f a -> f b -(<$>) = map - --- | `(<#>)` is `(<$>)` with its arguments reversed. For example: --- | --- | ```purescript --- | [1, 2, 3] <#> \n -> n * n --- | ``` -(<#>) :: 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. --- | --- | `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 --- | print n --- | print (n * n) --- | ``` -void :: forall f a. (Functor f) => f a -> f Unit -void fa = const unit <$> fa - --- | 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: --- | --- | ```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`. --- | --- | Instances must satisfy the following law in addition to the `Functor` --- | laws: --- | --- | - Associative composition: `(<<<) <$> f <*> g <*> h = f <*> (g <*> h)` --- | --- | Formally, `Apply` represents a strong lax semi-monoidal endofunctor. -class (Functor f) <= Apply f where - apply :: forall a b. f (a -> b) -> f a -> f b - -instance applyFn :: Apply ((->) r) where - apply f g x = f x (g x) - -instance applyArray :: Apply Array where - apply = ap - -infixl 4 <*> - --- | `(<*>)` is an alias for `apply`. -(<*>) :: forall f a b. (Apply f) => f (a -> b) -> f a -> f b -(<*>) = apply - --- | 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. --- | --- | 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 - -instance applicativeFn :: Applicative ((->) r) where - pure = const - -instance applicativeArray :: Applicative Array where - pure x = [x] - --- | `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: --- | --- | ```purescript --- | instance functorF :: Functor F where --- | map = liftA1 --- | ``` -liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b -liftA1 f a = pure f <*> a - --- | 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: --- | --- | ```purescript --- | x >>= f = do y <- x --- | f y --- | ``` --- | --- | where the function argument of `f` is given the name `y`. --- | --- | Instances must satisfy the following law in addition to the `Apply` --- | laws: --- | --- | - Associativity: `(x >>= f) >>= g = x >>= (\k => f k >>= g)` --- | --- | Associativity tells us that we can regroup operations which use `do` --- | notation so that we can unambiguously write, for example: --- | --- | ```purescript --- | do x <- m1 --- | y <- m2 x --- | m3 x y --- | ``` -class (Apply m) <= Bind m where - bind :: forall a b. m a -> (a -> m b) -> m b - -instance bindFn :: Bind ((->) r) where - bind m f x = f (m x) x - -instance bindArray :: Bind Array where - bind = arrayBind - -foreign import arrayBind :: forall a b. Array a -> (a -> Array b) -> Array b - -infixl 1 >>= - --- | `(>>=)` is an alias for `bind`. -(>>=) :: forall m a b. (Bind m) => m a -> (a -> m b) -> m b -(>>=) = bind - --- | The `Monad` type class combines the operations of the `Bind` and --- | `Applicative` type classes. Therefore, `Monad` instances represent type --- | constructors which support sequential composition, and also lifting of --- | functions of arbitrary arity. --- | --- | Instances must satisfy the following laws in addition to the --- | `Applicative` and `Bind` laws: --- | --- | - Left Identity: `pure x >>= f = f x` --- | - Right Identity: `x >>= pure = x` -class (Applicative m, Bind m) <= Monad m - -instance monadFn :: Monad ((->) r) -instance monadArray :: Monad Array - --- | `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: --- | --- | ```purescript --- | instance functorF :: Functor F where --- | map = liftM1 --- | ``` -liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b -liftM1 f a = do - 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` can therefore be used to write [`Apply`](#apply) instances as --- | follows: --- | --- | ```purescript --- | instance applyF :: Apply F where --- | apply = ap --- | ``` -ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b -ap f a = do - f' <- f - a' <- a - return (f' a') - --- | 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 - append :: a -> a -> a - -infixr 5 <> -infixr 5 ++ - --- | `(<>)` is an alias for `append`. -(<>) :: forall s. (Semigroup s) => s -> s -> s -(<>) = append - --- | `(++)` is an alternative alias for `append`. -(++) :: forall s. (Semigroup s) => s -> s -> s -(++) = append - -instance semigroupString :: Semigroup String where - append = concatString - -instance semigroupUnit :: Semigroup Unit where - append _ _ = unit - -instance semigroupFn :: (Semigroup s') => Semigroup (s -> s') where - append f g = \x -> f x <> g x - -instance semigroupOrdering :: Semigroup Ordering where - append LT _ = LT - append GT _ = GT - append EQ y = y - -instance semigroupArray :: Semigroup (Array a) where - append = concatArray - -foreign import concatString :: String -> String -> String -foreign import concatArray :: forall a. Array a -> Array a -> Array 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 - add :: a -> a -> a - zero :: a - mul :: a -> a -> a - one :: a - -instance semiringInt :: Semiring Int where - add = intAdd - zero = 0 - mul = intMul - one = 1 - -instance semiringNumber :: Semiring Number where - add = numAdd - zero = 0.0 - mul = numMul - one = 1.0 - -instance semiringUnit :: Semiring Unit where - add _ _ = unit - zero = unit - mul _ _ = unit - one = unit - -infixl 6 + -infixl 7 * - --- | `(+)` is an alias for `add`. -(+) :: forall a. (Semiring a) => a -> a -> a -(+) = add - --- | `(*)` is an alias for `mul`. -(*) :: forall a. (Semiring a) => a -> a -> a -(*) = mul - -foreign import intAdd :: Int -> Int -> Int -foreign import intMul :: Int -> Int -> Int -foreign import numAdd :: Number -> Number -> Number -foreign import numMul :: Number -> Number -> Number - --- | The `Ring` class is for types that support addition, multiplication, --- | and subtraction operations. --- | --- | Instances must satisfy the following law in addition to the `Semiring` --- | laws: --- | --- | - Additive inverse: `a - a = (zero - a) + a = zero` -class (Semiring a) <= Ring a where - sub :: a -> a -> a - -instance ringInt :: Ring Int where - sub = intSub - -instance ringNumber :: Ring Number where - sub = numSub - -instance ringUnit :: Ring Unit where - sub _ _ = unit - -infixl 6 - - --- | `(-)` is an alias for `sub`. -(-) :: forall a. (Ring a) => a -> a -> a -(-) = sub - --- | `negate x` can be used as a shorthand for `zero - x`. -negate :: forall a. (Ring a) => a -> a -negate a = zero - a - -foreign import intSub :: Int -> Int -> Int -foreign import numSub :: Number -> Number -> Number - --- | The `ModuloSemiring` class is for types that support addition, --- | multiplication, division, and modulo (division remainder) operations. --- | --- | 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 - div :: a -> a -> a - mod :: a -> a -> a - -instance moduloSemiringInt :: ModuloSemiring Int where - div = intDiv - mod = intMod - -instance moduloSemiringNumber :: ModuloSemiring Number where - div = numDiv - mod _ _ = 0.0 - -instance moduloSemiringUnit :: ModuloSemiring Unit where - div _ _ = unit - mod _ _ = unit - -infixl 7 / - --- | `(/)` is an alias for `div`. -(/) :: forall a. (ModuloSemiring a) => a -> a -> a -(/) = div - -foreign import intDiv :: Int -> Int -> Int -foreign import numDiv :: Number -> Number -> Number -foreign import intMod :: Int -> Int -> Int - --- | 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 - -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 - --- | The `Eq` type class represents types which support decidable equality. --- | --- | `Eq` instances should satisfy the following laws: --- | --- | - Reflexivity: `x == x = true` --- | - Symmetry: `x == y = y == x` --- | - Transitivity: if `x == y` and `y == z` then `x == z` -class Eq a where - eq :: a -> a -> Boolean - -infix 4 == -infix 4 /= - --- | `(==)` is an alias for `eq`. Tests whether one value is equal to another. -(==) :: forall a. (Eq a) => a -> a -> Boolean -(==) = eq - --- | `(/=)` tests whether one value is _not equal_ to another. Shorthand for --- | `not (x == y)`. -(/=) :: forall a. (Eq a) => a -> a -> Boolean -(/=) x y = not (x == y) - -instance eqBoolean :: Eq Boolean where - eq = refEq - -instance eqInt :: Eq Int where - eq = refEq - -instance eqNumber :: Eq Number where - eq = refEq - -instance eqChar :: Eq Char where - eq = refEq - -instance eqString :: Eq String where - eq = refEq - -instance eqUnit :: Eq Unit where - eq _ _ = true - -instance eqArray :: (Eq a) => Eq (Array a) where - eq = eqArrayImpl (==) - -instance eqOrdering :: Eq Ordering where - eq LT LT = true - eq GT GT = true - eq EQ EQ = true - eq _ _ = false - -foreign import refEq :: forall a. a -> a -> Boolean -foreign import refIneq :: forall a. a -> a -> Boolean -foreign import eqArrayImpl :: forall a. (a -> a -> Boolean) -> Array a -> Array a -> Boolean - --- | 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_ the second. -data Ordering = LT | GT | EQ - --- | The `Ord` type class represents types which support comparisons with a --- | _total order_. --- | --- | `Ord` instances should satisfy the laws of total orderings: --- | --- | - 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 = unsafeCompare - -instance ordInt :: Ord Int where - compare = unsafeCompare - -instance ordNumber :: Ord Number where - compare = unsafeCompare - -instance ordString :: Ord String where - compare = unsafeCompare - -instance ordChar :: Ord Char where - compare = unsafeCompare - -instance ordUnit :: Ord Unit where - compare _ _ = EQ - -instance ordArray :: (Ord a) => Ord (Array a) where - compare xs ys = compare 0 $ ordArrayImpl (\x y -> case compare x y of - EQ -> 0 - LT -> 1 - GT -> -1) xs ys - -foreign import ordArrayImpl :: forall a. (a -> a -> Int) -> Array a -> Array a -> Int - -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 -(<) a1 a2 = case a1 `compare` a2 of - LT -> true - _ -> false - --- | 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 - --- | 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 - --- | 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 :: forall a. Ordering -> Ordering -> Ordering -> a -> a -> Ordering - --- | The `Bounded` type class represents types that are finite. --- | --- | Although there are no "internal" laws for `Bounded`, every value of `a` --- | should be considered less than or equal to `top` by some means, and greater --- | than or equal to `bottom`. --- | --- | The lack of explicit `Ord` constraint allows flexibility in the use of --- | `Bounded` so it can apply to total and partially ordered sets, boolean --- | algebras, etc. -class 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 - -instance boundedInt :: Bounded Int where - top = topInt - bottom = bottomInt - --- | Characters fall within the Unicode range. -instance boundedChar :: Bounded Char where - top = topChar - bottom = bottomChar - -instance boundedFn :: (Bounded b) => Bounded (a -> b) where - top _ = top - bottom _ = bottom - -foreign import topInt :: Int -foreign import bottomInt :: Int - -foreign import topChar :: Char -foreign import bottomChar :: Char - --- | The `BoundedOrd` type class represents totally ordered finite data types. --- | --- | Instances should satisfy the following law in addition to the `Ord` laws: --- | --- | - Ordering: `bottom <= a <= top` -class (Bounded a, Ord a) <= BoundedOrd a - -instance boundedOrdBoolean :: BoundedOrd Boolean where -instance boundedOrdUnit :: BoundedOrd Unit where -instance boundedOrdOrdering :: BoundedOrd Ordering where -instance boundedOrdInt :: BoundedOrd Int where -instance boundedOrdChar :: BoundedOrd Char where - --- | The `BooleanAlgebra` type class represents types that behave like boolean --- | values. --- | --- | Instances should satisfy the following laws in addition to the `Bounded` --- | laws: --- | --- | - Associativity: --- | - `a || (b || c) = (a || b) || c` --- | - `a && (b && c) = (a && b) && c` --- | - Commutativity: --- | - `a || b = b || a` --- | - `a && b = b && a` --- | - Distributivity: --- | - `a && (b || c) = (a && b) || (a && c)` --- | - `a || (b && c) = (a || b) && (a || c)` --- | - Identity: --- | - `a || bottom = a` --- | - `a && top = a` --- | - Idempotent: --- | - `a || a = a` --- | - `a && a = a` --- | - Absorption: --- | - `a || (a && b) = a` --- | - `a && (a || b) = a` --- | - Annhiliation: --- | - `a || top = top` --- | - Complementation: --- | - `a && not a = bottom` --- | - `a || not a = top` -class (Bounded a) <= BooleanAlgebra a where - conj :: a -> a -> a - disj :: a -> a -> a - not :: a -> a - -instance booleanAlgebraBoolean :: BooleanAlgebra Boolean where - conj = boolAnd - disj = boolOr - not = boolNot - -instance booleanAlgebraUnit :: BooleanAlgebra Unit where - conj _ _ = unit - disj _ _ = unit - not _ = unit - -instance booleanAlgebraFn :: (BooleanAlgebra b) => BooleanAlgebra (a -> b) where - conj fx fy a = fx a `conj` fy a - disj fx fy a = fx a `disj` fy a - not fx a = not (fx a) - -infixr 3 && -infixr 2 || - --- | `(&&)` is an alias for `conj`. -(&&) :: forall a. (BooleanAlgebra a) => a -> a -> a -(&&) = conj - --- | `(||)` is an alias for `disj`. -(||) :: forall a. (BooleanAlgebra a) => a -> a -> a -(||) = disj - -foreign import boolOr :: Boolean -> Boolean -> Boolean -foreign import boolAnd :: Boolean -> Boolean -> Boolean -foreign import boolNot :: Boolean -> Boolean - --- | The `Show` type class represents those types which can be converted into --- | a human-readable `String` representation. --- | --- | While not required, it is recommended that for any expression `x`, the --- | string `show x` be executable PureScript code which evaluates to the same --- | value as the expression `x`. -class Show a where - show :: a -> String - -instance showBoolean :: Show Boolean where - show true = "true" - show false = "false" - -instance showInt :: Show Int where - show = showIntImpl - -instance showNumber :: Show Number where - show = showNumberImpl - -instance showChar :: Show Char where - show = showCharImpl - -instance showString :: Show String where - show = showStringImpl - -instance showUnit :: Show Unit where - show _ = "unit" - -instance showArray :: (Show a) => Show (Array a) where - show = showArrayImpl show - -instance showOrdering :: Show Ordering where - show LT = "LT" - show GT = "GT" - show EQ = "EQ" - -foreign import showIntImpl :: Int -> String -foreign import showNumberImpl :: Number -> String -foreign import showCharImpl :: Char -> String -foreign import showStringImpl :: String -> String -foreign import showArrayImpl :: forall a. (a -> String) -> Array a -> String diff --git a/tests/support/pscide/src/RebuildSpecWithHiddenIdent.purs b/tests/support/pscide/src/RebuildSpecWithHiddenIdent.purs new file mode 100644 --- /dev/null +++ b/tests/support/pscide/src/RebuildSpecWithHiddenIdent.purs @@ -0,0 +1,6 @@ +module RebuildSpecWithHiddenIdent (exported) where + +hidden x _ = x + +exported :: forall a. a -> a +exported x = x diff --git a/tests/support/setup.js b/tests/support/setup.js deleted file mode 100644 --- a/tests/support/setup.js +++ /dev/null @@ -1,22 +0,0 @@ -var glob = require("glob"); -var fs = require("fs"); - -try { - fs.mkdirSync("./flattened"); -} catch(e) { - // ignore the error if it already exists - if (e.code !== "EEXIST") { - throw(e); - } -} - -glob("bower_components/*/src/**/*.{js,purs}", function(err, files) { - if (err) throw err; - files.forEach(function(file) { - // We join with "-" because Cabal is weird about file extensions. - var dest = "./flattened/" + file.split("/").slice(3).join("-"); - console.log("Copying " + file + " to " + dest); - var content = fs.readFileSync(file, "utf-8"); - fs.writeFileSync(dest, content, "utf-8"); - }); -})