diff options
| author | PhilFreeman <> | 2015-08-04 00:18:00 (GMT) |
|---|---|---|
| committer | hdiff <hdiff@hdiff.luite.com> | 2015-08-04 00:18:00 (GMT) |
| commit | 83cb18a5d18a448f671ff47facfa16b22b91f1cc (patch) | |
| tree | a2b8013c75822d2e7b3204f534880546fa78ca34 | |
| parent | b7f4ed1fe863071139b42f9f40421ef693fbe2cf (diff) | |
version 0.7.2.00.7.2.0
231 files changed, 3125 insertions, 992 deletions
diff --git a/examples/failing/365.purs b/examples/failing/365.purs index 248003b..86a56d3 100644 --- a/examples/failing/365.purs +++ b/examples/failing/365.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith CycleInDeclaration module Main where import Prelude diff --git a/examples/failing/438.purs b/examples/failing/438.purs index f5e8f02..2084170 100644 --- a/examples/failing/438.purs +++ b/examples/failing/438.purs @@ -1,3 +1,8 @@ +-- @shouldFailWith NoInstanceFound + +-- See issue 438 for details: this test is mainly here to test that code like +-- this doesn't cause the compiler to loop. + module Main where import Prelude @@ -5,7 +10,6 @@ import Prelude data Fix f = In (f (Fix f)) instance eqFix :: (Eq (f (Fix f))) => Eq (Fix f) where - (==) (In f) (In g) = f == g - (/=) a b = not (a == b) + eq (In f) (In g) = f == g example = In [] == In [] diff --git a/examples/failing/ArrayType.purs b/examples/failing/ArrayType.purs index 88888aa..a93731c 100644 --- a/examples/failing/ArrayType.purs +++ b/examples/failing/ArrayType.purs @@ -1,7 +1,9 @@ +-- @shouldFailWith TypesDoNotUnify + module Main where import Prelude -import Debug.Trace +import Control.Monad.Eff.Console bar :: Number -> Number -> Number bar n m = n + m diff --git a/examples/failing/Arrays.purs b/examples/failing/Arrays.purs index d4ed307..6c7d763 100644 --- a/examples/failing/Arrays.purs +++ b/examples/failing/Arrays.purs @@ -1,5 +1,8 @@ +-- @shouldFailWith ExprDoesNotHaveType module Main where import Prelude +foreign import (!!) :: forall a. Array a -> Int -> a + test = \arr -> arr !! (0 !! 0) diff --git a/examples/failing/CaseDoesNotMatchAllConstructorArgs.purs b/examples/failing/CaseDoesNotMatchAllConstructorArgs.purs index 0e02b37..da95c96 100644 --- a/examples/failing/CaseDoesNotMatchAllConstructorArgs.purs +++ b/examples/failing/CaseDoesNotMatchAllConstructorArgs.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith IncorrectConstructorArity module Main where import Prelude diff --git a/examples/failing/Do.purs b/examples/failing/Do.purs index face15e..7d648c2 100644 --- a/examples/failing/Do.purs +++ b/examples/failing/Do.purs @@ -1,3 +1,5 @@ +-- @shouldFailWith InvalidDoBind +-- @shouldFailWith InvalidDoLet module Main where import Prelude diff --git a/examples/failing/DoNotSuggestComposition.purs b/examples/failing/DoNotSuggestComposition.purs new file mode 100644 index 0000000..c26bafb --- /dev/null +++ b/examples/failing/DoNotSuggestComposition.purs @@ -0,0 +1,13 @@ +-- @shouldFailWith TypesDoNotUnify +-- TODO: Check that this does not produce a "function composition is (<<<)" +-- suggestion. +module DoNotSuggestComposition where + +import Prelude + +x = { y: 3 } + +foo :: String -> String +foo y = y + +bar = foo x diff --git a/examples/failing/DoNotSuggestComposition2.purs b/examples/failing/DoNotSuggestComposition2.purs new file mode 100644 index 0000000..b6e13dc --- /dev/null +++ b/examples/failing/DoNotSuggestComposition2.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith CannotApplyFunction +-- TODO: Check that this does not produce a "function composition is (<<<)" +-- suggestion. + +module DoNotSuggestComposition2 where + +foo = let x = { y: 3 } in x 2 diff --git a/examples/failing/DuplicateDeclarationsInLet.purs b/examples/failing/DuplicateDeclarationsInLet.purs index 9230d3a..fed163d 100644 --- a/examples/failing/DuplicateDeclarationsInLet.purs +++ b/examples/failing/DuplicateDeclarationsInLet.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith OverlappingNamesInLet module Main where import Prelude diff --git a/examples/failing/DuplicateProperties1.purs b/examples/failing/DuplicateProperties1.purs index 7298bd7..d8bba9d 100644 --- a/examples/failing/DuplicateProperties1.purs +++ b/examples/failing/DuplicateProperties1.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith TypesDoNotUnify module DuplicateProperties where import Prelude diff --git a/examples/failing/DuplicateProperties2.purs b/examples/failing/DuplicateProperties2.purs index aa0e63c..bf88690 100644 --- a/examples/failing/DuplicateProperties2.purs +++ b/examples/failing/DuplicateProperties2.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith DuplicateLabel module DuplicateProperties where import Prelude diff --git a/examples/failing/DuplicateTypeVars.purs b/examples/failing/DuplicateTypeVars.purs index 85a638c..d209301 100644 --- a/examples/failing/DuplicateTypeVars.purs +++ b/examples/failing/DuplicateTypeVars.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith DuplicateTypeArgument module Main where import Prelude diff --git a/examples/failing/Eff.purs b/examples/failing/Eff.purs index 6fb7174..e41e085 100644 --- a/examples/failing/Eff.purs +++ b/examples/failing/Eff.purs @@ -1,12 +1,13 @@ +-- @shouldFailWith TypesDoNotUnify module Main where import Prelude import Control.Monad.Eff import Control.Monad.ST -import Debug.Trace +import Control.Monad.Eff.Console test = pureST (do ref <- newSTRef 0 - trace "ST" + log "ST" modifySTRef ref $ \n -> n + 1 readSTRef ref) diff --git a/examples/failing/ExtraRecordField.purs b/examples/failing/ExtraRecordField.purs new file mode 100644 index 0000000..de15fee --- /dev/null +++ b/examples/failing/ExtraRecordField.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith PropertyIsMissing +-- TODO: Make this fail with a new error ExtraProperty instead. +module ExtraRecordField where + +import Prelude ((<>)) + +full :: { first :: String, last :: String } -> String +full p = p.first <> " " <> p.last + +oops = full { first: "Jane", last: "Smith", age: 29 } diff --git a/examples/failing/Foldable.purs b/examples/failing/Foldable.purs index c589cce..daea9d9 100644 --- a/examples/failing/Foldable.purs +++ b/examples/failing/Foldable.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith CycleInDeclaration module Main where import Prelude diff --git a/examples/failing/InstanceExport.purs b/examples/failing/InstanceExport.purs index fca062c..f787aff 100644 --- a/examples/failing/InstanceExport.purs +++ b/examples/failing/InstanceExport.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith TransitiveExportError module InstanceExport (S(..), f) where import Prelude @@ -13,5 +14,6 @@ instance fs :: F S where module Test where import InstanceExport +import Prelude test = f $ S "Test" diff --git a/examples/failing/KindError.purs b/examples/failing/KindError.purs index ae6a728..ddc656b 100644 --- a/examples/failing/KindError.purs +++ b/examples/failing/KindError.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith KindsDoNotUnify module Main where import Prelude diff --git a/examples/failing/LeadingZeros1.purs b/examples/failing/LeadingZeros1.purs index 9c6967a..e77cf2d 100644 --- a/examples/failing/LeadingZeros1.purs +++ b/examples/failing/LeadingZeros1.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith ErrorParsingModule module Main where import Prelude diff --git a/examples/failing/LeadingZeros2.purs b/examples/failing/LeadingZeros2.purs index 4602707..58ff97c 100644 --- a/examples/failing/LeadingZeros2.purs +++ b/examples/failing/LeadingZeros2.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith ErrorParsingModule module Main where import Prelude diff --git a/examples/failing/Let.purs b/examples/failing/Let.purs index db26dbf..12d53ae 100644 --- a/examples/failing/Let.purs +++ b/examples/failing/Let.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith CycleInDeclaration module Main where import Prelude diff --git a/examples/failing/MPTCs.purs b/examples/failing/MPTCs.purs index 935bbf3..c5917cf 100644 --- a/examples/failing/MPTCs.purs +++ b/examples/failing/MPTCs.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith KindsDoNotUnify module Main where import Prelude diff --git a/examples/failing/MissingClassExport.purs b/examples/failing/MissingClassExport.purs index 4b3b8a0..bad7f30 100644 --- a/examples/failing/MissingClassExport.purs +++ b/examples/failing/MissingClassExport.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith TransitiveExportError module Test (bar) where import Prelude diff --git a/examples/failing/MissingClassMemberExport.purs b/examples/failing/MissingClassMemberExport.purs index e865694..cb6dec8 100644 --- a/examples/failing/MissingClassMemberExport.purs +++ b/examples/failing/MissingClassMemberExport.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith TransitiveExportError module Test (Foo) where import Prelude diff --git a/examples/failing/MissingRecordField.purs b/examples/failing/MissingRecordField.purs new file mode 100644 index 0000000..eb6ebd9 --- /dev/null +++ b/examples/failing/MissingRecordField.purs @@ -0,0 +1,11 @@ +-- @shouldFailWith TypesDoNotUnify +-- TODO: Update type checker to make this fail with PropertyIsMissing instead. +module MissingRecordField where + +import Prelude ((>)) + +john = { first: "John", last: "Smith" } + +isOver50 p = p.age > 50.0 + +result = isOver50 john diff --git a/examples/failing/MultipleErrors.purs b/examples/failing/MultipleErrors.purs index da04702..ecc9b1e 100644 --- a/examples/failing/MultipleErrors.purs +++ b/examples/failing/MultipleErrors.purs @@ -1,11 +1,13 @@ +-- @shouldFailWith ExprDoesNotHaveType +-- @shouldFailWith ExprDoesNotHaveType module MultipleErrors where import Prelude -foo :: Number -> Number +foo :: Int -> Int foo 0 = "Test" foo n = bar (n - 1) -bar :: Number -> Number +bar :: Int -> Int bar 0 = "Test" bar n = foo (n - 1) diff --git a/examples/failing/MultipleErrors2.purs b/examples/failing/MultipleErrors2.purs index 37fe9d7..31e007c 100644 --- a/examples/failing/MultipleErrors2.purs +++ b/examples/failing/MultipleErrors2.purs @@ -1,3 +1,5 @@ +-- @shouldFailWith UnknownValue +-- @shouldFailWith UnknownValue module MultipleErrors2 where import Prelude diff --git a/examples/failing/MutRec.purs b/examples/failing/MutRec.purs index 219eb6f..c444cc3 100644 --- a/examples/failing/MutRec.purs +++ b/examples/failing/MutRec.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith CycleInDeclaration module MutRec where import Prelude diff --git a/examples/failing/MutRec2.purs b/examples/failing/MutRec2.purs index 3fb84eb..ad62b20 100644 --- a/examples/failing/MutRec2.purs +++ b/examples/failing/MutRec2.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith CycleInDeclaration module Main where import Prelude diff --git a/examples/failing/NewtypeMultiArgs.purs b/examples/failing/NewtypeMultiArgs.purs index 805a784..b3ceed3 100644 --- a/examples/failing/NewtypeMultiArgs.purs +++ b/examples/failing/NewtypeMultiArgs.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith InvalidNewtype module Main where import Prelude diff --git a/examples/failing/NewtypeMultiCtor.purs b/examples/failing/NewtypeMultiCtor.purs index 158f38c..04b4cee 100644 --- a/examples/failing/NewtypeMultiCtor.purs +++ b/examples/failing/NewtypeMultiCtor.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith InvalidNewtype module Main where import Prelude diff --git a/examples/failing/NoOverlap.purs b/examples/failing/NoOverlap.purs deleted file mode 100644 index abf8620..0000000 --- a/examples/failing/NoOverlap.purs +++ /dev/null @@ -1,13 +0,0 @@ -module Main where - -import Prelude - -data Foo = Foo - -instance showFoo1 :: Show Foo where - show _ = "Foo" - -instance showFoo2 :: Show Foo where - show _ = "Bar" - -test = show Foo diff --git a/examples/failing/NullaryAbs.purs b/examples/failing/NullaryAbs.purs index 8ad6f88..9cd0eca 100644 --- a/examples/failing/NullaryAbs.purs +++ b/examples/failing/NullaryAbs.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith ErrorParsingModule module Main where import Prelude diff --git a/examples/failing/Object.purs b/examples/failing/Object.purs index 9a66afb..7d8f84c 100644 --- a/examples/failing/Object.purs +++ b/examples/failing/Object.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith PropertyIsMissing module Main where import Prelude diff --git a/examples/failing/OverlappingArguments.purs b/examples/failing/OverlappingArguments.purs index 7b2347c..5a64e20 100644 --- a/examples/failing/OverlappingArguments.purs +++ b/examples/failing/OverlappingArguments.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith OverlappingArgNames module OverlappingArguments where import Prelude diff --git a/examples/failing/OverlappingBinders.purs b/examples/failing/OverlappingBinders.purs index 9c879fe..95452f7 100644 --- a/examples/failing/OverlappingBinders.purs +++ b/examples/failing/OverlappingBinders.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith OverlappingArgNames module OverlappingBinders where import Prelude diff --git a/examples/failing/OverlappingInstances.purs b/examples/failing/OverlappingInstances.purs index aad48b0..fb15f8c 100644 --- a/examples/failing/OverlappingInstances.purs +++ b/examples/failing/OverlappingInstances.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith OverlappingInstances module OverlappingInstances where import Prelude @@ -10,4 +11,4 @@ instance showA1 :: Show A where instance showA2 :: Show A where show A = "Instance 2" -main = Debug.Trace.trace $ show A +main = Control.Monad.Eff.Console.log $ show A diff --git a/examples/failing/OverlappingInstances2.purs b/examples/failing/OverlappingInstances2.purs index bf971ee..1811754 100644 --- a/examples/failing/OverlappingInstances2.purs +++ b/examples/failing/OverlappingInstances2.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith OverlappingInstances module OverlappingInstances where import Prelude @@ -5,14 +6,12 @@ import Prelude data A = A | B instance eqA1 :: Eq A where - (==) A A = true - (==) B B = true - (==) _ _ = false - (/=) x y = not (x == y) + eq A A = true + eq B B = true + eq _ _ = false instance eqA2 :: Eq A where - (==) _ _ = true - (/=) _ _ = false + eq _ _ = true instance ordA :: Ord A where compare A B = LT @@ -22,4 +21,4 @@ instance ordA :: Ord A where test :: forall a. (Ord a) => a -> a -> String test x y = show $ x == y -main = Debug.Trace.trace $ test A B +main = Control.Monad.Eff.Console.log $ test A B diff --git a/examples/failing/OverlappingVars.purs b/examples/failing/OverlappingVars.purs index 1d9f118..82059ac 100644 --- a/examples/failing/OverlappingVars.purs +++ b/examples/failing/OverlappingVars.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith NoInstanceFound module Main where import Prelude diff --git a/examples/failing/Rank2Types.purs b/examples/failing/Rank2Types.purs index 61c0442..5cb50ef 100644 --- a/examples/failing/Rank2Types.purs +++ b/examples/failing/Rank2Types.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith ExprDoesNotHaveType module Main where import Prelude diff --git a/examples/failing/Reserved.purs b/examples/failing/Reserved.purs index 5edd95a..f94733b 100644 --- a/examples/failing/Reserved.purs +++ b/examples/failing/Reserved.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith ErrorParsingModule module Main where import Prelude diff --git a/examples/failing/RowConstructors1.purs b/examples/failing/RowConstructors1.purs index ca260db..64e0b65 100644 --- a/examples/failing/RowConstructors1.purs +++ b/examples/failing/RowConstructors1.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith KindsDoNotUnify module Main where import Prelude @@ -5,4 +6,4 @@ import Prelude data Foo = Bar type Baz = { | Foo } -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/failing/RowConstructors2.purs b/examples/failing/RowConstructors2.purs index d763d6e..dae6a44 100644 --- a/examples/failing/RowConstructors2.purs +++ b/examples/failing/RowConstructors2.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith KindsDoNotUnify module Main where import Prelude @@ -5,4 +6,4 @@ import Prelude type Foo r = (x :: Number | r) type Bar = { | Foo } -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/failing/RowConstructors3.purs b/examples/failing/RowConstructors3.purs index d5ad0b1..1a04e42 100644 --- a/examples/failing/RowConstructors3.purs +++ b/examples/failing/RowConstructors3.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith KindsDoNotUnify module Main where import Prelude @@ -5,4 +6,4 @@ import Prelude type Foo = { x :: Number } type Bar = { | Foo } -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/failing/SkolemEscape.purs b/examples/failing/SkolemEscape.purs index f083c73..c9c63ad 100644 --- a/examples/failing/SkolemEscape.purs +++ b/examples/failing/SkolemEscape.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith EscapedSkolem module Main where import Prelude diff --git a/examples/failing/SkolemEscape2.purs b/examples/failing/SkolemEscape2.purs index eb1ae72..6df2afe 100644 --- a/examples/failing/SkolemEscape2.purs +++ b/examples/failing/SkolemEscape2.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith EscapedSkolem module Main where import Prelude diff --git a/examples/failing/SuggestComposition.purs b/examples/failing/SuggestComposition.purs new file mode 100644 index 0000000..b4196c2 --- /dev/null +++ b/examples/failing/SuggestComposition.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith TypesDoNotUnify +-- TODO: Ensure the correct suggestion is produced. +module SuggestComposition where + +import Prelude + +f = g . g where g = (+1) diff --git a/examples/failing/Superclasses1.purs b/examples/failing/Superclasses1.purs index af98520..f6f2b3d 100644 --- a/examples/failing/Superclasses1.purs +++ b/examples/failing/Superclasses1.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith NoInstanceFound module Main where import Prelude diff --git a/examples/failing/Superclasses2.purs b/examples/failing/Superclasses2.purs index 13e9d56..0c50349 100644 --- a/examples/failing/Superclasses2.purs +++ b/examples/failing/Superclasses2.purs @@ -1,3 +1,5 @@ +-- @shouldFailWith CycleInTypeSynonym +-- TODO: Should this have its own error, perhaps CycleInTypeClassDeclaration? module CycleInSuperclasses where import Prelude diff --git a/examples/failing/Superclasses3.purs b/examples/failing/Superclasses3.purs index f79d89d..2a6c225 100644 --- a/examples/failing/Superclasses3.purs +++ b/examples/failing/Superclasses3.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith UndefinedTypeVariable module UnknownSuperclassTypeVar where import Prelude diff --git a/examples/failing/Superclasses4.purs b/examples/failing/Superclasses4.purs index 3c7c979..7b3e3ae 100644 --- a/examples/failing/Superclasses4.purs +++ b/examples/failing/Superclasses4.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith OverlappingInstances module OverlappingInstances where import Prelude @@ -11,4 +12,4 @@ instance foo2 :: Foo Number test :: forall a. (Foo a) => a -> a test a = a -test1 = test 0 +test1 = test 0.0 diff --git a/examples/failing/TopLevelCaseNoArgs.purs b/examples/failing/TopLevelCaseNoArgs.purs index c0a9f01..fae9238 100644 --- a/examples/failing/TopLevelCaseNoArgs.purs +++ b/examples/failing/TopLevelCaseNoArgs.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith DuplicateValueDeclaration module Main where import Prelude diff --git a/examples/failing/TypeClassInstances.purs b/examples/failing/TypeClassInstances.purs index ca4021f..488fccf 100644 --- a/examples/failing/TypeClassInstances.purs +++ b/examples/failing/TypeClassInstances.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith MissingClassMember module Main where import Prelude diff --git a/examples/failing/TypeClasses2.purs b/examples/failing/TypeClasses2.purs index cdaa921..16f6175 100644 --- a/examples/failing/TypeClasses2.purs +++ b/examples/failing/TypeClasses2.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith NoInstanceFound module Main where import Prelude () diff --git a/examples/failing/TypeError.purs b/examples/failing/TypeError.purs index a9e65b3..ad26361 100644 --- a/examples/failing/TypeError.purs +++ b/examples/failing/TypeError.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith ExprDoesNotHaveType module Main where import Prelude diff --git a/examples/failing/TypeSynonyms.purs b/examples/failing/TypeSynonyms.purs index 473dc7d..6afcde4 100644 --- a/examples/failing/TypeSynonyms.purs +++ b/examples/failing/TypeSynonyms.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith CycleInTypeSynonym module Main where import Prelude diff --git a/examples/failing/TypeSynonyms2.purs b/examples/failing/TypeSynonyms2.purs index 36c7950..e129df2 100644 --- a/examples/failing/TypeSynonyms2.purs +++ b/examples/failing/TypeSynonyms2.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith TypeSynonymInstance module Main where import Prelude diff --git a/examples/failing/TypeSynonyms3.purs b/examples/failing/TypeSynonyms3.purs index 36c7950..e129df2 100644 --- a/examples/failing/TypeSynonyms3.purs +++ b/examples/failing/TypeSynonyms3.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith TypeSynonymInstance module Main where import Prelude diff --git a/examples/failing/TypeSynonyms4.purs b/examples/failing/TypeSynonyms4.purs index af118c4..5861ef3 100644 --- a/examples/failing/TypeSynonyms4.purs +++ b/examples/failing/TypeSynonyms4.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith PartiallyAppliedSynonym module TypeSynonyms4 where import Prelude diff --git a/examples/failing/TypeSynonyms5.purs b/examples/failing/TypeSynonyms5.purs index e948d5a..964106b 100644 --- a/examples/failing/TypeSynonyms5.purs +++ b/examples/failing/TypeSynonyms5.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith CycleInTypeSynonym module Main where import Prelude diff --git a/examples/failing/TypeWildcards1.purs b/examples/failing/TypeWildcards1.purs index f231379..6a54b8e 100644 --- a/examples/failing/TypeWildcards1.purs +++ b/examples/failing/TypeWildcards1.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith ErrorParsingModule module TypeWildcards where import Prelude diff --git a/examples/failing/TypeWildcards2.purs b/examples/failing/TypeWildcards2.purs index b625b4e..f09a2dc 100644 --- a/examples/failing/TypeWildcards2.purs +++ b/examples/failing/TypeWildcards2.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith ErrorParsingModule module TypeWildcards where import Prelude diff --git a/examples/failing/TypeWildcards3.purs b/examples/failing/TypeWildcards3.purs index e28abb8..5c60b30 100644 --- a/examples/failing/TypeWildcards3.purs +++ b/examples/failing/TypeWildcards3.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith ErrorParsingModule module TypeWildcards where import Prelude diff --git a/examples/failing/UnderscoreModuleName.purs b/examples/failing/UnderscoreModuleName.purs index 2cc71a5..1514622 100644 --- a/examples/failing/UnderscoreModuleName.purs +++ b/examples/failing/UnderscoreModuleName.purs @@ -1,5 +1,6 @@ +-- @shouldFailWith ErrorParsingModule module Bad_Module where import Prelude -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/failing/UnifyInTypeInstanceLookup.purs b/examples/failing/UnifyInTypeInstanceLookup.purs index 93d084c..50aa41a 100644 --- a/examples/failing/UnifyInTypeInstanceLookup.purs +++ b/examples/failing/UnifyInTypeInstanceLookup.purs @@ -1,3 +1,6 @@ +-- @shouldFailWith NoInstanceFound +-- See issue #390. +-- TODO: Improve this error. module Main where import Prelude diff --git a/examples/failing/UnknownType.purs b/examples/failing/UnknownType.purs index ab2ea58..0b7645d 100644 --- a/examples/failing/UnknownType.purs +++ b/examples/failing/UnknownType.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith UnknownType module Main where import Prelude diff --git a/examples/passing/652.purs b/examples/passing/652.purs index 66443ab..43e49ad 100644 --- a/examples/passing/652.purs +++ b/examples/passing/652.purs @@ -14,4 +14,4 @@ instance bar :: Bar (a -> b) b instance baz :: (Eq a) => Baz (a -> b) a b -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/810.purs b/examples/passing/810.purs index 2ba3428..256d2c6 100644 --- a/examples/passing/810.purs +++ b/examples/passing/810.purs @@ -10,4 +10,4 @@ test m = o.x o = case m of Nothing -> { x : Nothing } Just a -> { x : Just a } -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/Applicative.purs b/examples/passing/Applicative.purs index 7c77c7e..fa47117 100644 --- a/examples/passing/Applicative.purs +++ b/examples/passing/Applicative.purs @@ -4,13 +4,13 @@ import Prelude () class Applicative f where pure :: forall a. a -> f a - (<*>) :: forall a b. f (a -> b) -> f a -> f b + apply :: forall a b. f (a -> b) -> f a -> f b data Maybe a = Nothing | Just a instance applicativeMaybe :: Applicative Maybe where pure = Just - (<*>) (Just f) (Just a) = Just (f a) - (<*>) _ _ = Nothing + apply (Just f) (Just a) = Just (f a) + apply _ _ = Nothing -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/ArrayType.purs b/examples/passing/ArrayType.purs index eddf257..889fcd3 100644 --- a/examples/passing/ArrayType.purs +++ b/examples/passing/ArrayType.purs @@ -8,4 +8,4 @@ class Pointed p where instance pointedArray :: Pointed Array where point a = [a] -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/Auto.purs b/examples/passing/Auto.purs index 070d4aa..c3500eb 100644 --- a/examples/passing/Auto.purs +++ b/examples/passing/Auto.purs @@ -12,4 +12,4 @@ exists = \state step f -> f (Auto { state: state, step: step }) 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 = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/AutoPrelude.purs b/examples/passing/AutoPrelude.purs index 1f8bcdf..a69b485 100644 --- a/examples/passing/AutoPrelude.purs +++ b/examples/passing/AutoPrelude.purs @@ -1,9 +1,9 @@ module Main where import Prelude -import Debug.Trace +import Control.Monad.Eff.Console f x = x * 10.0 g y = y - 10.0 -main = trace $ show $ (f <<< g) 100.0 +main = log $ show $ (f <<< g) 100.0 diff --git a/examples/passing/AutoPrelude2.purs b/examples/passing/AutoPrelude2.purs index 4a8c51a..373c380 100644 --- a/examples/passing/AutoPrelude2.purs +++ b/examples/passing/AutoPrelude2.purs @@ -2,9 +2,9 @@ module Main where import Prelude import qualified Prelude as P -import Debug.Trace +import Control.Monad.Eff.Console f :: forall a. a -> a f = P.id -main = P.($) trace ((f P.<<< f) "Done") +main = P.($) log ((f P.<<< f) "Done") diff --git a/examples/passing/BindersInFunctions.purs b/examples/passing/BindersInFunctions.purs index 13acfc5..d1a504b 100644 --- a/examples/passing/BindersInFunctions.purs +++ b/examples/passing/BindersInFunctions.purs @@ -1,12 +1,11 @@ module Main where import Prelude -import Assert +import Test.Assert snd = \[_, y] -> y -main = - let ts = snd [1.0, 2.0] in - if ts == 2.0 - then Debug.Trace.trace "Done" - else error "Incorrect result from 'snd'." +main = do + let ts = snd [1.0, 2.0] + assert' "Incorrect result from 'snd'." (ts == 2.0) + Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/BindingGroups.purs b/examples/passing/BindingGroups.purs index 903579d..fb7ceb2 100644 --- a/examples/passing/BindingGroups.purs +++ b/examples/passing/BindingGroups.purs @@ -7,4 +7,4 @@ foo = bar r = foo 2.0 -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/BlockString.purs b/examples/passing/BlockString.purs index 721612c..23f039e 100644 --- a/examples/passing/BlockString.purs +++ b/examples/passing/BlockString.purs @@ -5,4 +5,4 @@ import Prelude foo :: String foo = """foo""" -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/CaseInDo.purs b/examples/passing/CaseInDo.purs index 844d025..574b694 100644 --- a/examples/passing/CaseInDo.purs +++ b/examples/passing/CaseInDo.purs @@ -1,14 +1,14 @@ module Main where import Prelude -import Debug.Trace +import Control.Monad.Eff.Console import Control.Monad.Eff doIt :: forall eff. Eff eff Boolean doIt = return true set = do - trace "Testing..." + log "Testing..." case 0 of 0 -> doIt _ -> return false @@ -16,4 +16,4 @@ set = do main = do b <- set case b of - true -> trace "Done" + true -> log "Done" diff --git a/examples/passing/CaseStatement.purs b/examples/passing/CaseStatement.purs index 74b4b93..6ed9346 100644 --- a/examples/passing/CaseStatement.purs +++ b/examples/passing/CaseStatement.purs @@ -18,4 +18,4 @@ h f N a = a h f a N = a h f (J a) (J b) = J (f a b) -main = Debug.Trace.trace $ f "Done" "Failed" A +main = Control.Monad.Eff.Console.log $ f "Done" "Failed" A diff --git a/examples/passing/CheckFunction.purs b/examples/passing/CheckFunction.purs index 6504256..187c577 100644 --- a/examples/passing/CheckFunction.purs +++ b/examples/passing/CheckFunction.purs @@ -4,4 +4,4 @@ import Prelude test = ((\x -> x+1.0) >>> (\x -> x*2.0)) 4.0 -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/CheckSynonymBug.purs b/examples/passing/CheckSynonymBug.purs index 09c6161..3f565c2 100644 --- a/examples/passing/CheckSynonymBug.purs +++ b/examples/passing/CheckSynonymBug.purs @@ -2,8 +2,11 @@ module Main where import Prelude +length :: forall a. Array a -> Int +length _ = 0 + type Foo a = Array a foo _ = length ([] :: Foo Number) -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/CheckTypeClass.purs b/examples/passing/CheckTypeClass.purs index 45f59ad..81e86a1 100644 --- a/examples/passing/CheckTypeClass.purs +++ b/examples/passing/CheckTypeClass.purs @@ -14,5 +14,5 @@ foo_ x = foo ((mkBar :: forall a. (Foo a) => a -> Bar a) x) mkBar :: forall a. a -> Bar a mkBar _ = Bar -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/Church.purs b/examples/passing/Church.purs index bda8fb7..fd9cde8 100644 --- a/examples/passing/Church.purs +++ b/examples/passing/Church.purs @@ -15,4 +15,4 @@ append = \l1 l2 r f -> l2 (l1 r f) f test = append (cons 1 empty) (cons 2 empty) -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/Collatz.purs b/examples/passing/Collatz.purs index 37f51e9..80a3d1e 100644 --- a/examples/passing/Collatz.purs +++ b/examples/passing/Collatz.purs @@ -4,15 +4,15 @@ import Prelude import Control.Monad.Eff import Control.Monad.ST -collatz :: Number -> Number +collatz :: Int -> Int collatz n = runPure (runST (do r <- newSTRef n - count <- newSTRef 0.0 + count <- newSTRef 0 untilE $ do - modifySTRef count $ (+) 1.0 + modifySTRef count $ (+) 1 m <- readSTRef r - writeSTRef r $ if m % 2.0 == 0.0 then m / 2.0 else 3.0 * m + 1.0 - return $ m == 1.0 + writeSTRef r $ if m `mod` 2 == 0 then m / 2 else 3 * m + 1 + return $ m == 1 readSTRef count)) -main = Debug.Trace.print $ collatz 1000.0 +main = Control.Monad.Eff.Console.print $ collatz 1000 diff --git a/examples/passing/Comparisons.purs b/examples/passing/Comparisons.purs index ab35318..f98dca0 100644 --- a/examples/passing/Comparisons.purs +++ b/examples/passing/Comparisons.purs @@ -2,8 +2,8 @@ module Main where import Prelude import Control.Monad.Eff -import Debug.Trace -import Assert +import Control.Monad.Eff.Console +import Test.Assert main = do assert (1.0 < 2.0) @@ -12,4 +12,4 @@ main = do assert ("a" < "b") assert ("a" == "a") assert ("z" > "a") - trace "Done!" + log "Done!" diff --git a/examples/passing/Conditional.purs b/examples/passing/Conditional.purs index 6d39f7f..303f5a6 100644 --- a/examples/passing/Conditional.purs +++ b/examples/passing/Conditional.purs @@ -6,4 +6,4 @@ fns = \f -> if f true then f else \x -> x not = \x -> if x then false else true -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/Console.purs b/examples/passing/Console.purs index e9e5c91..a828773 100644 --- a/examples/passing/Console.purs +++ b/examples/passing/Console.purs @@ -2,7 +2,7 @@ module Main where import Prelude import Control.Monad.Eff -import Debug.Trace +import Control.Monad.Eff.Console replicateM_ :: forall m a. (Monad m) => Number -> m a -> m {} replicateM_ 0.0 _ = return {} @@ -10,4 +10,4 @@ replicateM_ n act = do act replicateM_ (n - 1.0) act -main = replicateM_ 10.0 (trace "Hello World!") +main = replicateM_ 10.0 (log "Hello World!") diff --git a/examples/passing/DataAndType.purs b/examples/passing/DataAndType.purs index d7b0d2f..4ce7527 100644 --- a/examples/passing/DataAndType.purs +++ b/examples/passing/DataAndType.purs @@ -6,4 +6,4 @@ data A = A B type B = A -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/DeepArrayBinder.purs b/examples/passing/DeepArrayBinder.purs index a5e7476..d34bfaa 100644 --- a/examples/passing/DeepArrayBinder.purs +++ b/examples/passing/DeepArrayBinder.purs @@ -2,7 +2,7 @@ module Main where import Prelude import Control.Monad.Eff -import Assert +import Test.Assert data List a = Cons a (List a) | Nil @@ -10,6 +10,7 @@ match2 :: List Number -> Number match2 (Cons x (Cons y xs)) = x * y + match2 xs match2 _ = 0.0 -main = case 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))))))))) of - 100.0 -> Debug.Trace.trace "Done" - _ -> error "Incorrect result!" +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" diff --git a/examples/passing/DeepCase.purs b/examples/passing/DeepCase.purs index 741e09a..dce5f23 100644 --- a/examples/passing/DeepCase.purs +++ b/examples/passing/DeepCase.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Debug.Trace +import Control.Monad.Eff.Console import Control.Monad.Eff import Control.Monad.ST diff --git a/examples/passing/Do.purs b/examples/passing/Do.purs index 9e63f9b..08c559d 100644 --- a/examples/passing/Do.purs +++ b/examples/passing/Do.purs @@ -5,12 +5,12 @@ import Prelude data Maybe a = Nothing | Just a instance functorMaybe :: Functor Maybe where - (<$>) f Nothing = Nothing - (<$>) f (Just x) = Just (f x) + map f Nothing = Nothing + map f (Just x) = Just (f x) instance applyMaybe :: Apply Maybe where - (<*>) (Just f) (Just x) = Just (f x) - (<*>) _ _ = Nothing + apply (Just f) (Just x) = Just (f x) + apply _ _ = Nothing instance applicativeMaybe :: Applicative Maybe where pure = Just @@ -64,4 +64,4 @@ test10 _ = do g x = f x / 2.0 Just (f 10.0) -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/Dollar.purs b/examples/passing/Dollar.purs index 6d51499..88be68f 100644 --- a/examples/passing/Dollar.purs +++ b/examples/passing/Dollar.purs @@ -13,4 +13,4 @@ test1 x = id $ id $ id $ id $ x test2 x = id id $ id x -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/Eff.purs b/examples/passing/Eff.purs index c269512..3d7c2cd 100644 --- a/examples/passing/Eff.purs +++ b/examples/passing/Eff.purs @@ -3,11 +3,11 @@ module Main where import Prelude import Control.Monad.Eff import Control.Monad.ST -import Debug.Trace +import Control.Monad.Eff.Console test1 = do - trace "Line 1" - trace "Line 2" + log "Line 1" + log "Line 2" test2 = runPure (runST (do ref <- newSTRef 0.0 @@ -21,5 +21,5 @@ test3 = pureST (do main = do test1 - Debug.Trace.print test2 - Debug.Trace.print test3 + Control.Monad.Eff.Console.print test2 + Control.Monad.Eff.Console.print test3 diff --git a/examples/passing/EmptyDataDecls.purs b/examples/passing/EmptyDataDecls.purs index e19cc65..40d77ee 100644 --- a/examples/passing/EmptyDataDecls.purs +++ b/examples/passing/EmptyDataDecls.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Assert +import Test.Assert data Z data S n @@ -12,8 +12,8 @@ nil :: forall a. ArrayBox Z a nil = ArrayBox [] cons' :: forall a n. a -> ArrayBox n a -> ArrayBox (S n) a -cons' x (ArrayBox xs) = ArrayBox $ concat [x] xs +cons' x (ArrayBox xs) = ArrayBox $ append [x] xs main = case cons' 1 $ cons' 2 $ cons' 3 nil of - ArrayBox [1, 2, 3] -> Debug.Trace.trace "Done" - _ -> error "Failed" + ArrayBox [1, 2, 3] -> Control.Monad.Eff.Console.log "Done" + _ -> assert' "Failed" false diff --git a/examples/passing/EmptyRow.purs b/examples/passing/EmptyRow.purs index 3b2532d..9f738fb 100644 --- a/examples/passing/EmptyRow.purs +++ b/examples/passing/EmptyRow.purs @@ -7,4 +7,4 @@ data Foo r = Foo { | r } test :: Foo () test = Foo {} -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/EmptyTypeClass.purs b/examples/passing/EmptyTypeClass.purs index 08aa4f3..81d5ab3 100644 --- a/examples/passing/EmptyTypeClass.purs +++ b/examples/passing/EmptyTypeClass.purs @@ -9,4 +9,4 @@ head [x] = x instance allowPartials :: Partial -main = Debug.Trace.trace $ head ["Done"] +main = Control.Monad.Eff.Console.log $ head ["Done"] diff --git a/examples/passing/EqOrd.purs b/examples/passing/EqOrd.purs index 1c03c70..9ed10b2 100644 --- a/examples/passing/EqOrd.purs +++ b/examples/passing/EqOrd.purs @@ -10,7 +10,6 @@ instance ordPair :: (Ord a, Ord b) => Ord (Pair a b) where r -> r instance eqPair :: (Eq a, Eq b) => Eq (Pair a b) where - (==) (Pair a1 b1) (Pair a2 b2) = a1 == a2 && b1 == b2 - (/=) (Pair a1 b1) (Pair a2 b2) = a1 /= a2 || b1 /= b2 + eq (Pair a1 b1) (Pair a2 b2) = a1 == a2 && b1 == b2 -main = Debug.Trace.print $ Pair 1.0 2.0 == Pair 1.0 2.0 +main = Control.Monad.Eff.Console.print $ Pair 1.0 2.0 == Pair 1.0 2.0 diff --git a/examples/passing/ExtendedInfixOperators.purs b/examples/passing/ExtendedInfixOperators.purs index 5771b8a..276d7d9 100644 --- a/examples/passing/ExtendedInfixOperators.purs +++ b/examples/passing/ExtendedInfixOperators.purs @@ -11,4 +11,4 @@ null _ = false test = [1.0, 2.0, 3.0] `comparing null` [4.0, 5.0, 6.0] main = do - Debug.Trace.print test + Control.Monad.Eff.Console.print test diff --git a/examples/passing/Fib.purs b/examples/passing/Fib.purs index 1f27ecd..bf6d522 100644 --- a/examples/passing/Fib.purs +++ b/examples/passing/Fib.purs @@ -12,4 +12,4 @@ main = runST (do n2' <- readSTRef n2 writeSTRef n2 $ n1' + n2' writeSTRef n1 n2' - Debug.Trace.print n2') + Control.Monad.Eff.Console.print n2') diff --git a/examples/passing/FinalTagless.purs b/examples/passing/FinalTagless.purs index 80edd29..5347153 100644 --- a/examples/passing/FinalTagless.purs +++ b/examples/passing/FinalTagless.purs @@ -1,6 +1,6 @@ module Main where -import Prelude +import Prelude hiding (add) class E e where num :: Number -> e Number @@ -19,4 +19,4 @@ runId (Id a) = a three :: Expr Number three = add (num 1.0) (num 2.0) -main = Debug.Trace.print $ runId three +main = Control.Monad.Eff.Console.print $ runId three diff --git a/examples/passing/FunctionScope.purs b/examples/passing/FunctionScope.purs index 00f7ee2..3506153 100644 --- a/examples/passing/FunctionScope.purs +++ b/examples/passing/FunctionScope.purs @@ -1,13 +1,12 @@ module Main where import Prelude -import Assert +import Test.Assert mkValue :: Number -> Number mkValue id = id main = do let value = mkValue 1.0 - if value == 1.0 - then Debug.Trace.trace "Done" - else error "Not done" + assert $ value == 1.0 + Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/Functions.purs b/examples/passing/Functions.purs index d2fcad5..f0e3162 100644 --- a/examples/passing/Functions.purs +++ b/examples/passing/Functions.purs @@ -12,4 +12,4 @@ test4 = \(%%) -> 1.0 %% 2.0 test5 = \(+++) (***) -> 1.0 +++ 2.0 *** 3.0 -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/Functions2.purs b/examples/passing/Functions2.purs index ef2db66..e43d88e 100644 --- a/examples/passing/Functions2.purs +++ b/examples/passing/Functions2.purs @@ -1,13 +1,12 @@ module Main where import Prelude -import Assert +import Test.Assert test :: forall a b. a -> b -> a test = \const _ -> const main = do let value = test "Done" {} - if value == "Done" - then Debug.Trace.trace "Done" - else error "Not done" + assert' "Not done" $ value == "Done" + Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/Guards.purs b/examples/passing/Guards.purs index 44234f2..81fdc2e 100644 --- a/examples/passing/Guards.purs +++ b/examples/passing/Guards.purs @@ -3,7 +3,7 @@ module Main where import Prelude collatz = \x -> case x of - y | y % 2.0 == 0.0 -> y / 2.0 + y | y `mod` 2.0 == 0.0 -> y / 2.0 y -> y * 3.0 + 1.0 -- Guards have access to current scope @@ -26,4 +26,4 @@ testIndentation x y | x > 0.0 | otherwise = y - x -main = Debug.Trace.trace $ min "Done" "ZZZZ" +main = Control.Monad.Eff.Console.log $ min "Done" "ZZZZ" diff --git a/examples/passing/HoistError.purs b/examples/passing/HoistError.purs index 25f123a..5128a75 100644 --- a/examples/passing/HoistError.purs +++ b/examples/passing/HoistError.purs @@ -2,11 +2,11 @@ module Main where import Prelude import Control.Monad.Eff -import Debug.Trace -import Assert +import Control.Monad.Eff.Console +import Test.Assert main = do let x = 0.0 assert $ x == 0.0 let x = 1.0 + 1.0 - trace "Done" + log "Done" diff --git a/examples/passing/IfThenElseMaybe.purs b/examples/passing/IfThenElseMaybe.purs index 2419dc7..77da023 100644 --- a/examples/passing/IfThenElseMaybe.purs +++ b/examples/passing/IfThenElseMaybe.purs @@ -8,4 +8,4 @@ test1 = if true then Just 10 else Nothing test2 = if true then Nothing else Just 10 -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/ImplicitEmptyImport.purs b/examples/passing/ImplicitEmptyImport.purs index 3a452d6..82261f7 100644 --- a/examples/passing/ImplicitEmptyImport.purs +++ b/examples/passing/ImplicitEmptyImport.purs @@ -3,6 +3,6 @@ module Main where import Prelude main = do - Debug.Trace.trace "Hello" - Debug.Trace.trace "Goodbye" - Debug.Trace.trace "Done" + Control.Monad.Eff.Console.log "Hello" + Control.Monad.Eff.Console.log "Goodbye" + Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/ImportHiding.purs b/examples/passing/ImportHiding.purs index 093e206..4abac7a 100644 --- a/examples/passing/ImportHiding.purs +++ b/examples/passing/ImportHiding.purs @@ -1,6 +1,6 @@ module Main where -import Debug.Trace +import Control.Monad.Eff.Console import Prelude hiding ( show, -- a value Show, -- a type class diff --git a/examples/passing/InferRecFunWithConstrainedArgument.purs b/examples/passing/InferRecFunWithConstrainedArgument.purs index e96285d..2a10977 100644 --- a/examples/passing/InferRecFunWithConstrainedArgument.purs +++ b/examples/passing/InferRecFunWithConstrainedArgument.purs @@ -5,4 +5,4 @@ import Prelude test 100.0 = 100.0 test n = test(1.0 + n) -main = Debug.Trace.print $ test 0.0 +main = Control.Monad.Eff.Console.print $ test 0.0 diff --git a/examples/passing/InstanceBeforeClass.purs b/examples/passing/InstanceBeforeClass.purs index 2302f50..80690e9 100644 --- a/examples/passing/InstanceBeforeClass.purs +++ b/examples/passing/InstanceBeforeClass.purs @@ -8,4 +8,4 @@ instance fooNumber :: Foo Number where class Foo a where foo :: a -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/IntAndChar.purs b/examples/passing/IntAndChar.purs index 68cf54f..aac7edd 100644 --- a/examples/passing/IntAndChar.purs +++ b/examples/passing/IntAndChar.purs @@ -2,7 +2,7 @@ module Main where import Prelude import Control.Monad.Eff -import Assert +import Test.Assert f 1 = 1 f _ = 0 @@ -15,4 +15,4 @@ main = do assert $ f 0 == 0 assert $ g 'a' == 'a' assert $ g 'b' == 'b' - Debug.Trace.trace "Done" + Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/JSReserved.purs b/examples/passing/JSReserved.purs index 0761059..ee552ca 100644 --- a/examples/passing/JSReserved.purs +++ b/examples/passing/JSReserved.purs @@ -9,4 +9,4 @@ public = \return -> return this catch = catch -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/KindedType.purs b/examples/passing/KindedType.purs index 70c48df..adff8bb 100644 --- a/examples/passing/KindedType.purs +++ b/examples/passing/KindedType.purs @@ -30,4 +30,4 @@ class Clazz (a :: *) where instance clazzString :: Clazz String where def = "test" -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/Let.purs b/examples/passing/Let.purs index 560c1cb..d1aac9d 100644 --- a/examples/passing/Let.purs +++ b/examples/passing/Let.purs @@ -44,10 +44,10 @@ test10 _ = in f 10.0 main = do - Debug.Trace.print (test1 1.0) - Debug.Trace.print (test2 1.0 2.0) - Debug.Trace.print test3 - Debug.Trace.print test4 - Debug.Trace.print test5 - Debug.Trace.print test7 - Debug.Trace.print (test8 100.0) + 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) diff --git a/examples/passing/Let2.purs b/examples/passing/Let2.purs index ad112f9..8da1344 100644 --- a/examples/passing/Let2.purs +++ b/examples/passing/Let2.purs @@ -14,4 +14,4 @@ test = x = f 1.0 in not x -main = Debug.Trace.print test +main = Control.Monad.Eff.Console.print test diff --git a/examples/passing/LetInInstance.purs b/examples/passing/LetInInstance.purs index b72f255..d3e71bf 100644 --- a/examples/passing/LetInInstance.purs +++ b/examples/passing/LetInInstance.purs @@ -11,4 +11,4 @@ instance fooString :: Foo String where go :: String -> String go s = s -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/LiberalTypeSynonyms.purs b/examples/passing/LiberalTypeSynonyms.purs index defe959..61f2ebf 100644 --- a/examples/passing/LiberalTypeSynonyms.purs +++ b/examples/passing/LiberalTypeSynonyms.purs @@ -18,4 +18,4 @@ f :: (forall r. F r) -> String f g = case g { x: "Hello" } of { x = x } -> x -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/MPTCs.purs b/examples/passing/MPTCs.purs index 276ec79..8b2fef2 100644 --- a/examples/passing/MPTCs.purs +++ b/examples/passing/MPTCs.purs @@ -17,4 +17,4 @@ instance coerceRefl :: Coerce a a where instance coerceShow :: (Prelude.Show a) => Coerce a String where coerce = show -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/Match.purs b/examples/passing/Match.purs index 4f6b08e..6df2a18 100644 --- a/examples/passing/Match.purs +++ b/examples/passing/Match.purs @@ -6,4 +6,4 @@ data Foo a = Foo foo = \f -> case f of Foo -> "foo" -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/ModuleExport.purs b/examples/passing/ModuleExport.purs index df54e20..6c283e9 100644 --- a/examples/passing/ModuleExport.purs +++ b/examples/passing/ModuleExport.purs @@ -2,7 +2,7 @@ module A (module Prelude) where import Prelude module Main where - import Debug.Trace + import Control.Monad.Eff.Console import A main = do diff --git a/examples/passing/ModuleExportDupes.purs b/examples/passing/ModuleExportDupes.purs index 82d5347..72f807b 100644 --- a/examples/passing/ModuleExportDupes.purs +++ b/examples/passing/ModuleExportDupes.purs @@ -9,7 +9,7 @@ module C (module Prelude, module A) where import A module Main where - import Debug.Trace + import Control.Monad.Eff.Console import A import B import C diff --git a/examples/passing/ModuleExportExcluded.purs b/examples/passing/ModuleExportExcluded.purs index 18ef141..fd0130a 100644 --- a/examples/passing/ModuleExportExcluded.purs +++ b/examples/passing/ModuleExportExcluded.purs @@ -5,7 +5,7 @@ module A (module Prelude, foo) where foo _ = 0.0 module Main where - import Debug.Trace + import Control.Monad.Eff.Console import A (foo) otherwise = false diff --git a/examples/passing/ModuleExportHiding.purs b/examples/passing/ModuleExportHiding.purs index 4cea222..3a59b71 100644 --- a/examples/passing/ModuleExportHiding.purs +++ b/examples/passing/ModuleExportHiding.purs @@ -2,7 +2,7 @@ module A (module Prelude) where import Prelude module Main where - import Debug.Trace + import Control.Monad.Eff.Console import A hiding (module Prelude) otherwise = false diff --git a/examples/passing/ModuleExportQualified.purs b/examples/passing/ModuleExportQualified.purs index 7a84aec..88fa20e 100644 --- a/examples/passing/ModuleExportQualified.purs +++ b/examples/passing/ModuleExportQualified.purs @@ -2,7 +2,7 @@ module A (module Prelude) where import Prelude module Main where - import Debug.Trace + import Control.Monad.Eff.Console import qualified A as B main = do diff --git a/examples/passing/ModuleExportSelf.purs b/examples/passing/ModuleExportSelf.purs index 42399a0..cc2a001 100644 --- a/examples/passing/ModuleExportSelf.purs +++ b/examples/passing/ModuleExportSelf.purs @@ -4,7 +4,7 @@ module A (module A, module Prelude) where type Foo = Boolean module Main where - import Debug.Trace + import Control.Monad.Eff.Console import A bar :: Foo diff --git a/examples/passing/Monad.purs b/examples/passing/Monad.purs index 731d7bb..96b2afd 100644 --- a/examples/passing/Monad.purs +++ b/examples/passing/Monad.purs @@ -29,4 +29,4 @@ test1 = test id test2 = test maybe -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/MonadState.purs b/examples/passing/MonadState.purs index 4218c88..c2cd0e7 100644 --- a/examples/passing/MonadState.purs +++ b/examples/passing/MonadState.purs @@ -13,10 +13,10 @@ data State s a = State (s -> Tuple s a) runState s (State f) = f s instance functorState :: Functor (State s) where - (<$>) = liftM1 + map = liftM1 instance applyState :: Apply (State s) where - (<*>) = ap + apply = ap instance applicativeState :: Applicative (State s) where pure a = State $ \s -> Tuple s a @@ -44,5 +44,5 @@ test = runState "" $ do main = do let t1 = test - Debug.Trace.trace "Done" + Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/MultiArgFunctions.purs b/examples/passing/MultiArgFunctions.purs index a15a363..999d527 100644 --- a/examples/passing/MultiArgFunctions.purs +++ b/examples/passing/MultiArgFunctions.purs @@ -3,7 +3,7 @@ module Main where import Prelude import Data.Function import Control.Monad.Eff -import Debug.Trace +import Control.Monad.Eff.Console f = mkFn2 $ \a b -> runFn2 g a b + runFn2 g b a @@ -12,16 +12,16 @@ g = mkFn2 $ \a b -> case {} of _ -> runFn2 f (a - 0.0) (b - 0.0) main = do - runFn0 (mkFn0 $ \_ -> trace $ show 0.0) - runFn1 (mkFn1 $ \a -> trace $ show a) 0.0 - runFn2 (mkFn2 $ \a b -> trace $ show [a, b]) 0.0 0.0 - runFn3 (mkFn3 $ \a b c -> trace $ show [a, b, c]) 0.0 0.0 0.0 - runFn4 (mkFn4 $ \a b c d -> trace $ show [a, b, c, d]) 0.0 0.0 0.0 0.0 - runFn5 (mkFn5 $ \a b c d e -> trace $ show [a, b, c, d, e]) 0.0 0.0 0.0 0.0 0.0 - runFn6 (mkFn6 $ \a b c d e f -> trace $ show [a, b, c, d, e, f]) 0.0 0.0 0.0 0.0 0.0 0.0 - runFn7 (mkFn7 $ \a b c d e f g -> trace $ show [a, b, c, d, e, f, g]) 0.0 0.0 0.0 0.0 0.0 0.0 0.0 - runFn8 (mkFn8 $ \a b c d e f g h -> trace $ 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 -> trace $ 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-> trace $ 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 + runFn0 (mkFn0 $ \_ -> log $ show 0.0) + runFn1 (mkFn1 $ \a -> log $ show a) 0.0 + runFn2 (mkFn2 $ \a b -> log $ show [a, b]) 0.0 0.0 + runFn3 (mkFn3 $ \a b c -> log $ show [a, b, c]) 0.0 0.0 0.0 + runFn4 (mkFn4 $ \a b c d -> log $ show [a, b, c, d]) 0.0 0.0 0.0 0.0 + runFn5 (mkFn5 $ \a b c d e -> log $ show [a, b, c, d, e]) 0.0 0.0 0.0 0.0 0.0 + runFn6 (mkFn6 $ \a b c d e f -> log $ show [a, b, c, d, e, f]) 0.0 0.0 0.0 0.0 0.0 0.0 + runFn7 (mkFn7 $ \a b c d e f g -> log $ show [a, b, c, d, e, f, g]) 0.0 0.0 0.0 0.0 0.0 0.0 0.0 + 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 - trace "Done!" + log "Done!" diff --git a/examples/passing/MutRec.purs b/examples/passing/MutRec.purs index bdf1797..afee9cd 100644 --- a/examples/passing/MutRec.purs +++ b/examples/passing/MutRec.purs @@ -16,4 +16,4 @@ evenToNumber (Even n) = oddToNumber n + 0.0 oddToNumber (Odd n) = evenToNumber n + 0.0 -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/MutRec2.purs b/examples/passing/MutRec2.purs index 8a98638..762c676 100644 --- a/examples/passing/MutRec2.purs +++ b/examples/passing/MutRec2.purs @@ -16,4 +16,4 @@ g b = case b of B a -> f a showN :: A -> S showN a = f a -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/MutRec3.purs b/examples/passing/MutRec3.purs index 1150f4f..a22ac5d 100644 --- a/examples/passing/MutRec3.purs +++ b/examples/passing/MutRec3.purs @@ -16,4 +16,4 @@ g b = case b of B a -> f a showN :: A -> S showN a = f a -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/NamedPatterns.purs b/examples/passing/NamedPatterns.purs index 28dc1c2..3e0d557 100644 --- a/examples/passing/NamedPatterns.purs +++ b/examples/passing/NamedPatterns.purs @@ -6,4 +6,4 @@ foo = \x -> case x of y@{ foo = "Foo" } -> y y -> y -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/NegativeBinder.purs b/examples/passing/NegativeBinder.purs index 3433f5d..63ba76a 100644 --- a/examples/passing/NegativeBinder.purs +++ b/examples/passing/NegativeBinder.purs @@ -6,4 +6,4 @@ test :: Number -> Boolean test -1.0 = false test _ = true -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/Nested.purs b/examples/passing/Nested.purs index 5ac3ffc..0f19014 100644 --- a/examples/passing/Nested.purs +++ b/examples/passing/Nested.purs @@ -6,4 +6,4 @@ data Extend r a = Extend { prev :: r a, next :: a } data Matrix r a = Square (r (r a)) | Bigger (Matrix (Extend r) a) -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/NestedTypeSynonyms.purs b/examples/passing/NestedTypeSynonyms.purs index 9f9f2d5..abb9ea7 100644 --- a/examples/passing/NestedTypeSynonyms.purs +++ b/examples/passing/NestedTypeSynonyms.purs @@ -8,4 +8,4 @@ type Y = X -> X fn :: Y fn a = a -main = Debug.Trace.print (fn "Done") +main = Control.Monad.Eff.Console.print (fn "Done") diff --git a/examples/passing/NestedWhere.purs b/examples/passing/NestedWhere.purs index 85e3901..4867ae8 100644 --- a/examples/passing/NestedWhere.purs +++ b/examples/passing/NestedWhere.purs @@ -9,4 +9,4 @@ f x = g x go x = go1 (x - 1.0) go1 x = go x -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/Newtype.purs b/examples/passing/Newtype.purs index e6e310d..c9edbda 100644 --- a/examples/passing/Newtype.purs +++ b/examples/passing/Newtype.purs @@ -1,8 +1,8 @@ module Main where -import Prelude +import Prelude hiding (apply) import Control.Monad.Eff -import Debug.Trace +import Control.Monad.Eff.Console newtype Thing = Thing String @@ -20,4 +20,4 @@ main = do print $ Thing "hello" print $ Box 42.0 print $ apply Box 9000.0 - trace "Done" + log "Done" diff --git a/examples/passing/NewtypeEff.purs b/examples/passing/NewtypeEff.purs index 8054d43..ad9fdbf 100644 --- a/examples/passing/NewtypeEff.purs +++ b/examples/passing/NewtypeEff.purs @@ -1,19 +1,19 @@ module Main where import Prelude -import Debug.Trace +import Control.Monad.Eff.Console import Control.Monad.Eff -newtype T a = T (Eff (trace :: Trace) a) +newtype T a = T (Eff (console :: CONSOLE) a) -runT :: forall a. T a -> Eff (trace :: Trace) a +runT :: forall a. T a -> Eff (console :: CONSOLE) a runT (T t) = t instance functorT :: Functor T where - (<$>) f (T t) = T (f <$> t) + map f (T t) = T (f <$> t) instance applyT :: Apply T where - (<*>) (T f) (T x) = T (f <*> x) + apply (T f) (T x) = T (f <*> x) instance applicativeT :: Applicative T where pure t = T (pure t) @@ -24,6 +24,6 @@ instance bindT :: Bind T where instance monadT :: Monad T main = runT do - T $ trace "Done" - T $ trace "Done" - T $ trace "Done" + T $ log "Done" + T $ log "Done" + T $ log "Done" diff --git a/examples/passing/NewtypeWithRecordUpdate.purs b/examples/passing/NewtypeWithRecordUpdate.purs index 4fd81cc..1a68534 100644 --- a/examples/passing/NewtypeWithRecordUpdate.purs +++ b/examples/passing/NewtypeWithRecordUpdate.purs @@ -3,7 +3,7 @@ module Main where import Prelude -import Debug.Trace +import Control.Monad.Eff.Console newtype NewType a = NewType (Object a) @@ -13,4 +13,4 @@ rec1 = { a: 0.0, b: 0.0, c: 0.0 } rec2 :: NewType (a :: Number, b :: Number, c :: Number) rec2 = NewType (rec1 { a = 1.0 }) -main = trace "Done" +main = log "Done" diff --git a/examples/passing/ObjectGetter.purs b/examples/passing/ObjectGetter.purs index 5224d79..addb57f 100644 --- a/examples/passing/ObjectGetter.purs +++ b/examples/passing/ObjectGetter.purs @@ -7,7 +7,7 @@ getX = _.x point = { x: 1.0, y: 0.0 } main = do - Debug.Trace.print $ getX point - Debug.Trace.trace $ _." 123 string Prop Name " { " 123 string Prop Name ": "OK" } - Debug.Trace.trace $ (_.x >>> _.y) { x: { y: "Nested" } } - Debug.Trace.trace $ _.value { value: "Done!" } + 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!" } diff --git a/examples/passing/ObjectSynonym.purs b/examples/passing/ObjectSynonym.purs index f9b60a6..34fb7fa 100644 --- a/examples/passing/ObjectSynonym.purs +++ b/examples/passing/ObjectSynonym.purs @@ -12,4 +12,4 @@ type Outer = { inner :: Inner } outer :: Outer outer = { inner: inner } -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/ObjectUpdate.purs b/examples/passing/ObjectUpdate.purs index 98fc71e..de6f358 100644 --- a/examples/passing/ObjectUpdate.purs +++ b/examples/passing/ObjectUpdate.purs @@ -17,4 +17,4 @@ polyUpdate = \o -> o { foo = "Foo" } inferPolyUpdate = \o -> o { foo = "Foo" } -main = Debug.Trace.trace ((update1 {foo: ""}).foo) +main = Control.Monad.Eff.Console.log ((update1 {foo: ""}).foo) diff --git a/examples/passing/ObjectUpdate2.purs b/examples/passing/ObjectUpdate2.purs index 610f4a5..da2bf11 100644 --- a/examples/passing/ObjectUpdate2.purs +++ b/examples/passing/ObjectUpdate2.purs @@ -14,4 +14,4 @@ test = blah x { baz = "blah" } -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/ObjectUpdater.purs b/examples/passing/ObjectUpdater.purs index 929416c..17246c6 100644 --- a/examples/passing/ObjectUpdater.purs +++ b/examples/passing/ObjectUpdater.purs @@ -2,8 +2,8 @@ module Main where import Prelude import Control.Monad.Eff -import Debug.Trace -import Assert +import Control.Monad.Eff.Console +import Test.Assert getValue :: forall e. Eff (| e) Boolean getValue = return true diff --git a/examples/passing/ObjectWildcards.purs b/examples/passing/ObjectWildcards.purs index eea7236..5a0d4c8 100644 --- a/examples/passing/ObjectWildcards.purs +++ b/examples/passing/ObjectWildcards.purs @@ -2,8 +2,8 @@ module Main where import Prelude import Control.Monad.Eff -import Debug.Trace -import Assert +import Control.Monad.Eff.Console +import Test.Assert mkRecord = { foo: _, bar: _, baz: "baz" } @@ -17,4 +17,4 @@ main = do point <- { x: _, y: x } <$> return 2.0 assert $ point.x == 2.0 assert $ point.y == 1.0 - trace (mkRecord 1.0 "Done!").bar + log (mkRecord 1.0 "Done!").bar diff --git a/examples/passing/Objects.purs b/examples/passing/Objects.purs index 3227c07..810dc80 100644 --- a/examples/passing/Objects.purs +++ b/examples/passing/Objects.purs @@ -1,6 +1,6 @@ module Main where -import Prelude +import Prelude hiding (append) test = \x -> x.foo + x.bar + 1.0 @@ -32,4 +32,4 @@ test6 = case { "***": 1.0 } of test7 {a: snoog , b : blah } = blah -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/OneConstructor.purs b/examples/passing/OneConstructor.purs index bbbcef5..149e1e2 100644 --- a/examples/passing/OneConstructor.purs +++ b/examples/passing/OneConstructor.purs @@ -6,4 +6,4 @@ data One a = One a one' (One a) = a -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/OperatorAssociativity.purs b/examples/passing/OperatorAssociativity.purs index b73de61..7ee50e6 100644 --- a/examples/passing/OperatorAssociativity.purs +++ b/examples/passing/OperatorAssociativity.purs @@ -2,8 +2,8 @@ module Main where import Prelude import Control.Monad.Eff -import Debug.Trace -import Assert +import Control.Monad.Eff.Console +import Test.Assert bug :: Number -> Number -> Number bug a b = 0.0 - (a - b) @@ -22,4 +22,4 @@ main = do 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) - trace "Success!" + log "Success!" diff --git a/examples/passing/OperatorInlining.purs b/examples/passing/OperatorInlining.purs index 83cb24c..172babd 100644 --- a/examples/passing/OperatorInlining.purs +++ b/examples/passing/OperatorInlining.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Debug.Trace +import Control.Monad.Eff.Console main = do diff --git a/examples/passing/OperatorSections.purs b/examples/passing/OperatorSections.purs index 1b51c0e..a9c426c 100644 --- a/examples/passing/OperatorSections.purs +++ b/examples/passing/OperatorSections.purs @@ -1,11 +1,11 @@ module Main where import Prelude -import Assert +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 - Debug.Trace.trace "Done!" + Control.Monad.Eff.Console.log "Done!" diff --git a/examples/passing/Operators.purs b/examples/passing/Operators.purs index b8b519f..0d6d86f 100644 --- a/examples/passing/Operators.purs +++ b/examples/passing/Operators.purs @@ -2,7 +2,7 @@ module Main where import Prelude import Control.Monad.Eff -import Debug.Trace +import Control.Monad.Eff.Console (?!) :: forall a. a -> a -> a (?!) x _ = x @@ -96,4 +96,4 @@ main = do let t18 = test18 let t19 = test19 let t20 = test20 - trace "Done" + log "Done" diff --git a/examples/passing/OptimizerBug.purs b/examples/passing/OptimizerBug.purs index cdddb1f..ea371de 100644 --- a/examples/passing/OptimizerBug.purs +++ b/examples/passing/OptimizerBug.purs @@ -6,4 +6,4 @@ x a = 1.0 + y a y a = x a -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/PartialFunction.purs b/examples/passing/PartialFunction.purs index 03d0943..f0c4fd3 100644 --- a/examples/passing/PartialFunction.purs +++ b/examples/passing/PartialFunction.purs @@ -1,10 +1,10 @@ module Main where import Prelude -import Assert +import Test.Assert fn :: Number -> Number fn 0.0 = 0.0 fn 1.0 = 2.0 -main = assertPartial $ \_ -> fn 2.0 +main = assertThrows $ \_ -> fn 2.0 diff --git a/examples/passing/Patterns.purs b/examples/passing/Patterns.purs index 4a63ad5..9606afa 100644 --- a/examples/passing/Patterns.purs +++ b/examples/passing/Patterns.purs @@ -19,4 +19,4 @@ isDesc :: Array Number -> Boolean isDesc [x, y] | x > y = true isDesc _ = false -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/Person.purs b/examples/passing/Person.purs index fba54ae..fa3384e 100644 --- a/examples/passing/Person.purs +++ b/examples/passing/Person.purs @@ -8,4 +8,4 @@ showPerson :: Person -> String showPerson = \p -> case p of Person o -> o.name ++ ", aged " ++ show o.age -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/Rank2Data.purs b/examples/passing/Rank2Data.purs index 2326d67..0f67803 100644 --- a/examples/passing/Rank2Data.purs +++ b/examples/passing/Rank2Data.purs @@ -1,6 +1,6 @@ module Main where -import Prelude +import Prelude hiding (add) data Id = Id forall a. a -> a @@ -26,4 +26,4 @@ two = succ zero' four = add two two fourNumber = runNat four -main = Debug.Trace.trace "Done'" +main = Control.Monad.Eff.Console.log "Done'" diff --git a/examples/passing/Rank2Object.purs b/examples/passing/Rank2Object.purs index e25516f..c9651e6 100644 --- a/examples/passing/Rank2Object.purs +++ b/examples/passing/Rank2Object.purs @@ -1,11 +1,11 @@ module Main where import Prelude -import Debug.Trace +import Control.Monad.Eff.Console data Foo = Foo { id :: forall a. a -> a } foo :: Foo -> Number foo (Foo { id = f }) = f 0.0 -main = trace "Done" +main = log "Done" diff --git a/examples/passing/Rank2TypeSynonym.purs b/examples/passing/Rank2TypeSynonym.purs index 11a51d2..a1977da 100644 --- a/examples/passing/Rank2TypeSynonym.purs +++ b/examples/passing/Rank2TypeSynonym.purs @@ -13,4 +13,4 @@ bar = foo 3.0 main = do x <- bar - Debug.Trace.print x + Control.Monad.Eff.Console.print x diff --git a/examples/passing/Rank2Types.purs b/examples/passing/Rank2Types.purs index fb92ed8..7af12ae 100644 --- a/examples/passing/Rank2Types.purs +++ b/examples/passing/Rank2Types.purs @@ -8,4 +8,4 @@ test1 = \f -> f 0.0 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 = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/RebindableSyntax.purs b/examples/passing/RebindableSyntax.purs index 533e302..df00ce1 100644 --- a/examples/passing/RebindableSyntax.purs +++ b/examples/passing/RebindableSyntax.purs @@ -20,10 +20,10 @@ runConst :: forall a b. Const a b -> a runConst (Const a) = a instance functorConst :: Functor (Const a) where - (<$>) _ (Const a) = Const a + map _ (Const a) = Const a instance applyConst :: (Semigroup a) => Apply (Const a) where - (<*>) (Const a1) (Const a2) = Const (a1 <> a2) + apply (Const a1) (Const a2) = Const (a1 <> a2) example2 :: Const String Unit example2 = do @@ -35,5 +35,5 @@ example2 = do bind x f = x *> f unit main = do - Debug.Trace.trace example1 - Debug.Trace.trace $ runConst example2 + Control.Monad.Eff.Console.log example1 + Control.Monad.Eff.Console.log $ runConst example2 diff --git a/examples/passing/Recursion.purs b/examples/passing/Recursion.purs index f6c88f9..67d3094 100644 --- a/examples/passing/Recursion.purs +++ b/examples/passing/Recursion.purs @@ -7,4 +7,4 @@ fib = \n -> case n of 1.0 -> 1.0 n -> fib (n - 1.0) + fib (n - 2.0) -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/ReservedWords.purs b/examples/passing/ReservedWords.purs index 89f023e..ff233bf 100644 --- a/examples/passing/ReservedWords.purs +++ b/examples/passing/ReservedWords.purs @@ -12,4 +12,4 @@ p = o { type = "p" } f :: forall r. { type :: String | r } -> String f { type = "p" } = "Done" -main = Debug.Trace.trace $ f { type: p.type, foo: "bar" } +main = Control.Monad.Eff.Console.log $ f { type: p.type, foo: "bar" } diff --git a/examples/passing/RowConstructors.purs b/examples/passing/RowConstructors.purs index 0ed416f..593d94c 100644 --- a/examples/passing/RowConstructors.purs +++ b/examples/passing/RowConstructors.purs @@ -39,4 +39,4 @@ wildcard { w: w } = { x: w, y: w, z: w, w: w } wildcard' :: { | Quux _ } -> Number wildcard' { q: q } = q -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/RowPolyInstanceContext.purs b/examples/passing/RowPolyInstanceContext.purs index fe4ad53..f0543af 100644 --- a/examples/passing/RowPolyInstanceContext.purs +++ b/examples/passing/RowPolyInstanceContext.purs @@ -19,4 +19,4 @@ test2 = state $ \o -> o { foo = o.foo ++ "!" } main = do let t1 = test1 let t2 = test2 - Debug.Trace.trace "Done" + Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/RuntimeScopeIssue.purs b/examples/passing/RuntimeScopeIssue.purs index 24e7923..f6800c8 100644 --- a/examples/passing/RuntimeScopeIssue.purs +++ b/examples/passing/RuntimeScopeIssue.purs @@ -16,4 +16,4 @@ instance bNumber :: B Number where b 0.0 = false b n = a (n - 1.0) -main = Debug.Trace.print $ a 10.0 +main = Control.Monad.Eff.Console.print $ a 10.0 diff --git a/examples/passing/ScopedTypeVariables.purs b/examples/passing/ScopedTypeVariables.purs index bfc0590..5526059 100644 --- a/examples/passing/ScopedTypeVariables.purs +++ b/examples/passing/ScopedTypeVariables.purs @@ -33,4 +33,4 @@ test4 = h j x = x -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/Sequence.purs b/examples/passing/Sequence.purs index 289a618..692fbd0 100644 --- a/examples/passing/Sequence.purs +++ b/examples/passing/Sequence.purs @@ -12,4 +12,4 @@ instance sequenceList :: Sequence List where sequence Nil = pure Nil sequence (Cons x xs) = Cons <$> x <*> sequence xs -main = sequence $ Cons (Debug.Trace.trace "Done") Nil +main = sequence $ Cons (Control.Monad.Eff.Console.log "Done") Nil diff --git a/examples/passing/SequenceDesugared.purs b/examples/passing/SequenceDesugared.purs index fbc184c..622f1c3 100644 --- a/examples/passing/SequenceDesugared.purs +++ b/examples/passing/SequenceDesugared.purs @@ -31,7 +31,7 @@ sequenceList''' = Sequence ((\val -> case val of Cons x xs -> Cons <$> x <*> sequence sequenceList''' xs) :: forall m a. (Monad m) => List (m a) -> m (List a)) main = do - sequence sequenceList $ Cons (Debug.Trace.trace "Done") Nil - sequence sequenceList' $ Cons (Debug.Trace.trace "Done") Nil - sequence sequenceList'' $ Cons (Debug.Trace.trace "Done") Nil - sequence sequenceList''' $ Cons (Debug.Trace.trace "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 (Control.Monad.Eff.Console.log "Done") Nil diff --git a/examples/passing/ShadowedRename.purs b/examples/passing/ShadowedRename.purs index 3c665c6..4b0c317 100644 --- a/examples/passing/ShadowedRename.purs +++ b/examples/passing/ShadowedRename.purs @@ -2,8 +2,8 @@ module Main where import Prelude import Control.Monad.Eff -import Debug.Trace -import Assert +import Control.Monad.Eff.Console +import Test.Assert foo foo = let foo_1 = \_ -> foo foo_2 = foo_1 unit + 1.0 @@ -11,4 +11,4 @@ foo foo = let foo_1 = \_ -> foo main = do assert $ foo 1.0 == 2.0 - trace "Done" + log "Done" diff --git a/examples/passing/ShadowedTCO.purs b/examples/passing/ShadowedTCO.purs index ceb9883..fa7e34d 100644 --- a/examples/passing/ShadowedTCO.purs +++ b/examples/passing/ShadowedTCO.purs @@ -1,6 +1,6 @@ module Main where -import Prelude +import Prelude hiding (add) runNat f = f 0.0 (\n -> n + 1.0) @@ -15,4 +15,4 @@ two = succ one' four = add two two fourNumber = runNat four -main = Debug.Trace.trace $ show fourNumber +main = Control.Monad.Eff.Console.log $ show fourNumber diff --git a/examples/passing/ShadowedTCOLet.purs b/examples/passing/ShadowedTCOLet.purs index 8c9c6a0..e3c1c7e 100644 --- a/examples/passing/ShadowedTCOLet.purs +++ b/examples/passing/ShadowedTCOLet.purs @@ -6,4 +6,4 @@ f x y z = let f 1.0 2.0 3.0 = 1.0 in f x z y -main = Debug.Trace.trace $ show $ f 1.0 3.0 2.0 +main = Control.Monad.Eff.Console.log $ show $ f 1.0 3.0 2.0 diff --git a/examples/passing/SignedNumericLiterals.purs b/examples/passing/SignedNumericLiterals.purs index 054f7a5..12937db 100644 --- a/examples/passing/SignedNumericLiterals.purs +++ b/examples/passing/SignedNumericLiterals.purs @@ -14,4 +14,4 @@ f x = -x test1 = 2.0 - 1.0 -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/Superclasses1.purs b/examples/passing/Superclasses1.purs index db9a039..cdf075f 100644 --- a/examples/passing/Superclasses1.purs +++ b/examples/passing/Superclasses1.purs @@ -17,4 +17,4 @@ instance clNumber :: Cl Number where test :: forall a. (Cl a) => a -> a test a = su (cl a a) -main = Debug.Trace.print $ test 10.0 +main = Control.Monad.Eff.Console.print $ test 10.0 diff --git a/examples/passing/Superclasses2.purs b/examples/passing/Superclasses2.purs index 09dfb63..5f14df3 100644 --- a/examples/passing/Superclasses2.purs +++ b/examples/passing/Superclasses2.purs @@ -1,7 +1,6 @@ module Main where import Prelude -import Prelude.Unsafe (unsafeIndex) class Su a where su :: a -> a @@ -21,4 +20,4 @@ instance clNumber :: Cl Number where test :: forall a. (Cl a) => a -> Array a test x = su [cl x x] -main = Debug.Trace.print $ test 10.0 `unsafeIndex` 0.0 +main = Control.Monad.Eff.Console.print $ test 10.0 diff --git a/examples/passing/Superclasses3.purs b/examples/passing/Superclasses3.purs index 7fa8ffa..d1135a0 100644 --- a/examples/passing/Superclasses3.purs +++ b/examples/passing/Superclasses3.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Debug.Trace +import Control.Monad.Eff.Console import Control.Monad.Eff class (Monad m) <= MonadWriter w m where @@ -16,16 +16,16 @@ test w = do tell w tell w -data MTrace a = MTrace (Eff (trace :: Trace) a) +data MTrace a = MTrace (Eff (console :: CONSOLE) a) -runMTrace :: forall a. MTrace a -> Eff (trace :: Trace) a +runMTrace :: forall a. MTrace a -> Eff (console :: CONSOLE) a runMTrace (MTrace a) = a instance functorMTrace :: Functor MTrace where - (<$>) = liftM1 + map = liftM1 instance applyMTrace :: Apply MTrace where - (<*>) = ap + apply = ap instance applicativeMTrace :: Applicative MTrace where pure = MTrace <<< return @@ -36,6 +36,6 @@ instance bindMTrace :: Bind MTrace where instance monadMTrace :: Monad MTrace instance writerMTrace :: MonadWriter String MTrace where - tell s = MTrace (trace s) + tell s = MTrace (log s) main = runMTrace $ test "Done" diff --git a/examples/passing/TCOCase.purs b/examples/passing/TCOCase.purs index 2f8454a..654aa53 100644 --- a/examples/passing/TCOCase.purs +++ b/examples/passing/TCOCase.purs @@ -4,7 +4,7 @@ import Prelude data Data = One | More Data -main = Debug.Trace.trace (from (to 10000.0 One)) +main = Control.Monad.Eff.Console.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 index 505f38c..1fad423 100644 --- a/examples/passing/TailCall.purs +++ b/examples/passing/TailCall.purs @@ -14,4 +14,4 @@ loop x = loop (x + 1.0) notATailCall = \x -> (\notATailCall -> notATailCall x) (\x -> x) -main = Debug.Trace.print (test 0.0 (1.0 `C` (2.0 `C` (3.0 `C` N)))) +main = Control.Monad.Eff.Console.print (test 0.0 (1.0 `C` (2.0 `C` (3.0 `C` N)))) diff --git a/examples/passing/Tick.purs b/examples/passing/Tick.purs index 718420f..6b8f19e 100644 --- a/examples/passing/Tick.purs +++ b/examples/passing/Tick.purs @@ -4,4 +4,4 @@ import Prelude test' x = x -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/TopLevelCase.purs b/examples/passing/TopLevelCase.purs index 557ab6f..1e11b7d 100644 --- a/examples/passing/TopLevelCase.purs +++ b/examples/passing/TopLevelCase.purs @@ -5,8 +5,8 @@ import Prelude gcd :: Number -> Number -> Number gcd 0.0 x = x gcd x 0.0 = x -gcd x y | x > y = gcd (x % y) y -gcd x y = gcd (y % x) x +gcd x y | x > y = gcd (x `mod` y) y +gcd x y = gcd (y `mod` x) x guardsTest [x] | x > 0.0 = [] guardsTest xs = xs @@ -15,4 +15,4 @@ data A = A parseTest A 0.0 = 0.0 -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/TypeClassMemberOrderChange.purs b/examples/passing/TypeClassMemberOrderChange.purs index f05dcfe..2e38b7d 100644 --- a/examples/passing/TypeClassMemberOrderChange.purs +++ b/examples/passing/TypeClassMemberOrderChange.purs @@ -10,4 +10,4 @@ instance testBoolean :: Test Boolean where val = true fn x y = y -main = Debug.Trace.trace (show (fn true val)) +main = Control.Monad.Eff.Console.log (show (fn true val)) diff --git a/examples/passing/TypeClasses.purs b/examples/passing/TypeClasses.purs index a9b2f1c..1dfdf51 100644 --- a/examples/passing/TypeClasses.purs +++ b/examples/passing/TypeClasses.purs @@ -22,10 +22,10 @@ instance showData :: (Prelude.Show a) => Prelude.Show (Data a) where test3 = \_ -> show (Data "testing") instance functorData :: Functor Data where - (<$>) = liftM1 + map = liftM1 instance applyData :: Apply Data where - (<*>) = ap + apply = ap instance applicativeData :: Applicative Data where pure = Data @@ -38,10 +38,10 @@ instance monadData :: Monad Data data Maybe a = Nothing | Just a instance functorMaybe :: Functor Maybe where - (<$>) = liftM1 + map = liftM1 instance applyMaybe :: Apply Maybe where - (<*>) = ap + apply = ap instance applicativeMaybe :: Applicative Maybe where pure = Just @@ -65,5 +65,5 @@ test9 _ = runReader 0.0 $ do n <- ask return $ n + 1.0 -main = Debug.Trace.trace (test7 "Done") +main = Control.Monad.Eff.Console.log (test7 "Done") diff --git a/examples/passing/TypeClassesInOrder.purs b/examples/passing/TypeClassesInOrder.purs index d576a84..a34db92 100644 --- a/examples/passing/TypeClassesInOrder.purs +++ b/examples/passing/TypeClassesInOrder.purs @@ -8,4 +8,4 @@ class Foo a where instance fooString :: Foo String where foo s = s -main = Debug.Trace.trace $ foo "Done" +main = Control.Monad.Eff.Console.log $ foo "Done" diff --git a/examples/passing/TypeClassesWithOverlappingTypeVariables.purs b/examples/passing/TypeClassesWithOverlappingTypeVariables.purs index 66b8b80..9b5c6a9 100644 --- a/examples/passing/TypeClassesWithOverlappingTypeVariables.purs +++ b/examples/passing/TypeClassesWithOverlappingTypeVariables.purs @@ -5,7 +5,7 @@ import Prelude data Either a b = Left a | Right b instance functorEither :: Prelude.Functor (Either a) where - (<$>) _ (Left x) = Left x - (<$>) f (Right y) = Right (f y) + map _ (Left x) = Left x + map f (Right y) = Right (f y) -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/TypeDecl.purs b/examples/passing/TypeDecl.purs index 9b78b38..76b32c4 100644 --- a/examples/passing/TypeDecl.purs +++ b/examples/passing/TypeDecl.purs @@ -9,4 +9,4 @@ iterate :: forall a. Number -> (a -> a) -> a -> a iterate 0.0 f a = a iterate n f a = iterate (n - 1.0) f (f a) -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/TypeSynonymInData.purs b/examples/passing/TypeSynonymInData.purs index 591ef53..62da487 100644 --- a/examples/passing/TypeSynonymInData.purs +++ b/examples/passing/TypeSynonymInData.purs @@ -8,4 +8,4 @@ data Foo a = Foo (A a) | Bar foo (Foo []) = Bar -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/TypeSynonyms.purs b/examples/passing/TypeSynonyms.purs index 4dbc27f..3cc4cf9 100644 --- a/examples/passing/TypeSynonyms.purs +++ b/examples/passing/TypeSynonyms.purs @@ -24,4 +24,4 @@ fst = test1 :: forall a b c. Lens (Pair (Pair a b) c) a test1 = composeLenses fst fst -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/TypeWildcards.purs b/examples/passing/TypeWildcards.purs index fa3f761..f6f3da2 100644 --- a/examples/passing/TypeWildcards.purs +++ b/examples/passing/TypeWildcards.purs @@ -12,4 +12,4 @@ test f a = go (f a) a go a1 a2 | a1 == a2 = a1 go a1 _ = go (f a1) a1 -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/TypeWildcardsRecordExtension.purs b/examples/passing/TypeWildcardsRecordExtension.purs index 3a636f4..615fe9e 100644 --- a/examples/passing/TypeWildcardsRecordExtension.purs +++ b/examples/passing/TypeWildcardsRecordExtension.purs @@ -5,4 +5,4 @@ import Prelude foo :: forall a. {b :: Number | a} -> {b :: Number | _} foo f = f -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/TypedWhere.purs b/examples/passing/TypedWhere.purs index 690c6b9..1773696 100644 --- a/examples/passing/TypedWhere.purs +++ b/examples/passing/TypedWhere.purs @@ -14,4 +14,4 @@ lefts = go N go ls (C (L a) rest) = go (C a ls) rest go ls (C _ rest) = go ls rest -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/UnderscoreIdent.purs b/examples/passing/UnderscoreIdent.purs index c669f2e..318bda3 100644 --- a/examples/passing/UnderscoreIdent.purs +++ b/examples/passing/UnderscoreIdent.purs @@ -8,4 +8,4 @@ type Type_name = Data_type done (Con_2 s) = s -main = Debug.Trace.trace (done (Con_2 "Done")) +main = Control.Monad.Eff.Console.log (done (Con_2 "Done")) diff --git a/examples/passing/Unit.purs b/examples/passing/Unit.purs index bda473c..5e55528 100644 --- a/examples/passing/Unit.purs +++ b/examples/passing/Unit.purs @@ -1,6 +1,6 @@ module Main where import Prelude -import Debug.Trace +import Control.Monad.Eff.Console main = print (const unit $ "Hello world") diff --git a/examples/passing/UnknownInTypeClassLookup.purs b/examples/passing/UnknownInTypeClassLookup.purs index 7b2cdc7..94f929f 100644 --- a/examples/passing/UnknownInTypeClassLookup.purs +++ b/examples/passing/UnknownInTypeClassLookup.purs @@ -11,4 +11,4 @@ test _ _ = "Done" runTest a = test a a -main = Debug.Trace.trace $ runTest 0.0 +main = Control.Monad.Eff.Console.log $ runTest 0.0 diff --git a/examples/passing/Where.purs b/examples/passing/Where.purs index 1493f8c..942255f 100644 --- a/examples/passing/Where.purs +++ b/examples/passing/Where.purs @@ -40,10 +40,10 @@ test7 x = go x go y = go $ (y + x / y) / 2.0 main = do - Debug.Trace.print (test1 1.0) - Debug.Trace.print (test2 1.0 2.0) - Debug.Trace.print test3 - Debug.Trace.print test4 - Debug.Trace.print test5 - Debug.Trace.print test6 - Debug.Trace.print (test7 100.0) + 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) diff --git a/examples/passing/iota.purs b/examples/passing/iota.purs index 48d98fb..be0430e 100644 --- a/examples/passing/iota.purs +++ b/examples/passing/iota.purs @@ -6,4 +6,4 @@ k = \x -> \y -> x iota = \x -> x s k -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/s.purs b/examples/passing/s.purs index c26a50e..041b125 100644 --- a/examples/passing/s.purs +++ b/examples/passing/s.purs @@ -4,4 +4,4 @@ import Prelude s = \x y z -> x z (y z) -main = Debug.Trace.trace "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/psc-publish/Main.hs b/psc-publish/Main.hs index 301c3e7..d691d2a 100644 --- a/psc-publish/Main.hs +++ b/psc-publish/Main.hs @@ -1,315 +1,38 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Main where -import Prelude hiding (userError) - -import Data.Maybe -import Data.Char (isSpace) -import Data.String (fromString) -import Data.List (stripPrefix, isSuffixOf, (\\), nubBy) -import Data.List.Split (splitOn) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Version -import Data.Function (on) -import Safe (headMay) - -import qualified Data.ByteString.Lazy.Char8 as BL -import qualified Data.Text as T - +import Data.Version (Version(..), showVersion) import qualified Data.Aeson as A -import Data.Aeson.BetterErrors - -import Control.Applicative -import Control.Category ((>>>)) -import Control.Arrow ((***)) -import Control.Exception (catch, try) -import Control.Monad.Trans.Except -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer +import qualified Data.ByteString.Lazy.Char8 as BL -import System.Directory (doesFileExist) -import System.Process (readProcess) -import System.Exit (exitFailure) -import qualified System.FilePath.Glob as Glob +import Options.Applicative hiding (str) -import Web.Bower.PackageMeta (PackageMeta(..), BowerError(..), PackageName, - runPackageName, parsePackageName, Repository(..)) -import qualified Web.Bower.PackageMeta as Bower +import qualified Paths_purescript as Paths +import Language.PureScript.Publish -import qualified Language.PureScript as P (version) -import qualified Language.PureScript.Docs as D -import Utils -import ErrorsWarnings +dryRun :: Parser Bool +dryRun = switch $ + long "dry-run" + <> help "Produce no output, and don't require a tagged version to be checked out." main :: IO () -main = do - pkg <- preparePackage - BL.putStrLn (A.encode pkg) - --- | Attempt to retrieve package metadata from the current directory. --- Calls exitFailure if no package metadata could be retrieved. -preparePackage :: IO D.UploadedPackage -preparePackage = - runPrepareM preparePackage' - >>= either (\e -> printError e >> exitFailure) - handleWarnings - where - handleWarnings (result, warns) = do - printWarnings warns - return result - -newtype PrepareM a = - PrepareM { unPrepareM :: WriterT [PackageWarning] (ExceptT PackageError IO) a } - deriving (Functor, Applicative, Monad, - MonadWriter [PackageWarning], - MonadError PackageError) - --- This MonadIO instance ensures that IO errors don't crash the program. -instance MonadIO PrepareM where - liftIO act = - lift' (try act) >>= either (otherError . IOExceptionThrown) return - where - lift' :: IO a -> PrepareM a - lift' = PrepareM . lift . lift - -runPrepareM :: PrepareM a -> IO (Either PackageError (a, [PackageWarning])) -runPrepareM = runExceptT . runWriterT . unPrepareM - -warn :: PackageWarning -> PrepareM () -warn w = tell [w] - -userError :: UserError -> PrepareM a -userError = throwError . UserError - -internalError :: InternalError -> PrepareM a -internalError = throwError . InternalError - -otherError :: OtherError -> PrepareM a -otherError = throwError . OtherError - -catchLeft :: Applicative f => Either a b -> (a -> f b) -> f b -catchLeft a f = either f pure a - -preparePackage' :: PrepareM D.UploadedPackage -preparePackage' = do - exists <- liftIO (doesFileExist "bower.json") - unless exists (userError BowerJSONNotFound) - - pkgMeta <- liftIO (Bower.decodeFile "bower.json") - >>= flip catchLeft (userError . CouldntParseBowerJSON) - (pkgVersionTag, pkgVersion) <- getVersionFromGitTag - pkgGithub <- getBowerInfo pkgMeta - (pkgBookmarks, pkgModules) <- getModulesAndBookmarks - - let declaredDeps = map fst (bowerDependencies pkgMeta ++ - bowerDevDependencies pkgMeta) - pkgResolvedDependencies <- getResolvedDependencies declaredDeps - - let pkgUploader = D.NotYetKnown - let pkgCompilerVersion = P.version - - return D.Package{..} - -getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module]) -getModulesAndBookmarks = do - (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles - liftIO (D.parseAndDesugar inputFiles depsFiles renderModules) - >>= either (userError . ParseAndDesugarError) return - where - renderModules bookmarks modules = - return (bookmarks, map D.convertModule modules) - -getVersionFromGitTag :: PrepareM (String, Version) -getVersionFromGitTag = do - out <- readProcess' "git" ["tag", "--list", "--points-at", "HEAD"] "" - let vs = map trimWhitespace (lines out) - case mapMaybe parseMay vs of - [] -> userError TagMustBeCheckedOut - [x] -> return x - xs -> userError (AmbiguousVersions (map snd xs)) - where - trimWhitespace = - dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse - parseMay str = - (str,) <$> D.parseVersion' (dropPrefix "v" str) - dropPrefix prefix str = - fromMaybe str (stripPrefix prefix str) - -getBowerInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo) -getBowerInfo = either (userError . BadRepositoryField) return . tryExtract - where - tryExtract pkgMeta = - case bowerRepository pkgMeta of - Nothing -> Left RepositoryFieldMissing - Just Repository{..} -> do - unless (repositoryType == "git") - (Left (BadRepositoryType repositoryType)) - maybe (Left NotOnGithub) Right (extractGithub repositoryUrl) - -extractGithub :: String -> Maybe (D.GithubUser, D.GithubRepo) -extractGithub = - stripPrefix "git://github.com/" - >>> fmap (splitOn "/") - >=> takeTwo - >>> fmap (D.GithubUser *** (D.GithubRepo . dropDotGit)) - - where - takeTwo :: [a] -> Maybe (a, a) - takeTwo [x, y] = Just (x, y) - takeTwo _ = Nothing - - dropDotGit :: String -> String - dropDotGit str - | ".git" `isSuffixOf` str = take (length str - 4) str - | otherwise = str - -readProcess' :: String -> [String] -> String -> PrepareM String -readProcess' prog args stdin = do - out <- liftIO (catch (Right <$> readProcess prog args stdin) - (return . Left)) - either (otherError . ProcessFailed prog args) return out - -data DependencyStatus - = Missing - -- ^ Listed in bower.json, but not installed. - | NoResolution - -- ^ In the output of `bower list --json --offline`, there was no - -- _resolution key. This can be caused by adding the dependency using - -- `bower link`, or simply copying it into bower_components instead of - -- installing it normally. - | ResolvedOther String - -- ^ Resolved, but to something other than a version. The String argument - -- is the resolution type. The values it can take that I'm aware of are - -- "commit" and "branch". - | ResolvedVersion String - -- ^ Resolved to a version. The String argument is the resolution tag (eg, - -- "v0.1.0"). - deriving (Show, Eq) - --- Go through all bower dependencies which contain purescript code, and --- extract their versions. --- --- In the case where a bower dependency is taken from a particular version, --- that's easy; take that version. In any other case (eg, a branch, or a commit --- sha) we print a warning that documentation links will not work, and avoid --- linking to documentation for any types from that package. --- --- The rationale for this is: people will prefer to use a released version --- where possible. If they are not using a released version, then this is --- probably for a reason. However, docs are only ever available for released --- versions. Therefore there will probably be no version of the docs which is --- appropriate to link to, and we should omit links. -getResolvedDependencies :: [PackageName] -> PrepareM [(PackageName, Version)] -getResolvedDependencies declaredDeps = do - depsBS <- fromString <$> readProcess' "bower" ["list", "--json", "--offline"] "" - - -- Check for undeclared dependencies - toplevels <- catchJSON (parse asToplevelDependencies depsBS) - warnUndeclared declaredDeps toplevels - - deps <- catchJSON (parse asResolvedDependencies depsBS) - handleDeps deps - - where - catchJSON = flip catchLeft (internalError . JSONError FromBowerList) - --- | Extracts all dependencies and their versions from --- `bower list --json --offline` -asResolvedDependencies :: Parse BowerError [(PackageName, DependencyStatus)] -asResolvedDependencies = nubBy ((==) `on` fst) <$> go - where - go = - fmap (fromMaybe []) $ - keyMay "dependencies" $ - (++) <$> eachInObjectWithKey (parsePackageName . T.unpack) - asDependencyStatus - <*> (concatMap snd <$> eachInObject asResolvedDependencies) - --- | Extracts only the top level dependency names from the output of --- `bower list --json --offline` -asToplevelDependencies :: Parse BowerError [PackageName] -asToplevelDependencies = - fmap (map fst) $ - key "dependencies" $ - eachInObjectWithKey (parsePackageName . T.unpack) (return ()) - -asDependencyStatus :: Parse e DependencyStatus -asDependencyStatus = do - isMissing <- keyOrDefault "missing" False asBool - if isMissing - then - return Missing - else - key "pkgMeta" $ - keyOrDefault "_resolution" NoResolution $ do - type_ <- key "type" asString - case type_ of - "version" -> ResolvedVersion <$> key "tag" asString - other -> return (ResolvedOther other) - -warnUndeclared :: [PackageName] -> [PackageName] -> PrepareM () -warnUndeclared declared actual = - mapM_ (warn . UndeclaredDependency) (actual \\ declared) - -handleDeps :: - [(PackageName, DependencyStatus)] -> PrepareM [(PackageName, Version)] -handleDeps deps = do - let (missing, noVersion, installed) = partitionDeps deps - case missing of - (x:xs) -> - userError (MissingDependencies (x :| xs)) - [] -> do - mapM_ (warn . NoResolvedVersion) noVersion - withVersions <- catMaybes <$> mapM tryExtractVersion' installed - filterM (liftIO . isPureScript . bowerDir . fst) withVersions - - where - partitionDeps = foldr go ([], [], []) - go (pkgName, d) (ms, os, is) = - case d of - Missing -> (pkgName : ms, os, is) - NoResolution -> (ms, pkgName : os, is) - ResolvedOther _ -> (ms, pkgName : os, is) - ResolvedVersion v -> (ms, os, (pkgName, v) : is) - - bowerDir pkgName = "bower_components/" ++ runPackageName pkgName - - -- Try to extract a version, and warn if unsuccessful. - tryExtractVersion' pair = - maybe (warn (UnacceptableVersion pair) >> return Nothing) - (return . Just) - (tryExtractVersion pair) - -tryExtractVersion :: (PackageName, String) -> Maybe (PackageName, Version) -tryExtractVersion (pkgName, tag) = - let tag' = fromMaybe tag (stripPrefix "v" tag) - in (pkgName,) <$> D.parseVersion' tag' - --- | Returns whether it looks like there is a purescript package checked out --- in the given directory. -isPureScript :: FilePath -> IO Bool -isPureScript dir = do - files <- Glob.globDir1 purescriptSourceFiles dir - return (not (null files)) - -getInputAndDepsFiles :: IO ([FilePath], [(PackageName, FilePath)]) -getInputAndDepsFiles = do - inputFiles <- globRelative purescriptSourceFiles - depsFiles' <- globRelative purescriptDepsFiles - return (inputFiles, mapMaybe withPackageName depsFiles') - -withPackageName :: FilePath -> Maybe (PackageName, FilePath) -withPackageName fp = (,fp) <$> getPackageName fp - -getPackageName :: FilePath -> Maybe PackageName -getPackageName fp = do - let xs = splitOn "/" fp - ys <- stripPrefix ["bower_components"] xs - y <- headMay ys - case Bower.mkPackageName y of - Right name -> Just name - Left _ -> Nothing +main = execParser opts >>= publish + where + opts = info (version <*> helper <*> dryRun) infoModList + infoModList = fullDesc <> headerInfo <> footerInfo + headerInfo = header "psc-publish - Generates documentation packages for upload to http://pursuit.purescript.org" + footerInfo = footer $ "psc-publish " ++ showVersion Paths.version + + version :: Parser (a -> a) + version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden + +publish :: Bool -> IO () +publish isDryRun = + if isDryRun + then do + let dummyVersion = ("0.0.0", Version [0,0,0] []) + _ <- preparePackage $ defaultPublishOptions { publishGetVersion = return dummyVersion } + putStrLn "Dry run completed, no errors." + else do + pkg <- preparePackage defaultPublishOptions + BL.putStrLn (A.encode pkg) diff --git a/psc-publish/Utils.hs b/psc-publish/Utils.hs deleted file mode 100644 index c61b6c7..0000000 --- a/psc-publish/Utils.hs +++ /dev/null @@ -1,22 +0,0 @@ - -module Utils where - -import Data.List -import Data.Maybe -import System.Directory -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 - return (mapMaybe (stripPrefix (currentDir ++ "/")) filesAbsolute) - --- | 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/psc/Main.hs b/psc/Main.hs index 0faced9..f42f523 100644 --- a/psc/Main.hs +++ b/psc/Main.hs @@ -68,14 +68,14 @@ compile (PSCMakeOptions inputGlob inputForeignGlob outputDir opts usePrefix) = d hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings) let filePathMap = M.fromList $ map (\(fp, P.Module _ mn _ _) -> (mn, fp)) ms makeActions = buildMakeActions outputDir filePathMap foreigns usePrefix - e <- runMake opts $ P.make makeActions ms + e <- runMake opts $ P.make makeActions (map snd ms) case e of Left errs -> do hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs) exitFailure Right (_, warnings') -> do when (P.nonEmpty warnings') $ - putStrLn (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings') + hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings') exitSuccess readInput :: InputOptions -> IO [(Either P.RebuildPolicy FilePath, String)] diff --git a/psci/Completion.hs b/psci/Completion.hs index 4bd0e27..2936f47 100644 --- a/psci/Completion.hs +++ b/psci/Completion.hs @@ -6,6 +6,7 @@ import Data.Char (isUpper) import Data.Function (on) import Data.Traversable (traverse) +import Control.Arrow (second) import Control.Applicative ((<$>), (<*>)) import Control.Monad.Trans.Reader (asks, runReaderT, ReaderT) import Control.Monad.Trans.State.Strict @@ -196,13 +197,15 @@ typeDecls = mapMaybe getTypeName . filter P.isDataDecl . P.exportedDeclarations getTypeName _ = Nothing identNames :: P.Module -> [(N.Ident, P.Declaration)] -identNames = nubOnFst . mapMaybe getDeclName . P.exportedDeclarations +identNames = nubOnFst . concatMap getDeclNames . P.exportedDeclarations where - getDeclName :: P.Declaration -> Maybe (P.Ident, P.Declaration) - getDeclName d@(P.ValueDeclaration ident _ _ _) = Just (ident, d) - getDeclName d@(P.ExternDeclaration ident _) = Just (ident, d) - getDeclName (P.PositionedDeclaration _ _ d) = getDeclName d - getDeclName _ = Nothing + 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, P.Declaration)] dctorNames = nubOnFst . concatMap go . P.exportedDeclarations diff --git a/psci/PSCi.hs b/psci/PSCi.hs index 258a580..e839ac3 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -21,7 +21,7 @@ module PSCi where import Data.Foldable (traverse_) -import Data.List (intercalate, nub, sort, isPrefixOf) +import Data.List (intercalate, nub, sort) import Data.Traversable (traverse) import Data.Tuple (swap) import Data.Version (showVersion) @@ -91,12 +91,15 @@ supportModule = -- 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 = runMaybeT . msum $ map (MaybeT . findExecutable) names +findNodeProcess = onFirstFileMatching findExecutable names where names = ["nodejs", "node"] -- | @@ -219,12 +222,12 @@ createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindi -- 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} typ = +createTemporaryModuleForKind PSCiState{psciImportedModules = imports, psciLetBindings = lets} typ = let moduleName = P.ModuleName [P.ProperName "$PSCI"] itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ in - P.Module [] moduleName ((importDecl `map` imports) ++ [itDecl]) Nothing + P.Module [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing -- | -- Makes a volatile module to execute the current imports. @@ -256,11 +259,11 @@ makeIO f io = do either (throwError . P.singleError . f) return e make :: PSCiState -> [(Either P.RebuildPolicy FilePath, P.Module)] -> P.Make P.Environment -make PSCiState{..} ms = P.make actions' (psciLoadedModules ++ ms) +make PSCiState{..} ms = P.make actions' (map snd (psciLoadedModules ++ ms)) where filePathMap = M.fromList $ (first P.getModuleName . swap) `map` (psciLoadedModules ++ ms) actions = P.buildMakeActions modulesDir filePathMap psciForeignFiles False - actions' = actions { P.progress = \s -> unless ("Compiling $PSCI" `isPrefixOf` s) $ liftIO . putStrLn $ s } + actions' = actions { P.progress = const (return ()) } -- | -- Takes a value declaration and evaluates it with the current state. @@ -486,18 +489,27 @@ whenFileExists filePath f = do then f absPath else PSCI . outputStrLn $ "Couldn't locate: " ++ filePath +-- | +-- Attempts to read initial commands from '.psci' in the present working +-- directory then the user's home +-- loadUserConfig :: IO (Maybe [Command]) -loadUserConfig = do - configFile <- (</> ".psci") <$> getCurrentDirectory - exists <- doesFileExist configFile - if exists - then do - ls <- lines <$> readFile configFile - case mapM parseCommand ls of - Left err -> print err >> exitFailure - Right cs -> return $ Just cs - else - return Nothing +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 <$> readFile configFile + case mapM 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 diff --git a/psci/tests/Main.hs b/psci/tests/Main.hs index 17fd3c7..2fdbba0 100644 --- a/psci/tests/Main.hs +++ b/psci/tests/Main.hs @@ -8,12 +8,13 @@ import Control.Applicative import Control.Monad.Writer (runWriterT) import Control.Monad.Trans.Except (runExceptT) -import Data.List (isSuffixOf, sort) +import Data.List (sort) import System.Exit (exitFailure) import System.Console.Haskeline import System.FilePath ((</>)) -import System.Directory (getCurrentDirectory, getDirectoryContents) +import System.Directory (getCurrentDirectory) +import qualified System.FilePath.Glob as Glob import Test.HUnit @@ -48,9 +49,14 @@ completionTestData = , (":mo", [":module"]) , (":b", [":browse"]) - -- :browse should complete modules - , (":b Prel", [":b Prelude", ":b Prelude.Unsafe"]) - , (":b Prelude.", [":b Prelude.Unsafe"]) + -- :browse should complete module names + , (":b Control.Monad.E", map (":b Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console"]) + , (":b Control.Monad.Eff.", map (":b Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"]) + + -- 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 psci/tests/data/", [":l psci/tests/data/Sample.purs"]) @@ -66,8 +72,8 @@ completionTestData = , (":show a", []) -- :type should complete values and data constructors in scope - , (":type Prelude.Unsafe.un", [":type Prelude.Unsafe.unsafeIndex"]) - , (":type un", [":type unit"]) + , (":type Control.Monad.Eff.Console.lo", [":type Control.Monad.Eff.Console.log"]) + , (":type uni", [":type unit"]) , (":type E", [":type EQ"]) -- :kind should complete types in scope @@ -79,25 +85,19 @@ completionTestData = , (":type EQ ", []) , (":kind Ordering ", []) - -- import should complete module names - , ("import Control.Monad.S", ["import Control.Monad.ST"]) - , ("import qualified Control.Monad.S", ["import qualified Control.Monad.ST"]) - , ("import Control.Monad.", map ("import Control.Monad." ++) - ["Eff", "ST"]) - -- a few other import tests , ("impor", ["import"]) , ("import q", ["import qualified"]) - , ("import ", map ("import " ++) allModuleNames ++ ["import qualified"]) - , ("import Prelude.Unsafe ", []) + , ("import ", map ("import " ++) supportModules ++ ["import qualified"]) + , ("import Prelude ", []) -- String and number literals should not be completed , ("\"hi", []) , ("34", []) -- Identifiers and data constructors should be completed - , ("un", ["unit"]) - , ("Debug.Trace.", map ("Debug.Trace." ++) ["print", "trace"]) + , ("uni", ["unit"]) + , ("Control.Monad.Eff.Class.", ["Control.Monad.Eff.Class.liftEff"]) , ("G", ["GT"]) , ("Prelude.L", ["Prelude.LT"]) @@ -107,14 +107,6 @@ completionTestData = , ("Control.Monad.ST.new", ["Control.Monad.ST.newSTRef"]) ] where - allModuleNames = [ "Assert" - , "Control.Monad.Eff" - , "Control.Monad.ST" - , "Data.Function" - , "Debug.Trace" - , "Prelude" - , "Prelude.Unsafe" - ] assertCompletedOk :: (String, [String]) -> Assertion assertCompletedOk (line, expecteds) = do @@ -131,10 +123,12 @@ runCM act = do getPSCiState :: IO PSCiState getPSCiState = do cwd <- getCurrentDirectory - let preludeDir = cwd </> "tests" </> "prelude" - jsDir = preludeDir </> "js" - modulesOrFirstError <- loadAllModules [ preludeDir </> "Prelude.purs" ] - jsFiles <- map (jsDir </>) . filter (".js" `isSuffixOf`) <$> getDirectoryContents jsDir + let supportDir = cwd </> "tests" </> "support" </> "flattened" + let supportFiles ext = Glob.globDir1 (Glob.compile ("*." ++ ext)) supportDir + pursFiles <- supportFiles "purs" + jsFiles <- supportFiles "js" + + modulesOrFirstError <- loadAllModules pursFiles foreignFiles <- forM jsFiles (\f -> (f,) <$> readFile f) Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles case modulesOrFirstError of @@ -148,3 +142,15 @@ 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/purescript.cabal b/purescript.cabal index da90e20..71befa2 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.7.1.0 +version: 0.7.2.0 cabal-version: >=1.8 build-type: Simple license: MIT @@ -20,6 +20,8 @@ tested-with: GHC==7.8 extra-source-files: examples/passing/*.purs , examples/failing/*.purs + , tests/support/flattened/*.purs + , tests/support/flattened/*.js source-repository head type: git @@ -48,7 +50,11 @@ library text -any, split -any, language-javascript == 0.5.*, - syb -any + syb -any, + Glob >= 0.7 && < 0.8, + process >= 1.2.0 && < 1.3, + safe >= 0.3.9 && < 0.4, + semigroups >= 0.16.2 && < 0.17 exposed-modules: Language.PureScript Language.PureScript.AST @@ -140,6 +146,11 @@ library Language.PureScript.Docs.ParseAndDesugar Language.PureScript.Docs.Utils.MonoidExtras + Language.PureScript.Publish + Language.PureScript.Publish.Utils + Language.PureScript.Publish.ErrorsWarnings + Language.PureScript.Publish.BoxesHelpers + Control.Monad.Unify Control.Monad.Supply Control.Monad.Supply.Class @@ -179,7 +190,7 @@ executable psci executable psc-docs build-depends: base >=4 && <5, purescript -any, optparse-applicative >= 0.10.0, process -any, mtl -any, - split -any, ansi-wl-pprint -any, directory -any, + split -any, ansi-wl-pprint -any, directory -any, filepath -any, Glob -any main-is: Main.hs buildable: True @@ -190,24 +201,15 @@ executable psc-docs ghc-options: -Wall -O2 executable psc-publish - build-depends: base >=4 && <5, purescript -any, - optparse-applicative >= 0.10.0, process -any, mtl -any, - pattern-arrows -any, aeson -any, bytestring -any, - directory -any, transformers -any, text -any, containers - -any, boxes -any, split -any, Glob -any, aeson-better-errors - -any, transformers-compat -any, bower-json -any, semigroups - -any, safe -any + build-depends: base >=4 && <5, purescript -any, bytestring -any, aeson -any, optparse-applicative -any main-is: Main.hs buildable: True hs-source-dirs: psc-publish - other-modules: Utils - ErrorsWarnings - BoxesHelpers ghc-options: -Wall -O2 executable psc-hierarchy build-depends: base >=4 && <5, purescript -any, optparse-applicative >= 0.10.0, - process -any, mtl -any, parsec -any, filepath -any, directory -any, + process -any, mtl -any, parsec -any, filepath -any, directory -any, Glob -any main-is: Main.hs buildable: True @@ -225,7 +227,7 @@ executable psc-bundle directory -any, mtl -any, transformers -any, - transformers-compat -any, + transformers-compat -any, optparse-applicative >= 0.10.0, Glob -any ghc-options: -Wall -O2 @@ -234,7 +236,8 @@ executable psc-bundle 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 + transformers -any, process -any, transformers-compat -any, time -any, + Glob -any type: exitcode-stdio-1.0 main-is: Main.hs buildable: True @@ -244,7 +247,7 @@ test-suite psci-tests build-depends: base >=4 && <5, containers -any, directory -any, filepath -any, mtl -any, optparse-applicative >= 0.10.0, parsec -any, haskeline >= 0.7.0.0, purescript -any, transformers -any, - transformers-compat -any, process -any, HUnit -any, time -any, + transformers-compat -any, process -any, HUnit -any, time -any, Glob -any type: exitcode-stdio-1.0 main-is: Main.hs diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs index bc6689a..3d5eb49 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -57,11 +57,15 @@ data SourceSpan = SourceSpan , spanEnd :: SourcePos } deriving (Eq, Ord, Show, D.Data, D.Typeable) +displayStartEndPos :: SourceSpan -> String +displayStartEndPos sp = + displaySourcePos (spanStart sp) ++ " - " ++ + displaySourcePos (spanEnd sp) + displaySourceSpan :: SourceSpan -> String displaySourceSpan sp = spanName sp ++ " " ++ - displaySourcePos (spanStart sp) ++ " - " ++ - displaySourcePos (spanEnd sp) + displayStartEndPos sp instance A.ToJSON SourceSpan where toJSON SourceSpan{..} = diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 87606f7..1046c57 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -10,6 +10,9 @@ -- -- | 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 #-} @@ -18,11 +21,6 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE RecordWildCards #-} --- | Bundle javascript for use in 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. module Language.PureScript.Bundle ( bundle , ModuleIdentifier(..) @@ -52,17 +50,17 @@ import qualified Paths_purescript as Paths data ErrorMessage = UnsupportedModulePath String | InvalidTopLevel - | UnableToParseModule + | UnableToParseModule String | UnsupportedExport - | ErrorInFile FilePath ErrorMessage + | ErrorInModule ModuleIdentifier ErrorMessage deriving Show --- | Modules are either "regular modules" (i.e. those generated by psc-make) or foreign modules. -data ModuleType - = Regular - | Foreign +-- | Modules are either "regular modules" (i.e. those generated by psc) or foreign modules. +data ModuleType + = Regular + | Foreign deriving (Show, Eq, Ord) - + -- | A module is identified by its module name and its type. data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Eq, Ord) @@ -75,11 +73,11 @@ type Key = (ModuleIdentifier, String) -- | An export is either a "regular export", which exports a name from the regular module we are in, -- or a reexport of a declaration in the corresponding foreign module. --- --- Regular exports are labelled, since they might re-export an operator with another name. -data ExportType - = RegularExport String - | ForeignReexport +-- +-- Regular exports are labelled, since they might re-export an operator with another name. +data ExportType + = RegularExport String + | ForeignReexport deriving (Show, Eq, Ord) -- | There are four types of module element we are interested in: @@ -91,37 +89,42 @@ data ExportType -- -- Each is labelled with the original AST node which generated it, so that we can dump it back -- into the output during codegen. -data ModuleElement +data ModuleElement = Require JSNode String ModuleIdentifier | Member JSNode Bool String [JSNode] [Key] | ExportsList [(ExportType, String, JSNode, [Key])] | Other JSNode deriving Show --- | A module is just a list of elements of the types listed above. +-- | A module is just a list of elements of the types listed above. data Module = Module ModuleIdentifier [ModuleElement] deriving Show - + -- | Prepare an error message for consumption by humans. printErrorMessage :: ErrorMessage -> [String] printErrorMessage (UnsupportedModulePath s) = [ "A CommonJS module has an unsupported name (" ++ show s ++ ")." , "The following file names are supported:" - , " 1) index.js (psc-make native modules)" - , " 2) foreign.js (psc-make foreign modules)" + , " 1) index.js (psc native modules)" + , " 2) foreign.js (psc foreign modules)" ] printErrorMessage InvalidTopLevel = - [ "Expected a list of source elements at the top level." ] -printErrorMessage UnableToParseModule = - [ "The module could not be parsed." ] + [ "Expected a list of source elements at the top level." ] +printErrorMessage (UnableToParseModule err) = + [ "The module could not be parsed:" + , err + ] printErrorMessage UnsupportedExport = [ "An export was unsupported. Exports can be defined in one of two ways: " , " 1) exports.name = ..." , " 2) exports = { ... }" ] -printErrorMessage (ErrorInFile filename e) = - ("Error in file " ++ show filename ++ ":") +printErrorMessage (ErrorInModule mid e) = + ("Error in module " ++ displayIdentifier mid ++ ":") : "" : map (" " ++) (printErrorMessage e) + where + displayIdentifier (ModuleIdentifier name ty) = + name ++ " (" ++ show ty ++ ")" -- | Unpack the node inside a JSNode. This is useful when pattern matching. node :: JSNode -> Node @@ -130,18 +133,18 @@ node (NT n _ _) = n -- | Calculate the ModuleIdentifier which a require(...) statement imports. checkImportPath :: String -> ModuleIdentifier -> S.Set String -> Maybe ModuleIdentifier -checkImportPath "./foreign" m _ = +checkImportPath "./foreign" m _ = Just (ModuleIdentifier (moduleName m) Foreign) -checkImportPath name _ names +checkImportPath name _ names | name `S.member` names = Just (ModuleIdentifier name Regular) checkImportPath _ _ _ = Nothing -- | Compute the dependencies of all elements in a module, and add them to the tree. --- +-- -- Members and exports can have dependencies. A dependency is of one of the following forms: -- -- 1) module.name or member["name"] --- +-- -- where module was imported using -- -- var module = require("Module.Name"); @@ -151,7 +154,7 @@ checkImportPath _ _ _ = Nothing -- where name is the name of a member defined in the current module. withDeps :: Module -> Module withDeps (Module modulePath es) = Module modulePath (map expandDeps es) - where + where -- | Collects all modules which are imported, so that we can identify dependencies of the first type. imports :: [(String, ModuleIdentifier)] imports = mapMaybe toImport es @@ -159,7 +162,7 @@ withDeps (Module modulePath es) = Module modulePath (map expandDeps es) toImport :: ModuleElement -> Maybe (String, ModuleIdentifier) toImport (Require _ nm mid) = Just (nm, mid) toImport _ = Nothing - + -- | Collects all member names in scope, so that we can identify dependencies of the second type. boundNames :: [String] boundNames = mapMaybe toBoundName es @@ -175,7 +178,7 @@ withDeps (Module modulePath es) = Module modulePath (map expandDeps es) where expand (ty, nm, n1, _) = (ty, nm, n1, nub (dependencies modulePath n1)) expandDeps other = other - + dependencies :: ModuleIdentifier -> JSNode -> [(ModuleIdentifier, String)] dependencies m = everything (++) (mkQ [] toReference) where @@ -197,29 +200,31 @@ withDeps (Module modulePath es) = Module modulePath (map expandDeps es) toReference _ = [] -- | Attempt to create a Module from a Javascript AST. --- --- Each type of module element is matched using pattern guards, and everything else is bundled into the +-- +-- Each type of module element is matched using pattern guards, and everything else is bundled into the -- Other constructor. toModule :: forall m. (Applicative m, MonadError ErrorMessage m) => S.Set String -> ModuleIdentifier -> JSNode -> m Module -toModule mids mid top +toModule mids mid top | JSSourceElementsTop ns <- node top = Module mid <$> mapM toModuleElement ns - | otherwise = throwError InvalidTopLevel - where + | otherwise = err InvalidTopLevel + where + err = throwError . ErrorInModule mid + toModuleElement :: JSNode -> m ModuleElement toModuleElement n | JSVariables var [ varIntro ] _ <- node n - , JSLiteral "var" <- node var + , JSLiteral "var" <- node var , JSVarDecl impN [ eq, req, impP ] <- node varIntro , JSIdentifier importName <- node impN , JSLiteral "=" <- node eq , JSIdentifier "require" <- node req - , JSArguments _ [ impS ] _ <- node impP + , JSArguments _ [ impS ] _ <- node impP , JSStringLiteral _ importPath <- node impS , Just importPath' <- checkImportPath importPath mid mids = pure (Require n importName importPath') toModuleElement n | JSVariables var [ varIntro ] _ <- node n - , JSLiteral "var" <- node var + , JSLiteral "var" <- node var , JSVarDecl declN (eq : decl) <- node varIntro , JSIdentifier name <- node declN , JSLiteral "=" <- node eq @@ -253,11 +258,11 @@ toModule mids mid top = ExportsList <$> mapM toExport (filter (not . isSeparator) (map node props)) where toExport :: Node -> m (ExportType, String, JSNode, [Key]) - toExport (JSPropertyNameandValue name _ [val] ) = - (,,val,[]) <$> exportType (node val) + toExport (JSPropertyNameandValue name _ [val] ) = + (,,val,[]) <$> exportType (node val) <*> extractLabel (node name) - toExport _ = throwError UnsupportedExport - + toExport _ = err UnsupportedExport + exportType :: Node -> m ExportType exportType (JSMemberDot [f] _ _) | JSIdentifier "$foreign" <- node f @@ -266,13 +271,13 @@ toModule mids mid top | JSIdentifier "$foreign" <- node f = pure ForeignReexport exportType (JSIdentifier s) = pure (RegularExport s) - exportType _ = throwError UnsupportedExport - + exportType _ = err UnsupportedExport + extractLabel :: Node -> m String extractLabel (JSStringLiteral _ nm) = pure nm extractLabel (JSIdentifier nm) = pure nm - extractLabel _ = throwError UnsupportedExport - + extractLabel _ = err UnsupportedExport + isSeparator :: Node -> Bool isSeparator (JSLiteral ",") = True isSeparator _ = False @@ -282,9 +287,9 @@ toModule mids mid top compile :: [Module] -> [ModuleIdentifier] -> [Module] compile modules [] = modules compile modules entryPoints = filteredModules - where + where (graph, _, vertexFor) = graphFromEdges verts - + -- | The vertex set verts :: [(ModuleElement, Key, [Key])] verts = do @@ -292,12 +297,12 @@ compile modules entryPoints = filteredModules concatMap (toVertices mid) els where -- | Create a set of vertices for a module element. - -- + -- -- Some special cases worth commenting on: -- -- 1) Regular exports which simply export their own name do not count as dependencies. -- Regular exports which rename and reexport an operator do count, however. - -- + -- -- 2) Require statements don't contribute towards dependencies, since they effectively get -- inlined wherever they are used inside other module elements. toVertices :: ModuleIdentifier -> ModuleElement -> [(ModuleElement, Key, [Key])] @@ -308,18 +313,18 @@ compile modules entryPoints = filteredModules toVertex (RegularExport nm, nm1, _, ks) | nm /= nm1 = Just (m, (p, nm1), ks) toVertex _ = Nothing toVertices _ _ = [] - + -- | The set of vertices whose connected components we are interested in keeping. entryPointVertices :: [Vertex] entryPointVertices = catMaybes $ do (_, k@(mid, _), _) <- verts guard $ mid `elem` entryPoints return (vertexFor k) - + -- | The set of vertices reachable from an entry point reachableSet :: S.Set Vertex reachableSet = S.fromList (concatMap (reachable graph) entryPointVertices) - + filteredModules :: [Module] filteredModules = map filterUsed modules where @@ -328,29 +333,29 @@ compile modules entryPoints = filteredModules where go :: [ModuleElement] -> [ModuleElement] go [] = [] - go (d : Other semi : rest) + go (d : Other semi : rest) | JSLiteral ";" <- node semi , not (isDeclUsed d) = go rest - go (d : rest) + go (d : rest) | not (isDeclUsed d) = go rest | otherwise = d : go rest - + -- | Filter out the exports for members which aren't used. filterExports :: ModuleElement -> ModuleElement filterExports (ExportsList exps) = ExportsList (filter (\(_, nm, _, _) -> isKeyUsed (mid, nm)) exps) filterExports me = me - + isDeclUsed :: ModuleElement -> Bool isDeclUsed (Member _ _ nm _ _) = isKeyUsed (mid, nm) isDeclUsed _ = True - + isKeyUsed :: Key -> Bool - isKeyUsed k + isKeyUsed k | Just me <- vertexFor k = me `S.member` reachableSet | otherwise = False - --- | Topologically sort the module dependency graph, so that when we generate code, modules can be + +-- | Topologically sort the module dependency graph, so that when we generate code, modules can be -- defined in the right order. sortModules :: [Module] -> [Module] sortModules modules = map (\v -> case nodeFor v of (n, _, _) -> n) (reverse (topSort graph)) @@ -358,11 +363,11 @@ sortModules modules = map (\v -> case nodeFor v of (n, _, _) -> n) (reverse (top (graph, nodeFor, _) = graphFromEdges $ do m@(Module mid els) <- modules return (m, mid, mapMaybe getKey els) - + getKey :: ModuleElement -> Maybe ModuleIdentifier - getKey (Require _ _ mi) = Just mi + getKey (Require _ _ mi) = Just mi getKey _ = Nothing - + -- | A module is empty if it contains no exported members (in other words, -- if the only things left after dead code elimination are module imports and -- "other" foreign code). @@ -376,7 +381,7 @@ isModuleEmpty (Module _ els) = all isElementEmpty els isElementEmpty (Require _ _ _) = True isElementEmpty (Other _) = True isElementEmpty _ = False - + -- | Generate code for a set of modules, including a call to main(). -- -- Modules get defined on the global PS object, as follows: @@ -386,10 +391,10 @@ isModuleEmpty (Module _ els) = all isElementEmpty els -- ... -- })(PS["Module.Name"] = PS["Module.Name"] || {}); -- --- In particular, a module and its foreign imports share the same namespace inside PS. +-- In particular, a module and its foreign imports share the same namespace inside PS. -- This saves us from having to generate unique names for a module and its foreign imports, -- and is safe since a module shares a namespace with its foreign imports in PureScript as well --- (so there is no way to have overlaps in code generated by psc-make). +-- (so there is no way to have overlaps in code generated by psc). codeGen :: Maybe String -- ^ main module -> String -- ^ namespace -> [Module] -- ^ input modules @@ -401,85 +406,85 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (NN (JSSourceElem where declToJS :: ModuleElement -> [JSNode] declToJS (Member n _ _ _ _) = [n] - declToJS (Other n) = [n] - declToJS (Require _ nm req) = - [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ]) - [ NN (JSVarDecl (sp (JSIdentifier nm)) + declToJS (Other n) = [n] + declToJS (Require _ nm req) = + [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ]) + [ NN (JSVarDecl (sp (JSIdentifier nm)) [ sp (JSLiteral "=") , moduleReference sp (moduleName req) ]) ] (nt (JSLiteral ";"))) ] declToJS (ExportsList exps) = map toExport exps - - where + + where toExport :: (ExportType, String, JSNode, [Key]) -> JSNode toExport (_, nm, val, _) = - NN (JSExpression [ NN (JSMemberSquare [ NT (JSIdentifier "exports") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ] ] - (nt (JSLiteral "[")) + NN (JSExpression [ NN (JSMemberSquare [ NT (JSIdentifier "exports") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ] ] + (nt (JSLiteral "[")) (NN (JSExpression [ nt (JSStringLiteral '"' nm) ])) (nt (JSLiteral "]"))) , NN (JSOperator (sp (JSLiteral "="))) , reindent val , nt (JSLiteral ";") ]) - + reindent :: JSNode -> JSNode reindent (NT n _ _) = sp n reindent nn = nn - + indent :: [JSNode] -> [JSNode] indent = everywhere (mkT squash) where squash (NT n pos ann) = NT n (keepCol pos) (map splat ann) squash nn = nn - + splat (CommentA pos s) = CommentA (keepCol pos) s splat (WhiteSpace pos w) = WhiteSpace (keepCol pos) w splat ann = ann - + keepCol (TokenPn _ _ c) = TokenPn 0 0 (c + 2) - + prelude :: [JSNode] - prelude = + prelude = [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ CommentA tokenPosnEmpty ("// Generated by psc-bundle " ++ showVersion Paths.version) , WhiteSpace tokenPosnEmpty "\n" - ]) - [ NN (JSVarDecl (sp (JSIdentifier optionsNamespace)) + ]) + [ NN (JSVarDecl (sp (JSIdentifier optionsNamespace)) [ sp (JSLiteral "=") - , NN (JSObjectLiteral (sp (JSLiteral "{")) + , NN (JSObjectLiteral (sp (JSLiteral "{")) [] (sp (JSLiteral "}"))) ]) - ] + ] (nt (JSLiteral ";"))) , lf ] - + moduleReference :: (Node -> JSNode) -> String -> JSNode - moduleReference f mn = - NN (JSMemberSquare [ f (JSIdentifier optionsNamespace) ] - (nt (JSLiteral "[")) + moduleReference f mn = + NN (JSMemberSquare [ f (JSIdentifier optionsNamespace) ] + (nt (JSLiteral "[")) (NN (JSExpression [ nt (JSStringLiteral '"' mn) ])) (nt (JSLiteral "]"))) - + wrap :: String -> [JSNode] -> [JSNode] - wrap mn ds = - [ NN (JSExpression [ NN (JSExpressionParen (nt (JSLiteral "(")) - (NN (JSExpression [ NN (JSFunctionExpression (nt (JSLiteral "function")) - [] - (nt (JSLiteral "(") ) [nt (JSIdentifier "exports")] (nt (JSLiteral ")")) - (NN (JSBlock [sp (JSLiteral "{")] + wrap mn ds = + [ NN (JSExpression [ NN (JSExpressionParen (nt (JSLiteral "(")) + (NN (JSExpression [ NN (JSFunctionExpression (nt (JSLiteral "function")) + [] + (nt (JSLiteral "(") ) [nt (JSIdentifier "exports")] (nt (JSLiteral ")")) + (NN (JSBlock [sp (JSLiteral "{")] (lf : ds) [nl (JSLiteral "}")])))])) (nt (JSLiteral ")"))) - , NN (JSArguments (nt (JSLiteral "(")) + , NN (JSArguments (nt (JSLiteral "(")) [ NN (JSExpression [ moduleReference nt mn , NN (JSOperator (sp (JSLiteral "="))) , NN (JSExpressionBinary "||" - [ moduleReference sp mn ] - (sp (JSLiteral "||")) - [ emptyObj ]) + [ moduleReference sp mn ] + (sp (JSLiteral "||")) + [ emptyObj ]) ]) ] (nt (JSLiteral ")"))) @@ -489,30 +494,30 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (NN (JSSourceElem ] where emptyObj = NN (JSObjectLiteral (sp (JSLiteral "{")) [] (nt (JSLiteral "}"))) - + runMain :: String -> [JSNode] - runMain mn = - [ NN (JSExpression [ NN (JSMemberDot [ NN (JSMemberSquare [ nl (JSIdentifier optionsNamespace) ] - (nt (JSLiteral "[")) - (NN (JSExpression [ nt (JSStringLiteral '"' mn) ])) + runMain mn = + [ NN (JSExpression [ NN (JSMemberDot [ NN (JSMemberSquare [ nl (JSIdentifier optionsNamespace) ] + (nt (JSLiteral "[")) + (NN (JSExpression [ nt (JSStringLiteral '"' mn) ])) (nt (JSLiteral "]"))) - ] - (nt (JSLiteral ".")) + ] + (nt (JSLiteral ".")) (nt (JSIdentifier "main"))) , NN (JSArguments (nt (JSLiteral "(")) [] (nt (JSLiteral ")"))) ]) , nt (JSLiteral ";") ] - + nt :: Node -> JSNode nt n = NT n tokenPosnEmpty [] - + lf :: JSNode lf = NT (JSLiteral "") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ] - + sp :: Node -> JSNode sp n = NT n tokenPosnEmpty [ WhiteSpace tokenPosnEmpty " " ] - + nl :: Node -> JSNode nl n = NT n tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ] @@ -520,21 +525,21 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (NN (JSSourceElem -- This function performs dead code elimination, filters empty modules -- and generates and prints the final Javascript bundle. bundle :: forall m. (Applicative m, MonadError ErrorMessage m) - => [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc-make@. + => [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@. -> [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). -> m String bundle inputStrs entryPoints mainModule namespace = do input <- forM inputStrs $ \(ident, js) -> do - ast <- either (const $ throwError UnableToParseModule) pure $ parse js (moduleName ident) + ast <- either (throwError . ErrorInModule ident . UnableToParseModule) pure $ parse js (moduleName ident) return (ident, ast) let mids = S.fromList (map (moduleName . fst) input) - + modules <- mapM (fmap withDeps . uncurry (toModule mids)) input - + let compiled = compile modules entryPoints sorted = sortModules (filter (not . isModuleEmpty) compiled) - + return (codeGen mainModule namespace sorted) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index f856957..ccb854f 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -274,7 +274,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign = do failedPatternError names = JSUnary JSNew $ JSApp (JSVar "Error") [JSBinary Add (JSStringLiteral errorMessage) (JSArrayLiteral $ zipWith valueError names vals)] errorMessage :: String - errorMessage = "Failed pattern match" ++ maybe "" ((" at " ++) . displaySourceSpan) maybeSpan ++ ": " + errorMessage = "Failed pattern match" ++ maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++ ": " valueError :: String -> JS -> JS valueError _ l@(JSNumericLiteral _) = l diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs index 2777956..e460ad2 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -156,11 +156,11 @@ inlineCommonOperators = applyAll $ , binary semigroupString (C.<>) Add , binary semigroupString (C.++) Add - , binary latticeBoolean (C.&&) And - , binary latticeBoolean (C.||) Or - , binaryFunction latticeBoolean C.inf And - , binaryFunction latticeBoolean C.sup Or - , unary complementedLatticeBoolean C.not Not + , binary booleanAlgebraBoolean (C.&&) And + , binary booleanAlgebraBoolean (C.||) Or + , binaryFunction booleanAlgebraBoolean C.conj And + , binaryFunction booleanAlgebraBoolean C.disj Or + , unary booleanAlgebraBoolean C.not Not , binary' C.dataIntBits (C..|.) BitwiseOr , binary' C.dataIntBits (C..&.) BitwiseAnd @@ -269,25 +269,25 @@ semiringNumber :: (String, String) semiringNumber = (C.prelude, C.semiringNumber) semiringInt :: (String, String) -semiringInt = (C.dataInt, C.semiringInt) +semiringInt = (C.prelude, C.semiringInt) ringNumber :: (String, String) ringNumber = (C.prelude, C.ringNumber) ringInt :: (String, String) -ringInt = (C.dataInt, C.ringInt) +ringInt = (C.prelude, C.ringInt) moduloSemiringNumber :: (String, String) moduloSemiringNumber = (C.prelude, C.moduloSemiringNumber) moduloSemiringInt :: (String, String) -moduloSemiringInt = (C.dataInt, C.moduloSemiringInt) +moduloSemiringInt = (C.prelude, C.moduloSemiringInt) eqNumber :: (String, String) eqNumber = (C.prelude, C.eqNumber) eqInt :: (String, String) -eqInt = (C.dataInt, C.eqInt) +eqInt = (C.prelude, C.eqInt) eqString :: (String, String) eqString = (C.prelude, C.eqNumber) @@ -299,7 +299,7 @@ ordNumber :: (String, String) ordNumber = (C.prelude, C.ordNumber) ordInt :: (String, String) -ordInt = (C.dataInt, C.ordInt) +ordInt = (C.prelude, C.ordInt) semigroupString :: (String, String) semigroupString = (C.prelude, C.semigroupString) @@ -307,11 +307,8 @@ semigroupString = (C.prelude, C.semigroupString) boundedBoolean :: (String, String) boundedBoolean = (C.prelude, C.boundedBoolean) -latticeBoolean :: (String, String) -latticeBoolean = (C.prelude, C.latticeBoolean) - -complementedLatticeBoolean :: (String, String) -complementedLatticeBoolean = (C.prelude, C.complementedLatticeBoolean) +booleanAlgebraBoolean :: (String, String) +booleanAlgebraBoolean = (C.prelude, C.booleanAlgebraBoolean) semigroupoidArr :: (String, String) semigroupoidArr = (C.prelude, C.semigroupoidArr) diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index d992336..10d627e 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -97,11 +97,11 @@ negate = "negate" not :: String not = "not" -sup :: String -sup = "sup" +conj :: String +conj = "conj" -inf :: String -inf = "inf" +disj :: String +disj = "disj" mod :: String mod = "mod" @@ -229,11 +229,8 @@ eqBoolean = "eqBoolean" boundedBoolean :: String boundedBoolean = "boundedBoolean" -latticeBoolean :: String -latticeBoolean = "latticeBoolean" - -complementedLatticeBoolean :: String -complementedLatticeBoolean = "complementedLatticeBoolean" +booleanAlgebraBoolean :: String +booleanAlgebraBoolean = "booleanAlgebraBoolean" semigroupString :: String semigroupString = "semigroupString" @@ -274,8 +271,5 @@ st = "Control_Monad_ST" dataFunction :: String dataFunction = "Data_Function" -dataInt :: String -dataInt = "Data_Int" - dataIntBits :: String dataIntBits = "Data_Int_Bits" diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 8f45247..1818e80 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -214,9 +214,17 @@ tyObject = primTy "Object" -- Check whether a type is an object -- isObject :: Type -> Bool -isObject = (==) tyObject . extract - where extract (TypeApp t _) = t - extract t = t +isObject = isTypeOrApplied tyObject + +-- | +-- Check whether a type is a function +-- +isFunction :: Type -> Bool +isFunction = isTypeOrApplied tyFunction + +isTypeOrApplied :: Type -> Type -> Bool +isTypeOrApplied t1 (TypeApp t2 _) = t1 == t2 +isTypeOrApplied t1 t2 = t1 == t2 -- | -- Smart constructor for function types diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 869384d..88f8b7e 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -35,7 +35,7 @@ import Control.Monad.Trans.State.Lazy import Control.Arrow(first) import Language.PureScript.AST -import Language.PureScript.Environment (isObject) +import Language.PureScript.Environment (isObject, isFunction) import Language.PureScript.Pretty import Language.PureScript.Types import Language.PureScript.Names @@ -120,7 +120,8 @@ data SimpleErrorMessage | TransitiveExportError DeclarationRef [DeclarationRef] | ShadowedName Ident | WildcardInferredType Type - | NotExhaustivePattern [[Binder]] + | NotExhaustivePattern [[Binder]] Bool + | OverlappingPattern [[Binder]] Bool | ClassOperator ProperName Ident deriving (Show) @@ -230,7 +231,8 @@ errorCode em = case unwrapErrorMessage em of (TransitiveExportError _ _) -> "TransitiveExportError" (ShadowedName _) -> "ShadowedName" (WildcardInferredType _) -> "WildcardInferredType" - (NotExhaustivePattern _) -> "NotExhaustivePattern" + (NotExhaustivePattern _ _) -> "NotExhaustivePattern" + (OverlappingPattern _ _) -> "OverlappingPattern" (ClassOperator _ _) -> "ClassOperator" -- | @@ -561,11 +563,16 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError ] goSimple (WildcardInferredType ty) = line $ "The wildcard type definition has the inferred type " ++ prettyPrintType ty - goSimple (NotExhaustivePattern bs) = - paras $ [ line "Pattern could not be determined to cover all cases." + goSimple (NotExhaustivePattern bs b) = + indent $ paras $ [ line "Pattern could not be determined to cover all cases." , line $ "The definition has the following uncovered cases:\n" - , indent $ Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) - ] + , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) + ] ++ if not b then [line "..."] else [] + goSimple (OverlappingPattern bs b) = + indent $ paras $ [ line "Redundant cases have been detected." + , line $ "The definition has the following redundant cases:\n" + , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) + ] ++ if not b then [line "..."] else [] go (NotYetDefined names err) = paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map show names) ++ ":" , indent $ go err @@ -670,7 +677,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError , indent . line $ "import " ++ show im ++ " hiding (" ++ nm ++ ")" ] suggestions' (TypesDoNotUnify t1 t2) - | any isObject [t1, t2] = [line "Note that function composition in PureScript is defined using (<<<)"] + | isObject t1 && isFunction t2 = [line "Note that function composition in PureScript is defined using (<<<)"] | otherwise = [] suggestions' _ = [] @@ -740,13 +747,13 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError -- Pretty print multiple errors -- prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String -prettyPrintMultipleErrors full = flip evalState M.empty . prettyPrintMultipleErrorsWith Error "Error:" "Multiple errors:" full +prettyPrintMultipleErrors full = flip evalState M.empty . prettyPrintMultipleErrorsWith Error "Error found:" "Multiple errors found:" full -- | -- Pretty print multiple warnings -- prettyPrintMultipleWarnings :: Bool -> MultipleErrors -> String -prettyPrintMultipleWarnings full = flip evalState M.empty . prettyPrintMultipleErrorsWith Warning "Warning:" "Multiple warnings:" full +prettyPrintMultipleWarnings full = flip evalState M.empty . prettyPrintMultipleErrorsWith Warning "Warning found:" "Multiple warnings found:" full prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> State UnknownMap String prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 6b72b71..7a66663 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -53,7 +53,12 @@ lint (Module _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_ li lintDeclaration :: Declaration -> m () lintDeclaration d = let (f, _, _, _, _) = everythingWithContextOnValues moduleNames mempty mappend stepD stepE stepB def def - in tell (f d) + + f' :: Declaration -> MultipleErrors + f' (PositionedDeclaration pos _ dec) = onErrorMessages (PositionedError pos) (f' dec) + f' dec = f dec + + in tell (f' d) where def s _ = (s, mempty) diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index f12c3cb..698dc2e 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -31,6 +31,7 @@ import Data.Function (on) import Control.Monad (unless) import Control.Applicative +import Control.Arrow (first, second) import Control.Monad.Writer.Class import Language.PureScript.AST.Binders @@ -107,31 +108,30 @@ genericMerge f bsl@((s, b):bs) bsr@((s', b'):bs') -- | -- Find the uncovered set between two binders: --- the first binder is the case we are trying to cover the second one is the matching binder +-- the first binder is the case we are trying to cover, the second one is the matching binder -- -missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> [Binder] -missingCasesSingle _ _ _ NullBinder = [] -missingCasesSingle _ _ _ (VarBinder _) = [] +missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Maybe Bool) +missingCasesSingle _ _ _ NullBinder = ([], Just True) +missingCasesSingle _ _ _ (VarBinder _) = ([], Just True) missingCasesSingle env mn (VarBinder _) b = missingCasesSingle env mn NullBinder b missingCasesSingle env mn br (NamedBinder _ bl) = missingCasesSingle env mn br bl missingCasesSingle env mn NullBinder cb@(ConstructorBinder con _) = - concatMap (\cp -> missingCasesSingle env mn cp cb) allPatterns + (concatMap (\cp -> fst $ missingCasesSingle env mn cp cb) allPatterns, Just True) where allPatterns = map (\(p, t) -> ConstructorBinder (qualifyName p mn con) (initialize $ length t)) $ getConstructors env mn con missingCasesSingle env mn cb@(ConstructorBinder con bs) (ConstructorBinder con' bs') - | con == con' = map (ConstructorBinder con) (missingCasesMultiple env mn bs bs') - | otherwise = [cb] -missingCasesSingle _ _ NullBinder (ArrayBinder bs) - | null bs = [] - | otherwise = [] + | con == con' = let (bs'', pr) = missingCasesMultiple env mn bs bs' in (map (ConstructorBinder con) bs'', pr) + | otherwise = ([cb], Just False) missingCasesSingle env mn NullBinder (ObjectBinder bs) = - map (ObjectBinder . zip (map fst bs)) allMisses + (map (ObjectBinder . zip (map fst bs)) allMisses, pr) where - allMisses = missingCasesMultiple env mn (initialize $ length bs) (map snd bs) + (allMisses, pr) = missingCasesMultiple env mn (initialize $ length bs) (map snd bs) missingCasesSingle env mn (ObjectBinder bs) (ObjectBinder bs') = - map (ObjectBinder . zip sortedNames) $ uncurry (missingCasesMultiple env mn) (unzip binders) + (map (ObjectBinder . zip sortedNames) allMisses, pr) where + (allMisses, pr) = uncurry (missingCasesMultiple env mn) (unzip binders) + sortNames = sortBy (compare `on` fst) (sbs, sbs') = (sortNames bs, sortNames bs') @@ -145,12 +145,12 @@ missingCasesSingle env mn (ObjectBinder bs) (ObjectBinder bs') = compBS e s b b' = (s, compB e b b') (sortedNames, binders) = unzip $ genericMerge (compBS NullBinder) sbs sbs' -missingCasesSingle _ _ NullBinder (BooleanBinder b) = [BooleanBinder $ not b] +missingCasesSingle _ _ NullBinder (BooleanBinder b) = ([BooleanBinder $ not b], Just True) missingCasesSingle _ _ (BooleanBinder bl) (BooleanBinder br) - | bl == br = [] - | otherwise = [BooleanBinder bl] + | bl == br = ([], Just True) + | otherwise = ([BooleanBinder bl], Just False) missingCasesSingle env mn b (PositionedBinder _ _ cb) = missingCasesSingle env mn b cb -missingCasesSingle _ _ b _ = [b] +missingCasesSingle _ _ b _ = ([b], Nothing) -- | -- Returns the uncovered set of binders @@ -178,15 +178,14 @@ missingCasesSingle _ _ b _ = [b] -- redundant or not, but uncovered at least. If we use `y` instead, we'll need to have a redundancy checker -- (which ought to be available soon), or increase the complexity of the algorithm. -- -missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> [[Binder]] +missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Maybe Bool) missingCasesMultiple env mn = go where - go [] _ = [] - go (x:xs) (y:ys) - | null miss = map (x :) (go xs ys) - | otherwise = map (: xs) miss ++ map (x :) (go xs ys) + go [] [] = ([], pure True) + go (x:xs) (y:ys) = (map (: xs) miss1 ++ map (x :) miss2, liftA2 (&&) pr1 pr2) where - miss = missingCasesSingle env mn x y + (miss1, pr1) = missingCasesSingle env mn x y + (miss2, pr2) = go xs ys go _ _ = error "Argument lengths did not match in missingCasesMultiple." -- | @@ -213,13 +212,15 @@ isExhaustiveGuard (Right _) = True -- | -- Returns the uncovered set of case alternatives -- -missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> [[Binder]] +missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Maybe Bool) missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAlternativeBinders ca) -missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> [[Binder]] +missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Maybe Bool) missingAlternative env mn ca uncovered - | isExhaustiveGuard (caseAlternativeResult ca) = missingCases env mn uncovered ca - | otherwise = [uncovered] + | isExhaustiveGuard (caseAlternativeResult ca) = mcases + | otherwise = ([uncovered], snd mcases) + where + mcases = missingCases env mn uncovered ca -- | -- Main exhaustivity checking function @@ -228,20 +229,29 @@ missingAlternative env mn ca uncovered -- Then, returns the uncovered set of case alternatives. -- checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Environment -> ModuleName -> [CaseAlternative] -> m () -checkExhaustive env mn cas = makeResult . nub $ foldl' step [initial] cas +checkExhaustive env mn cas = makeResult . first nub $ foldl' step ([initial], (pure True, [])) cas where - step :: [[Binder]] -> CaseAlternative -> [[Binder]] - step uncovered ca = concatMap (missingAlternative env mn ca) uncovered + step :: ([[Binder]], (Maybe Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Maybe Bool, [[Binder]])) + step (uncovered, (nec, redundant)) ca = + let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered) + cond = or <$> sequenceA pr + in (concat missed, (liftA2 (&&) cond nec, + if fromMaybe True cond then redundant else caseAlternativeBinders ca : redundant)) + where + sequenceA = foldr (liftA2 (:)) (pure []) initial :: [Binder] initial = initialize numArgs where numArgs = length . caseAlternativeBinders . head $ cas - makeResult :: [[Binder]] -> m () - makeResult bss = unless (null bss) tellWarning + makeResult :: ([[Binder]], (Maybe Bool, [[Binder]])) -> m () + makeResult (bss, (_, bss')) = + do unless (null bss) tellExhaustive + unless (null bss') tellRedundant where - tellWarning = tell . errorMessage $ NotExhaustivePattern bss + tellExhaustive = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss + tellRedundant = tell . errorMessage . uncurry OverlappingPattern . second null . splitAt 5 $ bss' -- | -- Exhaustivity checking over a list of declarations diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index ba35dd7..6ed68bc 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -136,10 +136,10 @@ data RebuildPolicy -- make :: forall m. (Functor m, Applicative m, Monad m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m - -> [(Either RebuildPolicy FilePath, Module)] + -> [Module] -> m Environment make MakeActions{..} ms = do - (sorted, graph) <- sortModules $ map (importPrim . snd) ms + (sorted, graph) <- sortModules $ map importPrim ms mapM_ lint sorted toRebuild <- foldM (\s (Module _ moduleName' _ _) -> do inputTimestamp <- getInputTimestamp moduleName' @@ -282,6 +282,8 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = foreignFile = outputDir </> filePath </> "foreign.js" prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix] js = unlines $ map ("// " ++) prefix ++ [pjs] + verboseErrorsEnabled <- asks optionsVerboseErrors + when verboseErrorsEnabled $ progress $ "Writing " ++ jsFile writeTextFile jsFile js maybe (return ()) (writeTextFile foreignFile . snd) $ mn `M.lookup` foreigns writeTextFile externsFile exts @@ -295,16 +297,11 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = traverse (const $ getModificationTime path) $ guard exists readTextFile :: FilePath -> Make String - readTextFile path = do - verboseErrorsEnabled <- asks optionsVerboseErrors - makeIO (const (SimpleErrorWrapper $ CannotReadFile path)) $ do - when verboseErrorsEnabled $ putStrLn $ "Reading " ++ path - readFile path + readTextFile path = makeIO (const (SimpleErrorWrapper $ CannotReadFile path)) $ readFile path writeTextFile :: FilePath -> String -> Make () writeTextFile path text = makeIO (const (SimpleErrorWrapper $ CannotWriteFile path)) $ do mkdirp path - putStrLn $ "Writing " ++ path writeFile path text where mkdirp :: FilePath -> IO () diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs new file mode 100644 index 0000000..99258eb --- /dev/null +++ b/src/Language/PureScript/Publish.hs @@ -0,0 +1,361 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Language.PureScript.Publish + ( preparePackage + , preparePackage' + , PrepareM() + , runPrepareM + , PublishOptions(..) + , defaultPublishOptions + , getGitWorkingTreeStatus + , requireCleanWorkingTree + , getVersionFromGitTag + , getBowerInfo + , getModulesAndBookmarks + , getResolvedDependencies + ) where + +import Prelude hiding (userError) + +import Data.Maybe +import Data.Char (isSpace) +import Data.String (fromString) +import Data.List (stripPrefix, isSuffixOf, (\\), nubBy) +import Data.List.Split (splitOn) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Version +import Data.Function (on) +import Safe (headMay) +import Data.Aeson.BetterErrors +import qualified Data.Text as T + +import Control.Applicative +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 + +import System.Directory (doesFileExist, findExecutable) +import System.Process (readProcess) +import System.Exit (exitFailure) +import System.FilePath (pathSeparator) +import qualified System.FilePath.Glob as Glob +import qualified System.Info + +import Web.Bower.PackageMeta (PackageMeta(..), BowerError(..), PackageName, + runPackageName, parsePackageName, Repository(..)) +import qualified Web.Bower.PackageMeta as Bower + +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 + -- generated will refer to. + publishGetVersion :: PrepareM (String, Version) + } + +defaultPublishOptions :: PublishOptions +defaultPublishOptions = PublishOptions + { publishGetVersion = getVersionFromGitTag + } + +-- | Attempt to retrieve package metadata from the current directory. +-- Calls exitFailure if no package metadata could be retrieved. +preparePackage :: PublishOptions -> IO D.UploadedPackage +preparePackage opts = + runPrepareM (preparePackage' opts) + >>= either (\e -> printError e >> exitFailure) + handleWarnings + where + handleWarnings (result, warns) = do + printWarnings warns + return result + +newtype PrepareM a = + PrepareM { unPrepareM :: WriterT [PackageWarning] (ExceptT PackageError IO) a } + deriving (Functor, Applicative, Monad, + MonadWriter [PackageWarning], + MonadError PackageError) + +-- This MonadIO instance ensures that IO errors don't crash the program. +instance MonadIO PrepareM where + liftIO act = + lift' (try act) >>= either (otherError . IOExceptionThrown) return + where + lift' :: IO a -> PrepareM a + lift' = PrepareM . lift . lift + +runPrepareM :: PrepareM a -> IO (Either PackageError (a, [PackageWarning])) +runPrepareM = runExceptT . runWriterT . unPrepareM + +warn :: PackageWarning -> PrepareM () +warn w = tell [w] + +userError :: UserError -> PrepareM a +userError = throwError . UserError + +internalError :: InternalError -> PrepareM a +internalError = throwError . InternalError + +otherError :: OtherError -> PrepareM a +otherError = throwError . OtherError + +catchLeft :: Applicative f => Either a b -> (a -> f b) -> f b +catchLeft a f = either f pure a + +preparePackage' :: PublishOptions -> PrepareM D.UploadedPackage +preparePackage' opts = do + exists <- liftIO (doesFileExist "bower.json") + unless exists (userError BowerJSONNotFound) + + requireCleanWorkingTree + + pkgMeta <- liftIO (Bower.decodeFile "bower.json") + >>= flip catchLeft (userError . CouldntParseBowerJSON) + (pkgVersionTag, pkgVersion) <- publishGetVersion opts + pkgGithub <- getBowerInfo pkgMeta + (pkgBookmarks, pkgModules) <- getModulesAndBookmarks + + let declaredDeps = map fst (bowerDependencies pkgMeta ++ + bowerDevDependencies pkgMeta) + pkgResolvedDependencies <- getResolvedDependencies declaredDeps + + let pkgUploader = D.NotYetKnown + let pkgCompilerVersion = P.version + + return D.Package{..} + +getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module]) +getModulesAndBookmarks = do + (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles + liftIO (D.parseAndDesugar inputFiles depsFiles renderModules) + >>= either (userError . ParseAndDesugarError) return + where + renderModules bookmarks modules = + return (bookmarks, map D.convertModule modules) + +data TreeStatus = Clean | Dirty deriving (Show, Eq, Ord, Enum) + +getGitWorkingTreeStatus :: PrepareM TreeStatus +getGitWorkingTreeStatus = do + out <- readProcess' "git" ["status", "--porcelain"] "" + return $ + if null . filter (not . null) . lines $ out + then Clean + else Dirty + +requireCleanWorkingTree :: PrepareM () +requireCleanWorkingTree = do + status <- getGitWorkingTreeStatus + unless (status == Clean) $ + userError DirtyWorkingTree + +getVersionFromGitTag :: PrepareM (String, Version) +getVersionFromGitTag = do + out <- readProcess' "git" ["tag", "--list", "--points-at", "HEAD"] "" + let vs = map trimWhitespace (lines out) + case mapMaybe parseMay vs of + [] -> userError TagMustBeCheckedOut + [x] -> return x + xs -> userError (AmbiguousVersions (map snd xs)) + where + trimWhitespace = + dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse + parseMay str = + (str,) <$> D.parseVersion' (dropPrefix "v" str) + dropPrefix prefix str = + fromMaybe str (stripPrefix prefix str) + +getBowerInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo) +getBowerInfo = either (userError . BadRepositoryField) return . tryExtract + where + tryExtract pkgMeta = + case bowerRepository pkgMeta of + Nothing -> Left RepositoryFieldMissing + Just Repository{..} -> do + unless (repositoryType == "git") + (Left (BadRepositoryType repositoryType)) + maybe (Left NotOnGithub) Right (extractGithub repositoryUrl) + +extractGithub :: String -> Maybe (D.GithubUser, D.GithubRepo) +extractGithub = + stripPrefix "git://github.com/" + >>> fmap (splitOn "/") + >=> takeTwo + >>> fmap (D.GithubUser *** (D.GithubRepo . dropDotGit)) + + where + takeTwo :: [a] -> Maybe (a, a) + takeTwo [x, y] = Just (x, y) + takeTwo _ = Nothing + + dropDotGit :: String -> String + dropDotGit str + | ".git" `isSuffixOf` str = take (length str - 4) str + | otherwise = str + +readProcess' :: String -> [String] -> String -> PrepareM String +readProcess' prog args stdin = do + out <- liftIO (catch (Right <$> readProcess prog args stdin) + (return . Left)) + either (otherError . ProcessFailed prog args) return out + +data DependencyStatus + = Missing + -- ^ Listed in bower.json, but not installed. + | NoResolution + -- ^ In the output of `bower list --json --offline`, there was no + -- _resolution key. This can be caused by adding the dependency using + -- `bower link`, or simply copying it into bower_components instead of + -- installing it normally. + | ResolvedOther String + -- ^ Resolved, but to something other than a version. The String argument + -- is the resolution type. The values it can take that I'm aware of are + -- "commit" and "branch". + | ResolvedVersion String + -- ^ Resolved to a version. The String argument is the resolution tag (eg, + -- "v0.1.0"). + deriving (Show, Eq) + +-- Go through all bower dependencies which contain purescript code, and +-- extract their versions. +-- +-- In the case where a bower dependency is taken from a particular version, +-- that's easy; take that version. In any other case (eg, a branch, or a commit +-- sha) we print a warning that documentation links will not work, and avoid +-- linking to documentation for any types from that package. +-- +-- The rationale for this is: people will prefer to use a released version +-- where possible. If they are not using a released version, then this is +-- probably for a reason. However, docs are only ever available for released +-- versions. Therefore there will probably be no version of the docs which is +-- appropriate to link to, and we should omit links. +getResolvedDependencies :: [PackageName] -> PrepareM [(PackageName, Version)] +getResolvedDependencies declaredDeps = do + bower <- findBowerExecutable + depsBS <- fromString <$> readProcess' bower ["list", "--json", "--offline"] "" + + -- Check for undeclared dependencies + toplevels <- catchJSON (parse asToplevelDependencies depsBS) + warnUndeclared declaredDeps toplevels + + deps <- catchJSON (parse asResolvedDependencies depsBS) + handleDeps deps + + where + catchJSON = flip catchLeft (internalError . JSONError FromBowerList) + +findBowerExecutable :: PrepareM String +findBowerExecutable = do + mname <- liftIO . runMaybeT . msum . map (MaybeT . findExecutable) $ names + maybe (userError (BowerExecutableNotFound names)) return mname + where + names = case System.Info.os of + "mingw32" -> ["bower", "bower.cmd"] + _ -> ["bower"] + +-- | Extracts all dependencies and their versions from +-- `bower list --json --offline` +asResolvedDependencies :: Parse BowerError [(PackageName, DependencyStatus)] +asResolvedDependencies = nubBy ((==) `on` fst) <$> go + where + go = + fmap (fromMaybe []) $ + keyMay "dependencies" $ + (++) <$> eachInObjectWithKey (parsePackageName . T.unpack) + asDependencyStatus + <*> (concatMap snd <$> eachInObject asResolvedDependencies) + +-- | Extracts only the top level dependency names from the output of +-- `bower list --json --offline` +asToplevelDependencies :: Parse BowerError [PackageName] +asToplevelDependencies = + fmap (map fst) $ + key "dependencies" $ + eachInObjectWithKey (parsePackageName . T.unpack) (return ()) + +asDependencyStatus :: Parse e DependencyStatus +asDependencyStatus = do + isMissing <- keyOrDefault "missing" False asBool + if isMissing + then + return Missing + else + key "pkgMeta" $ + keyOrDefault "_resolution" NoResolution $ do + type_ <- key "type" asString + case type_ of + "version" -> ResolvedVersion <$> key "tag" asString + other -> return (ResolvedOther other) + +warnUndeclared :: [PackageName] -> [PackageName] -> PrepareM () +warnUndeclared declared actual = + mapM_ (warn . UndeclaredDependency) (actual \\ declared) + +handleDeps :: + [(PackageName, DependencyStatus)] -> PrepareM [(PackageName, Version)] +handleDeps deps = do + let (missing, noVersion, installed) = partitionDeps deps + case missing of + (x:xs) -> + userError (MissingDependencies (x :| xs)) + [] -> do + mapM_ (warn . NoResolvedVersion) noVersion + withVersions <- catMaybes <$> mapM tryExtractVersion' installed + filterM (liftIO . isPureScript . bowerDir . fst) withVersions + + where + partitionDeps = foldr go ([], [], []) + go (pkgName, d) (ms, os, is) = + case d of + Missing -> (pkgName : ms, os, is) + NoResolution -> (ms, pkgName : os, is) + ResolvedOther _ -> (ms, pkgName : os, is) + ResolvedVersion v -> (ms, os, (pkgName, v) : is) + + bowerDir pkgName = "bower_components/" ++ runPackageName pkgName + + -- Try to extract a version, and warn if unsuccessful. + tryExtractVersion' pair = + maybe (warn (UnacceptableVersion pair) >> return Nothing) + (return . Just) + (tryExtractVersion pair) + +tryExtractVersion :: (PackageName, String) -> Maybe (PackageName, Version) +tryExtractVersion (pkgName, tag) = + let tag' = fromMaybe tag (stripPrefix "v" tag) + in (pkgName,) <$> D.parseVersion' tag' + +-- | Returns whether it looks like there is a purescript package checked out +-- in the given directory. +isPureScript :: FilePath -> IO Bool +isPureScript dir = do + files <- Glob.globDir1 purescriptSourceFiles dir + return (not (null files)) + +getInputAndDepsFiles :: IO ([FilePath], [(PackageName, FilePath)]) +getInputAndDepsFiles = do + inputFiles <- globRelative purescriptSourceFiles + depsFiles' <- globRelative purescriptDepsFiles + return (inputFiles, mapMaybe withPackageName depsFiles') + +withPackageName :: FilePath -> Maybe (PackageName, FilePath) +withPackageName fp = (,fp) <$> getPackageName fp + +getPackageName :: FilePath -> Maybe PackageName +getPackageName fp = do + let xs = splitOn [pathSeparator] fp + ys <- stripPrefix ["bower_components"] xs + y <- headMay ys + case Bower.mkPackageName y of + Right name -> Just name + Left _ -> Nothing diff --git a/psc-publish/BoxesHelpers.hs b/src/Language/PureScript/Publish/BoxesHelpers.hs index 7ab0c67..3e214a6 100644 --- a/psc-publish/BoxesHelpers.hs +++ b/src/Language/PureScript/Publish/BoxesHelpers.hs @@ -1,7 +1,7 @@ -module BoxesHelpers +module Language.PureScript.Publish.BoxesHelpers ( Boxes.Box , Boxes.nullBox - , module BoxesHelpers + , module Language.PureScript.Publish.BoxesHelpers ) where import System.IO (hPutStr, stderr) diff --git a/psc-publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index 18371b3..256638f 100644 --- a/psc-publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -1,7 +1,19 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -module ErrorsWarnings where +module Language.PureScript.Publish.ErrorsWarnings + ( PackageError(..) + , PackageWarning(..) + , UserError(..) + , InternalError(..) + , OtherError(..) + , RepositoryFieldError(..) + , JSONSource(..) + , printError + , renderError + , printWarnings + , renderWarnings + ) where import Control.Applicative ((<$>)) import Data.Aeson.BetterErrors @@ -9,7 +21,7 @@ import Data.Version import Data.Maybe import Data.Monoid import Data.Foldable (foldMap) -import Data.List (intersperse) +import Data.List (intersperse, intercalate) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty @@ -22,7 +34,7 @@ import qualified Web.Bower.PackageMeta as Bower import qualified Language.PureScript as P import qualified Language.PureScript.Docs as D -import BoxesHelpers +import Language.PureScript.Publish.BoxesHelpers -- | An error which meant that it was not possible to retrieve metadata for a -- package. @@ -41,6 +53,7 @@ data PackageWarning -- | An error that should be fixed by the user. data UserError = BowerJSONNotFound + | BowerExecutableNotFound [String] -- list of executable names tried | CouldntParseBowerJSON (ParseError BowerError) | BowerJSONNameMissing | TagMustBeCheckedOut @@ -48,6 +61,7 @@ data UserError | BadRepositoryField RepositoryFieldError | MissingDependencies (NonEmpty PackageName) | ParseAndDesugarError D.ParseDesugarError + | DirtyWorkingTree deriving (Show) data RepositoryFieldError @@ -108,6 +122,13 @@ displayUserError e = case e of [ "The bower.json file was not found. Please create one, or run " , "`pulp init`." ]) + BowerExecutableNotFound names -> + para (concat + [ "The Bower executable was not found (tried: ", format names, "). Please" + , " ensure that bower is installed and on your PATH." + ]) + where + format = intercalate ", " . map show CouldntParseBowerJSON err -> vcat [ successivelyIndented @@ -184,6 +205,11 @@ displayUserError e = case e of [ para "Error while desugaring:" , indented (para (P.prettyPrintMultipleErrors False err)) ] + DirtyWorkingTree -> + para (concat + [ "Your git working tree is dirty. Please commit, discard, or stash " + , "your changes first." + ]) displayRepositoryError :: RepositoryFieldError -> Box displayRepositoryError err = case err of diff --git a/src/Language/PureScript/Publish/Utils.hs b/src/Language/PureScript/Publish/Utils.hs new file mode 100644 index 0000000..ddaed99 --- /dev/null +++ b/src/Language/PureScript/Publish/Utils.hs @@ -0,0 +1,38 @@ + +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" diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 71e576e..a510dd4 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -31,6 +31,7 @@ import Data.Foldable (for_) import qualified Data.Map as M +import Control.Applicative ((<$>), (<*)) import Control.Monad.State import Control.Monad.Error.Class (MonadError(..)) @@ -129,25 +130,23 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms -- * Process module imports -- typeCheckAll :: Maybe ModuleName -> ModuleName -> [DeclarationRef] -> [Declaration] -> Check [Declaration] -typeCheckAll mainModuleName moduleName exps = go +typeCheckAll mainModuleName moduleName exps ds = mapM go ds <* mapM_ checkOrphanFixities ds where - go :: [Declaration] -> Check [Declaration] - go [] = return [] - go (DataDeclaration dtype name args dctors : rest) = do + go :: Declaration -> Check Declaration + go (DataDeclaration dtype name args dctors) = do rethrow (onErrorMessages (ErrorInTypeConstructor name)) $ do when (dtype == Newtype) $ checkNewtype dctors checkDuplicateTypeArguments $ map fst args ctorKind <- kindsOf True moduleName name args (concatMap snd dctors) let args' = args `withKinds` ctorKind addDataType moduleName dtype name args' dctors ctorKind - ds <- go rest - return $ DataDeclaration dtype name args dctors : ds + return $ DataDeclaration dtype name args dctors where checkNewtype :: [(ProperName, [Type])] -> Check () checkNewtype [(_, [_])] = return () checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype checkNewtype _ = throwError . errorMessage $ InvalidNewtype - go (d@(DataBindingGroupDeclaration tys) : rest) = do + go (d@(DataBindingGroupDeclaration tys)) = do rethrow (onErrorMessages ErrorInDataBindingGroup) $ do let syns = mapMaybe toTypeSynonym tys let dataDecls = mapMaybe toDataDecl tys @@ -160,8 +159,7 @@ typeCheckAll mainModuleName moduleName exps = go checkDuplicateTypeArguments $ map fst args let args' = args `withKinds` kind addTypeSynonym moduleName name args' ty kind - ds <- go rest - return $ d : ds + return d where toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty) toTypeSynonym (PositionedDeclaration _ _ d') = toTypeSynonym d' @@ -169,26 +167,23 @@ typeCheckAll mainModuleName moduleName exps = go toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors) toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d' toDataDecl _ = Nothing - go (TypeSynonymDeclaration name args ty : rest) = do + go (TypeSynonymDeclaration name args ty) = do rethrow (onErrorMessages (ErrorInTypeSynonym name)) $ do checkDuplicateTypeArguments $ map fst args kind <- kindsOf False moduleName name args [ty] let args' = args `withKinds` kind addTypeSynonym moduleName name args' ty kind - ds <- go rest - return $ TypeSynonymDeclaration name args ty : ds - go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed" - go (ValueDeclaration name nameKind [] (Right val) : rest) = do - d <- rethrow (onErrorMessages (ErrorInValueDeclaration name)) $ do + return $ TypeSynonymDeclaration name args ty + go (TypeDeclaration{}) = error "Type declarations should have been removed" + go (ValueDeclaration name nameKind [] (Right val)) = + rethrow (onErrorMessages (ErrorInValueDeclaration name)) $ do valueIsNotDefined moduleName name [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)] addValue moduleName name ty nameKind return $ ValueDeclaration name nameKind [] $ Right val' - ds <- go rest - return $ d : ds - go (ValueDeclaration{} : _) = error "Binders were not desugared" - go (BindingGroupDeclaration vals : rest) = do - d <- rethrow (onErrorMessages (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do + go (ValueDeclaration{}) = error "Binders were not desugared" + go (BindingGroupDeclaration vals) = + rethrow (onErrorMessages (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do forM_ (map (\(ident, _, _) -> ident) vals) $ \name -> valueIsNotDefined moduleName name tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals @@ -200,14 +195,11 @@ typeCheckAll mainModuleName moduleName exps = go addValue moduleName name ty nameKind return (name, nameKind, val) return $ BindingGroupDeclaration vals' - ds <- go rest - return $ d : ds - go (d@(ExternDataDeclaration name kind) : rest) = do + go (d@(ExternDataDeclaration name kind)) = do env <- getEnv putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) } - ds <- go rest - return $ d : ds - go (d@(ExternDeclaration name ty) : rest) = do + return d + go (d@(ExternDeclaration name ty)) = do rethrow (onErrorMessages (ErrorInForeignImport name)) $ do env <- getEnv kind <- kindOf moduleName ty @@ -215,38 +207,37 @@ typeCheckAll mainModuleName moduleName exps = go case M.lookup (moduleName, name) (names env) of Just _ -> throwError . errorMessage $ RedefinedIdent name Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) }) - ds <- go rest - return $ d : ds - go (d@(FixityDeclaration _ name) : rest) = do - ds <- go rest - env <- getEnv - guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env - return $ d : ds - go (d@(ImportDeclaration importedModule _ _) : rest) = do + return d + go (d@(FixityDeclaration{})) = return d + go (d@(ImportDeclaration importedModule _ _)) = do instances <- lookupTypeClassDictionaries $ Just importedModule addTypeClassDictionaries (Just moduleName) instances - ds <- go rest - return $ d : ds - go (d@(TypeClassDeclaration pn args implies tys) : rest) = do + return d + go (d@(TypeClassDeclaration pn args implies tys)) = do addTypeClass moduleName pn args implies tys - ds <- go rest - return $ d : ds - go (d@(TypeInstanceDeclaration dictName deps className tys _) : rest) = do - goInstance d dictName deps className tys rest - go (d@(ExternInstanceDeclaration dictName deps className tys) : rest) = do - goInstance d dictName deps className tys rest - go (PositionedDeclaration pos com d : rest) = - rethrowWithPosition pos $ do - (d' : rest') <- go (d : rest) - return (PositionedDeclaration pos com d' : rest') - goInstance :: Declaration -> Ident -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Check [Declaration] - goInstance d dictName deps className tys rest = do + return d + go (d@(TypeInstanceDeclaration dictName deps className tys _)) = + goInstance d dictName deps className tys + go (d@(ExternInstanceDeclaration dictName deps className tys)) = + goInstance d dictName deps className tys + go (PositionedDeclaration pos com d) = + rethrowWithPosition pos $ PositionedDeclaration pos com <$> go d + + checkOrphanFixities :: Declaration -> Check () + checkOrphanFixities (FixityDeclaration _ name) = do + env <- getEnv + guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env + checkOrphanFixities (PositionedDeclaration pos _ d) = + rethrowWithPosition pos $ checkOrphanFixities d + checkOrphanFixities _ = return () + + goInstance :: Declaration -> Ident -> [Constraint] -> Qualified ProperName -> [Type] -> Check Declaration + goInstance d dictName deps className tys = do mapM_ (checkTypeClassInstance moduleName) tys forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular isInstanceExported addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (canonicalizeDictionary dict) dict - ds <- go rest - return $ d : ds + return d where diff --git a/tests/Main.hs b/tests/Main.hs index 4bf2edd..398649c 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -13,18 +13,35 @@ ----------------------------------------------------------------------------- {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} +-- Failing tests can specify the kind of error that should be thrown with a +-- @shouldFailWith declaration. For example: +-- +-- "-- @shouldFailWith TypesDoNotUnify" +-- +-- will cause the test to fail unless that module fails to compile with exactly +-- one TypesDoNotUnify error. +-- +-- If a module is expected to produce multiple type errors, then use multiple +-- @shouldFailWith lines; for example: +-- +-- -- @shouldFailWith TypesDoNotUnify +-- -- @shouldFailWith TypesDoNotUnify +-- -- @shouldFailWith TransitiveExportError + module Main (main) where import qualified Language.PureScript as P import qualified Language.PureScript.CodeGen.JS as J import qualified Language.PureScript.CoreFn as CF -import Data.List (isSuffixOf) +import Data.Char (isSpace) +import Data.Maybe (mapMaybe, fromMaybe) +import Data.List (isSuffixOf, sort, stripPrefix) import Data.Traversable (traverse) import Data.Time.Clock (UTCTime()) @@ -33,6 +50,7 @@ import qualified Data.Map as M import Control.Monad import Control.Monad.IO.Class (liftIO) import Control.Applicative +import Control.Arrow ((>>>)) import Control.Monad.Reader import Control.Monad.Writer @@ -44,6 +62,7 @@ import System.Exit import System.Process import System.FilePath import System.Directory +import qualified System.FilePath.Glob as Glob import Text.Parsec (ParseError) @@ -60,31 +79,23 @@ makeActions :: M.Map P.ModuleName (FilePath, P.ForeignJS) -> P.MakeActions Test makeActions foreigns = P.MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress where getInputTimestamp :: P.ModuleName -> Test (Either P.RebuildPolicy (Maybe UTCTime)) - getInputTimestamp mn - | isPreludeModule (P.runModuleName mn) = return (Left P.RebuildNever) + getInputTimestamp mn + | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever) | otherwise = return (Left P.RebuildAlways) where - isPreludeModule = flip elem - [ "Prelude.Unsafe" - , "Prelude" - , "Data.Function" - , "Control.Monad.Eff" - , "Control.Monad.ST" - , "Debug.Trace" - , "Assert" - ] - + isSupportModule = flip elem supportModules + getOutputTimestamp :: P.ModuleName -> Test (Maybe UTCTime) getOutputTimestamp mn = do let filePath = modulesDir </> P.runModuleName mn exists <- liftIO $ doesDirectoryExist filePath return (if exists then Just (error "getOutputTimestamp: read timestamp") else Nothing) - + readExterns :: P.ModuleName -> Test (FilePath, String) readExterns mn = do let filePath = modulesDir </> P.runModuleName mn </> "externs.purs" (filePath, ) <$> readTextFile filePath - + codegen :: CF.Module CF.Ann -> P.Environment -> P.SupplyVar -> P.Externs -> Test () codegen m _ nextVar exts = do let mn = CF.moduleName m @@ -101,15 +112,15 @@ makeActions foreigns = P.MakeActions getInputTimestamp getOutputTimestamp readEx writeTextFile jsFile pjs maybe (return ()) (writeTextFile foreignFile . snd) $ CF.moduleName m `M.lookup` foreigns writeTextFile externsFile exts - + readTextFile :: FilePath -> Test String readTextFile path = liftIO $ readFile path - + writeTextFile :: FilePath -> String -> Test () writeTextFile path text = liftIO $ do createDirectoryIfMissing True (takeDirectory path) writeFile path text - + progress :: String -> Test () progress = liftIO . putStrLn @@ -118,28 +129,30 @@ readInput inputFiles = forM inputFiles $ \inputFile -> do text <- readFile inputFile return (inputFile, text) +type TestM = WriterT [(FilePath, String)] IO + compile :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO (Either P.MultipleErrors P.Environment) compile inputFiles foreigns = runTest $ do fs <- liftIO $ readInput inputFiles ms <- P.parseModulesFromFiles id fs - P.make (makeActions foreigns) (map (\(k, v) -> (Right k, v)) ms) + P.make (makeActions foreigns) (map snd ms) -assert :: [FilePath] -> - M.Map P.ModuleName (FilePath, P.ForeignJS) -> - (Either P.MultipleErrors P.Environment -> IO (Maybe String)) -> - IO () +assert :: [FilePath] -> + M.Map P.ModuleName (FilePath, P.ForeignJS) -> + (Either P.MultipleErrors P.Environment -> IO (Maybe String)) -> + TestM () assert inputFiles foreigns f = do - e <- compile inputFiles foreigns - maybeErr <- f e + e <- liftIO $ compile inputFiles foreigns + maybeErr <- liftIO $ f e case maybeErr of - Just err -> putStrLn err >> exitFailure + Just err -> tell [(last inputFiles, err)] Nothing -> return () -assertCompiles :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO () +assertCompiles :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> TestM () assertCompiles inputFiles foreigns = do - putStrLn $ "Assert " ++ last inputFiles ++ " compiles successfully" + liftIO . putStrLn $ "Assert " ++ last inputFiles ++ " compiles successfully" assert inputFiles foreigns $ \e -> - case e of + case e of Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs Right _ -> do process <- findNodeProcess @@ -151,36 +164,96 @@ assertCompiles inputFiles foreigns = do Just (ExitFailure _, _, err) -> return $ Just err Nothing -> return $ Just "Couldn't find node.js executable" -assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO () +assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> TestM () assertDoesNotCompile inputFiles foreigns = do - putStrLn $ "Assert " ++ last inputFiles ++ " does not compile" + let testFile = last inputFiles + liftIO . putStrLn $ "Assert " ++ testFile ++ " does not compile" + shouldFailWith <- getShouldFailWith testFile assert inputFiles foreigns $ \e -> case e of - Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> return Nothing - Right _ -> return $ Just "Should not have compiled" + Left errs -> do + putStrLn (P.prettyPrintMultipleErrors False errs) + return $ if null shouldFailWith + then Just $ "shouldFailWith declaration is missing (errors were: " + ++ show (map P.errorCode (P.runMultipleErrors errs)) + ++ ")" + else checkShouldFailWith shouldFailWith errs + Right _ -> + return $ Just "Should not have compiled" + + where + getShouldFailWith = + readFile + >>> 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 findNodeProcess :: IO (Maybe String) findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names - where + where names = ["nodejs", "node"] main :: IO () main = do + fetchSupportCode cwd <- getCurrentDirectory - - let preludeDir = cwd </> "tests" </> "prelude" - preludePurs = preludeDir </> "Prelude.purs" - jsDir = preludeDir </> "js" - jsFiles <- map (jsDir </>) . filter (".js" `isSuffixOf`) <$> getDirectoryContents jsDir - foreignFiles <- forM jsFiles (\f -> (f,) <$> readFile f) + + let supportDir = cwd </> "tests" </> "support" </> "flattened" + let supportFiles ext = Glob.globDir1 (Glob.compile ("*." ++ ext)) supportDir + + supportPurs <- supportFiles "purs" + supportJS <- supportFiles "js" + + foreignFiles <- forM supportJS (\f -> (f,) <$> readFile f) Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles - + let passing = cwd </> "examples" </> "passing" - passingTestCases <- getDirectoryContents passing - forM_ passingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $ - assertCompiles [preludePurs, passing </> inputFile] foreigns + passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passing let failing = cwd </> "examples" </> "failing" - failingTestCases <- getDirectoryContents failing - forM_ failingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $ - assertDoesNotCompile [preludePurs, failing </> inputFile] foreigns - exitSuccess + failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing + + failures <- execWriterT $ do + forM_ passingTestCases $ \inputFile -> + assertCompiles (supportPurs ++ [passing </> inputFile]) foreigns + forM_ failingTestCases $ \inputFile -> + assertDoesNotCompile (supportPurs ++ [failing </> inputFile]) foreigns + + if null failures + then exitSuccess + else do + putStrLn "Failures:" + forM_ failures $ \(fp, err) -> + let fp' = fromMaybe fp $ stripPrefix (failing ++ [pathSeparator]) fp + in putStrLn $ fp' ++ ": " ++ err + exitFailure + +fetchSupportCode :: IO () +fetchSupportCode = do + setCurrentDirectory "tests/support" + callProcess "npm" ["install"] + callProcess "bower" ["install"] + callProcess "node" ["setup.js"] + setCurrentDirectory "../.." + +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/support/flattened/Control-Monad-Eff-Class.purs b/tests/support/flattened/Control-Monad-Eff-Class.purs new file mode 100644 index 0000000..dbfd58e --- /dev/null +++ b/tests/support/flattened/Control-Monad-Eff-Class.purs @@ -0,0 +1,24 @@ +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 new file mode 100644 index 0000000..9ccfc26 --- /dev/null +++ b/tests/support/flattened/Control-Monad-Eff-Console.js @@ -0,0 +1,18 @@ +/* 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 new file mode 100644 index 0000000..0a03ee4 --- /dev/null +++ b/tests/support/flattened/Control-Monad-Eff-Console.purs @@ -0,0 +1,18 @@ +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 new file mode 100644 index 0000000..bada18a --- /dev/null +++ b/tests/support/flattened/Control-Monad-Eff-Unsafe.js @@ -0,0 +1,8 @@ +/* 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 new file mode 100644 index 0000000..5d6f104 --- /dev/null +++ b/tests/support/flattened/Control-Monad-Eff-Unsafe.purs @@ -0,0 +1,10 @@ +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 new file mode 100644 index 0000000..1498f21 --- /dev/null +++ b/tests/support/flattened/Control-Monad-Eff.js @@ -0,0 +1,62 @@ +/* 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 new file mode 100644 index 0000000..0417c19 --- /dev/null +++ b/tests/support/flattened/Control-Monad-Eff.purs @@ -0,0 +1,67 @@ +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 new file mode 100644 index 0000000..64597c1 --- /dev/null +++ b/tests/support/flattened/Control-Monad-ST.js @@ -0,0 +1,38 @@ +/* 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 new file mode 100644 index 0000000..ac113e5 --- /dev/null +++ b/tests/support/flattened/Control-Monad-ST.purs @@ -0,0 +1,42 @@ +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 new file mode 100644 index 0000000..0d6d0f4 --- /dev/null +++ b/tests/support/flattened/Data-Function.js @@ -0,0 +1,233 @@ +/* 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 new file mode 100644 index 0000000..37ceca1 --- /dev/null +++ b/tests/support/flattened/Data-Function.purs @@ -0,0 +1,113 @@ +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 new file mode 100644 index 0000000..6e4d364 --- /dev/null +++ b/tests/support/flattened/Prelude.js @@ -0,0 +1,222 @@ +/* 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; + }; + }; + }; + }; +}; + +//- Lattice -------------------------------------------------------------------- + +exports.boolOr = function (b1) { + return function (b2) { + return b1 || b2; + }; +}; + +exports.boolAnd = function (b1) { + return function (b2) { + return b1 && b2; + }; +}; + +//- ComplementedLattice -------------------------------------------------------- + +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 new file mode 100644 index 0000000..6c06c5f --- /dev/null +++ b/tests/support/flattened/Prelude.purs @@ -0,0 +1,860 @@ +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 = 2147483647 + bottom = -2147483648 + +instance boundedFn :: (Bounded b) => Bounded (a -> b) where + top _ = top + bottom _ = bottom + +-- | 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 + +-- | 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 new file mode 100644 index 0000000..ad1a67c --- /dev/null +++ b/tests/support/flattened/Test-Assert.js @@ -0,0 +1,27 @@ +/* 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 new file mode 100644 index 0000000..66b8622 --- /dev/null +++ b/tests/support/flattened/Test-Assert.purs @@ -0,0 +1,46 @@ +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 |