git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge pull request #1095 from purescript/external-ffi-files

Move JS codegen for compile into psc

commitef27736e31bcc7b4ae047bea0d03aed4609b7187 authorPhil Freeman <paf31@cantab.net> dateWed 3 Jun 2015, 14:13 (11 years ago) parentcdd856c6a21e12
223 files changed+2919−2494
.gitignore+1 examples/failing/365.purs+2 examples/failing/438.purs+4−2 examples/failing/ArrayType.purs+1 examples/failing/Arrays.purs+2−2 examples/failing/Do.purs+2 examples/failing/DuplicateDeclarationsInLet.purs+2 examples/failing/DuplicateProperties1.purs+4−2 examples/failing/DuplicateProperties2.purs+4−2 examples/failing/DuplicateTypeVars.purs+2 examples/failing/Foldable.purs+2 examples/failing/InstanceExport.purs+2 examples/failing/KindError.purs+3−1 examples/failing/LeadingZeros1.purs+3−1 examples/failing/LeadingZeros2.purs+3−1 examples/failing/Let.purs+2 examples/failing/MPTCs.purs+2 examples/failing/MissingClassExport.purs+4−2 examples/failing/MissingClassMemberExport.purs+4−2 examples/failing/MultipleErrors.purs+2 examples/failing/MultipleErrors2.purs+2 examples/failing/MutRec.purs+2 examples/failing/MutRec2.purs+2 examples/failing/NewtypeMultiArgs.purs+2 examples/failing/NewtypeMultiCtor.purs+2 examples/failing/NoOverlap.purs+2 examples/failing/NullaryAbs.purs+3−1 examples/failing/Object.purs+2 examples/failing/OverlappingArguments.purs+2 examples/failing/OverlappingBinders.purs+2 examples/failing/OverlappingInstances.purs+2 examples/failing/OverlappingInstances2.purs+2 examples/failing/OverlappingVars.purs+2 examples/failing/Rank2Types.purs+3−3 examples/failing/Reserved.purs+2 examples/failing/RowConstructors1.purs+2 examples/failing/RowConstructors2.purs+2 examples/failing/RowConstructors3.purs+2 examples/failing/SkolemEscape.purs+4−2 examples/failing/Superclasses1.purs+2 examples/failing/Superclasses2.purs+2 examples/failing/Superclasses3.purs+2 examples/failing/Superclasses4.purs+2 examples/failing/TopLevelCaseNoArgs.purs+6−3 examples/failing/TypeClassInstances.purs+2 examples/failing/TypeError.purs+2−2 examples/failing/TypeSynonyms.purs+2 examples/failing/TypeSynonyms2.purs+2 examples/failing/TypeSynonyms3.purs+2 examples/failing/TypeSynonyms4.purs+2 examples/failing/TypeSynonyms5.purs+2 examples/failing/TypeWildcards1.purs+2 examples/failing/TypeWildcards2.purs+2 examples/failing/TypeWildcards3.purs+2 examples/failing/UnderscoreModuleName.purs+2 examples/failing/UnifyInTypeInstanceLookup.purs+2 examples/failing/UnknownType.purs+2 examples/manual/QualifiedNames.purs+2 examples/manual/failing/ArgLengthMismatch.purs+4−2 examples/manual/failing/ExportExplicit.purs+4−2 examples/manual/failing/ExportExplicit2.purs+4−2 examples/manual/failing/OrphanTypeDecl.purs+1−1 examples/manual/failing/RedefinedFixity.purs+5−3 examples/manual/failing/RequiredHiddenType.purs+4−4 examples/manual/passing/ExportedInstanceDeclarations.purs+2 examples/manual/passing/TransitiveImport.purs+3 examples/passing/652.purs+2 examples/passing/810.purs+2 examples/passing/ArrayType.purs+2 examples/passing/Auto.purs+9−7 examples/passing/AutoPrelude.purs+1 examples/passing/AutoPrelude2.purs+1 examples/passing/BindersInFunctions.purs+1−7 examples/passing/BindingGroups.purs+2 examples/passing/BlockString.purs+3−7 examples/passing/CaseInDo.purs+5−6 examples/passing/CaseStatement.purs+2 examples/passing/CheckFunction.purs+2 examples/passing/CheckSynonymBug.purs+4−11 examples/passing/CheckTypeClass.purs+11−9 examples/passing/Church.purs+10−10 examples/passing/Collatz.purs+1−12 examples/passing/Comparisons.purs+2−12 examples/passing/Conditional.purs+4−4 examples/passing/DataAndType.purs+2 examples/passing/DeepArrayBinder.purs+3−8 examples/passing/DeepCase.purs+1 examples/passing/EmptyDataDecls.purs+1−16 examples/passing/EmptyRow.purs+2 examples/passing/EqOrd.purs+2 examples/passing/ExtendedInfixOperators.purs+2 examples/passing/ExternData.purs−13 examples/passing/ExternRaw.purs−26 examples/passing/FFI.purs−13 examples/passing/ForeignInstance.purs−20 examples/passing/FunctionScope.purs+9−15 examples/passing/Functions.purs+7−7 examples/passing/Functions2.purs+9−15 examples/passing/Guards.purs+1−11 examples/passing/HoistError.purs+3−10 examples/passing/IfThenElseMaybe.purs+2 examples/passing/ImplicitEmptyImport.purs+2 examples/passing/InstanceBeforeClass.purs+2 examples/passing/IntAndChar.purs+6−13 examples/passing/JSReserved.purs+6−6 examples/passing/KindedType.purs+2 examples/passing/Let2.purs+3−1 examples/passing/LetInInstance.purs+2 examples/passing/LiberalTypeSynonyms.purs+2 examples/passing/Match.purs+5−3 examples/passing/Monad.purs+21−21 examples/passing/MultiArgFunctions.purs+1 examples/passing/MutRec.purs+10−10 examples/passing/MutRec2.purs+2 examples/passing/MutRec3.purs+2 examples/passing/NamedPatterns.purs+6−4 examples/passing/NegativeBinder.purs+2 examples/passing/Nested.purs+5−3 examples/passing/NestedTypeSynonyms.purs+6−6 examples/passing/NestedWhere.purs+2 examples/passing/Newtype.purs+1 examples/passing/NewtypeEff.purs+1 examples/passing/NewtypeWithRecordUpdate.purs+2−1 examples/passing/ObjectGetter.purs+2 examples/passing/ObjectSynonym.purs+2 examples/passing/ObjectUpdate.purs+13−11 examples/passing/ObjectUpdate2.purs+4−1 examples/passing/ObjectUpdater.purs+6−17 examples/passing/ObjectWildcards.purs+4−15 examples/passing/Objects.purs+20−20 examples/passing/OneConstructor.purs+2 examples/passing/OperatorAssociativity.purs+16−41 examples/passing/OperatorInlining.purs+1 examples/passing/OperatorSections.purs+6−16 examples/passing/Operators.purs+68−67 examples/passing/PartialFunction.purs+3−12 examples/passing/Patterns.purs+15−15 examples/passing/Person.purs+6−13 examples/passing/Rank2Data.purs+18−18 examples/passing/Rank2Object.purs+1 examples/passing/Rank2TypeSynonym.purs+1 examples/passing/Rank2Types.purs+6−6 examples/passing/RebindableSyntax.purs+2 examples/passing/Recursion.purs+6−6 examples/passing/ReservedWords.purs+9−7 examples/passing/RowConstructors.purs+2 examples/passing/RowPolyInstanceContext.purs+2 examples/passing/RowSynonyms.purs−46 examples/passing/ScopedTypeVariables.purs+3−1 examples/passing/Sequence.purs+1 examples/passing/SequenceDesugared.purs+1 examples/passing/ShadowedRename.purs+3−10 examples/passing/ShadowedTCO.purs+2 examples/passing/ShadowedTCOLet.purs+2 examples/passing/SignedNumericLiterals.purs+12−10 examples/passing/Superclasses1.purs+2 examples/passing/Superclasses2.purs+1 examples/passing/Superclasses3.purs+1−1 examples/passing/TCOCase.purs+2 examples/passing/Tick.purs+2 examples/passing/TopLevelCase.purs+1−11 examples/passing/TypeClassImport.purs−18 examples/passing/TypeClassMemberOrderChange.purs+2 examples/passing/TypeClassesWithOverlappingTypeVariables.purs+6−6 examples/passing/TypeDecl.purs+7−7 examples/passing/TypeSynonymInData.purs+2 examples/passing/TypeSynonyms.purs+20−18 examples/passing/TypeWildcards.purs+2 examples/passing/TypeWildcardsRecordExtension.purs+2 examples/passing/TypedWhere.purs+2 examples/passing/UnderscoreIdent.purs+2 examples/passing/UnknownInTypeClassLookup.purs+2 examples/passing/iota.purs+4−4 examples/passing/s.purs+4−2 hierarchy/Main.hs+3−6 psc-docs/Main.hs−1 psc-docs/Tags.hs+1−1 psc-make/Main.hs+46−66 psc-make/Make.hs+138 psc/Main.hs+46−33 psci/Completion.hs+1−1 psci/IO.hs+21 psci/Make.hs+127 psci/PSCi.hs+60−86 psci/Parser.hs+7−7 psci/Types.hs+6−3 psci/tests/Main.hs+17−8 purescript.cabal+9−5 src/Language/PureScript.hs+110−105 src/Language/PureScript/AST/Declarations.hs+3−4 src/Language/PureScript/AST/Exported.hs+1−1 src/Language/PureScript/AST/Traversals.hs+1−1 src/Language/PureScript/CodeGen/Externs.hs+4−4 src/Language/PureScript/CodeGen/JS.hs+27−12 src/Language/PureScript/CoreFn/Desugar.hs+13−4 src/Language/PureScript/CoreFn/Meta.hs+5−1 src/Language/PureScript/CoreFn/Module.hs+1−2 src/Language/PureScript/DeadCodeElimination.hs+1−1 src/Language/PureScript/Docs/ParseAndDesugar.hs+2−6 src/Language/PureScript/Docs/Render.hs+2−2 src/Language/PureScript/Environment.hs+16−32 src/Language/PureScript/Errors.hs+299−201 src/Language/PureScript/Linter.hs+8−8 src/Language/PureScript/Options.hs+3−7 src/Language/PureScript/Parser.hs+1 src/Language/PureScript/Parser/Declarations.hs+30−23 src/Language/PureScript/Parser/JS.hs+59 src/Language/PureScript/Sugar/CaseDeclarations.hs+9−9 src/Language/PureScript/Sugar/Names.hs+3−3 src/Language/PureScript/Sugar/TypeClasses.hs+3−3 src/Language/PureScript/TypeChecker.hs+2−2 src/Language/PureScript/TypeChecker/Monad.hs+2−2 src/Language/PureScript/TypeChecker/Types.hs+2−2 tests/Main.hs+37−28 tests/prelude.purs−1068 tests/prelude/Prelude.purs+628 tests/prelude/js/Assert.js+19 tests/prelude/js/Control.Monad.Eff.js+40 tests/prelude/js/Control.Monad.ST.js+38 tests/prelude/js/Data.Function.js+233 tests/prelude/js/Debug.Trace.js+11 tests/prelude/js/Prelude.Unsafe.js+10 tests/prelude/js/Prelude.js+150
.gitignore+1
@@ -9,4 +9,5 @@ cabal.sandbox.config
99*.lksh*
1010.virthualenv
1111.psci_modules/
12+bower_components/
1213tmp/
examples/failing/365.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35class C a where
46 f :: a -> a
57 g :: a -> a
examples/failing/438.purs+4−2
@@ -1,9 +1,11 @@
11module Main where
2−
2+
3+import Prelude
4+
35data Fix f = In (f (Fix f))
46
57instance eqFix :: (Eq (f (Fix f))) => Eq (Fix f) where
68 (==) (In f) (In g) = f == g
79 (/=) a b = not (a == b)
8−
10+
911example = In [] == In []
examples/failing/ArrayType.purs+1
@@ -1,5 +1,6 @@
11module Main where
22
3+import Prelude
34import Debug.Trace
45
56bar :: Number -> Number -> Number
examples/failing/Arrays.purs+2−2
@@ -1,5 +1,5 @@
11module Main where
22
3− import Prelude
3+import Prelude
44
5− test = \arr -> arr !! (0 !! 0)
5+test = \arr -> arr !! (0 !! 0)
examples/failing/Do.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35test1 = do let x = 1
46
57test2 y = do x <- y
examples/failing/DuplicateDeclarationsInLet.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35foo = a
46 where
57 a :: Number
examples/failing/DuplicateProperties1.purs+4−2
@@ -1,9 +1,11 @@
11module DuplicateProperties where
22
3+import Prelude
4+
35foreign import data Test :: # * -> *
46
5−foreign import subtractX "" :: forall r. Test (x :: Unit | r) -> Test r
7+foreign import subtractX :: forall r. Test (x :: Unit | r) -> Test r
68
7−foreign import hasX "" :: Test (x :: Unit, y :: Unit)
9+foreign import hasX :: Test (x :: Unit, y :: Unit)
810
911baz = subtractX (subtractX hasX)
examples/failing/DuplicateProperties2.purs+4−2
@@ -1,9 +1,11 @@
11module DuplicateProperties where
22
3+import Prelude
4+
35foreign import data Test :: # * -> *
46
5−foreign import subtractX "" :: forall r. Test (x :: Unit | r) -> Test r
7+foreign import subtractX :: forall r. Test (x :: Unit | r) -> Test r
68
7−foreign import hasX "" :: forall r. Test (x :: Unit, y :: Unit | r)
9+foreign import hasX :: forall r. Test (x :: Unit, y :: Unit | r)
810
911baz = subtractX (subtractX hasX)
examples/failing/DuplicateTypeVars.purs+2
@@ -1,3 +1,5 @@
11module Main where
22
3+import Prelude
4+
35type Foo a a = a
examples/failing/Foldable.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35class Foldable f where
46 fold :: forall a b. (a -> b -> b) -> b -> f a -> b
57 size :: forall a. f a -> Number
examples/failing/InstanceExport.purs+2
@@ -1,5 +1,7 @@
11module InstanceExport (S(..), f) where
22
3+import Prelude
4+
35newtype S = S String
46
57class F a where
examples/failing/KindError.purs+3−1
@@ -1,3 +1,5 @@
11module Main where
22
3− data KindError f a = One f | Two (f a)
3+import Prelude
4+
5+data KindError f a = One f | Two (f a)
examples/failing/LeadingZeros1.purs+3−1
@@ -1,3 +1,5 @@
11module Main where
22
3−x = 01
3+import Prelude
4+
5+x = 01
examples/failing/LeadingZeros2.purs+3−1
@@ -1,3 +1,5 @@
11module Main where
22
3−x = 00.1
3+import Prelude
4+
5+x = 00.1
examples/failing/Let.purs+2
@@ -1,3 +1,5 @@
11module Main where
22
3+import Prelude
4+
35test = let x = x in x
examples/failing/MPTCs.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35class Foo a where
46 f :: a -> a
57
examples/failing/MissingClassExport.purs+4−2
@@ -1,4 +1,6 @@
11module Test (bar) where
22
3− class Foo a where
4− bar :: a -> a
3+import Prelude
4+
5+class Foo a where
6+ bar :: a -> a
examples/failing/MissingClassMemberExport.purs+4−2
@@ -1,4 +1,6 @@
11module Test (Foo) where
22
3− class Foo a where
4− bar :: a -> a
3+import Prelude
4+
5+class Foo a where
6+ bar :: a -> a
examples/failing/MultipleErrors.purs+2
@@ -1,5 +1,7 @@
11module MultipleErrors where
22
3+import Prelude
4+
35foo :: Number -> Number
46foo 0 = "Test"
57foo n = bar (n - 1)
examples/failing/MultipleErrors2.purs+2
@@ -1,5 +1,7 @@
11module MultipleErrors2 where
22
3+import Prelude
4+
35foo = itDoesntExist
46
57bar = neitherDoesThis
examples/failing/MutRec.purs+2
@@ -1,5 +1,7 @@
11module MutRec where
22
3+import Prelude
4+
35x = y
46
57y = x
examples/failing/MutRec2.purs+2
@@ -1,3 +1,5 @@
11module Main where
22
3+import Prelude
4+
35x = x
examples/failing/NewtypeMultiArgs.purs+2
@@ -1,3 +1,5 @@
11module Main where
22
3+import Prelude
4+
35newtype Thing = Thing String Boolean
examples/failing/NewtypeMultiCtor.purs+2
@@ -1,3 +1,5 @@
11module Main where
22
3+import Prelude
4+
35newtype Thing = Thing String | Other
examples/failing/NoOverlap.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35data Foo = Foo
46
57instance showFoo1 :: Show Foo where
examples/failing/NullaryAbs.purs+3−1
@@ -1,3 +1,5 @@
11module Main where
22
3− func = \ -> "no"
3+import Prelude
4+
5+func = \ -> "no"
examples/failing/Object.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35test o = o.foo
46
57test1 = test {}
examples/failing/OverlappingArguments.purs+2
@@ -1,3 +1,5 @@
11module OverlappingArguments where
22
3+import Prelude
4+
35f x x = x
examples/failing/OverlappingBinders.purs+2
@@ -1,5 +1,7 @@
11module OverlappingBinders where
22
3+import Prelude
4+
35data S a = S a (S a)
46
57f x = case x of
examples/failing/OverlappingInstances.purs+2
@@ -1,5 +1,7 @@
11module OverlappingInstances where
22
3+import Prelude
4+
35data A = A
46
57instance showA1 :: Show A where
examples/failing/OverlappingInstances2.purs+2
@@ -1,5 +1,7 @@
11module OverlappingInstances where
22
3+import Prelude
4+
35data A = A | B
46
57instance eqA1 :: Eq A where
examples/failing/OverlappingVars.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35class OverlappingVars a where
46 f :: a -> a
57
examples/failing/Rank2Types.purs+3−3
@@ -1,7 +1,7 @@
11module Main where
22
3− import Prelude
3+import Prelude
44
5− foreign import test :: (forall a. a -> a) -> Number
5+foreign import test :: (forall a. a -> a) -> Number
66
7− test1 = test (\n -> n + 1)
7+test1 = test (\n -> n + 1)
examples/failing/Reserved.purs+2
@@ -1,4 +1,6 @@
11module Main where
22
3+import Prelude
4+
35(<) :: Number -> Number -> Number
46(<) a b = !(a >= b)
examples/failing/RowConstructors1.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35data Foo = Bar
46type Baz = { | Foo }
57
examples/failing/RowConstructors2.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35type Foo r = (x :: Number | r)
46type Bar = { | Foo }
57
examples/failing/RowConstructors3.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35type Foo = { x :: Number }
46type Bar = { | Foo }
57
examples/failing/SkolemEscape.purs+4−2
@@ -1,5 +1,7 @@
11module Main where
22
3− foreign import foo :: (forall a. a -> a) -> Number
3+import Prelude
44
5− test = \x -> foo x
5+foreign import foo :: (forall a. a -> a) -> Number
6+
7+test = \x -> foo x
examples/failing/Superclasses1.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35class Su a where
46 su :: a -> a
57
examples/failing/Superclasses2.purs+2
@@ -1,5 +1,7 @@
11module CycleInSuperclasses where
22
3+import Prelude
4+
35class (Foo a) <= Bar a
46
57class (Bar a) <= Foo a
examples/failing/Superclasses3.purs+2
@@ -1,5 +1,7 @@
11module UnknownSuperclassTypeVar where
22
3+import Prelude
4+
35class Foo a
46
57class (Foo b) <= Bar a
examples/failing/Superclasses4.purs+2
@@ -1,5 +1,7 @@
11module OverlappingInstances where
22
3+import Prelude
4+
35class Foo a
46
57instance foo1 :: Foo Number
examples/failing/TopLevelCaseNoArgs.purs+6−3
@@ -1,4 +1,7 @@
11module Main where
2− foo :: Number
3− foo = 1
4− foo = 2
2+
3+import Prelude
4+
5+foo :: Number
6+foo = 1
7+foo = 2
examples/failing/TypeClassInstances.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35class A a where
46 a :: a -> String
57 b :: a -> Number
examples/failing/TypeError.purs+2−2
@@ -1,5 +1,5 @@
11module Main where
22
3− import Prelude
3+import Prelude
44
5− test = 1 ++ "A"
5+test = 1 ++ "A"
examples/failing/TypeSynonyms.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35type T1 = Array T2
46
57type T2 = T1
examples/failing/TypeSynonyms2.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35class Foo a where
46 foo :: a -> String
57
examples/failing/TypeSynonyms3.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35class Foo a where
46 foo :: a -> String
57
examples/failing/TypeSynonyms4.purs+2
@@ -1,5 +1,7 @@
11module TypeSynonyms4 where
22
3+import Prelude
4+
35type F x y = x -> y
46
57type G x = F x
examples/failing/TypeSynonyms5.purs+2
@@ -1,3 +1,5 @@
11module Main where
22
3+import Prelude
4+
35type T = T
examples/failing/TypeWildcards1.purs+2
@@ -1,4 +1,6 @@
11module TypeWildcards where
22
3+import Prelude
4+
35type Test = _
46
examples/failing/TypeWildcards2.purs+2
@@ -1,4 +1,6 @@
11module TypeWildcards where
22
3+import Prelude
4+
35data Test = Test _
46
examples/failing/TypeWildcards3.purs+2
@@ -1,5 +1,7 @@
11module TypeWildcards where
22
3+import Prelude
4+
35data Foo a = Foo
46
57instance showFoo :: Show (Foo _) where
examples/failing/UnderscoreModuleName.purs+2
@@ -1,3 +1,5 @@
11module Bad_Module where
22
3+import Prelude
4+
35main = Debug.Trace.trace "Done"
examples/failing/UnifyInTypeInstanceLookup.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35data Z = Z
46data S n = S n
57
examples/failing/UnknownType.purs+2
@@ -1,4 +1,6 @@
11module Main where
22
3+import Prelude
4+
35test :: Number -> Something
46test = {}
examples/manual/QualifiedNames.purs+2
@@ -1,5 +1,7 @@
11module Data.Either where
22
3+import Prelude
4+
35data Either a b = Left a | Right b
46
57module Main where
examples/manual/failing/ArgLengthMismatch.purs+4−2
@@ -1,4 +1,6 @@
11module ArgLengthMismatch where
22
3− f x y = true
4− f = false
3+import Prelude
4+
5+f x y = true
6+f = false
examples/manual/failing/ExportExplicit.purs+4−2
@@ -1,5 +1,7 @@
11-- should fail as z does not exist in the module
22module M1 (x, y, z) where
33
4− x = 1
5− y = 2
4+import Prelude
5+
6+x = 1
7+y = 2
examples/manual/failing/ExportExplicit2.purs+4−2
@@ -1,5 +1,7 @@
11-- should fail as Y is not a data constructor for X
22module M1 (X(Y)) where
33
4− data X = X
5− data Y = Y
4+import Prelude
5+
6+data X = X
7+data Y = Y
examples/manual/failing/OrphanTypeDecl.purs+1−1
@@ -1,3 +1,3 @@
11module OrphanTypeDecl where
22
3− fn :: Number -> Boolean
3+fn :: Number -> Boolean
examples/manual/failing/RedefinedFixity.purs+5−3
@@ -1,6 +1,8 @@
11module RedefinedFixity where
22
3− (!?) x y = x + y
3+import Prelude
44
5− infix 2 !?
6− infix 2 !?
5+(!?) x y = x + y
6+
7+infix 2 !?
8+infix 2 !?
examples/manual/failing/RequiredHiddenType.purs+4−4
@@ -1,8 +1,8 @@
11-- exporting `a` should fail as `A` is hidden
22module Foo (B(..), a, b) where
33
4− data A = A
5− data B = B
4+data A = A
5+data B = B
66
7− a = A
8− b = B
7+a = A
8+b = B
examples/manual/passing/ExportedInstanceDeclarations.purs+2
@@ -8,6 +8,8 @@ module ExportedInstanceDeclarations
88 , foo
99 ) where
1010
11+import Prelude
12+
1113data Const a b = Const a
1214
1315class Foo a where
examples/manual/passing/TransitiveImport.purs+3
@@ -1,5 +1,7 @@
11module Test where
22
3+ import Prelude
4+
35 class TestCls a where
46 test :: a -> a
57
@@ -12,6 +14,7 @@ module Middle where
1214
1315module Main where
1416
17+ import Prelude
1518 import Middle
1619 import Debug.Trace
1720
examples/passing/652.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35class Foo a b
46
57class Bar a c
examples/passing/810.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35data Maybe a = Nothing | Just a
46
57test :: forall a. Maybe a -> Maybe a
examples/passing/ArrayType.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35class Pointed p where
46 point :: forall a. a -> p a
57
examples/passing/Auto.purs+9−7
@@ -1,13 +1,15 @@
11module Main where
22
3− data Auto s i o = Auto { state :: s, step :: s -> i -> o }
3+import Prelude
44
5− type SomeAuto i o = forall r. (forall s. Auto s i o -> r) -> r
5+data Auto s i o = Auto { state :: s, step :: s -> i -> o }
66
7− exists :: forall s i o. s -> (s -> i -> o) -> SomeAuto i o
8− exists = \state step f -> f (Auto { state: state, step: step })
7+type SomeAuto i o = forall r. (forall s. Auto s i o -> r) -> r
98
10− run :: forall i o. SomeAuto i o -> i -> o
11− run = \s i -> s (\a -> case a of Auto a -> a.step a.state i)
9+exists :: forall s i o. s -> (s -> i -> o) -> SomeAuto i o
10+exists = \state step f -> f (Auto { state: state, step: step })
1211
13− main = Debug.Trace.trace "Done"
12+run :: forall i o. SomeAuto i o -> i -> o
13+run = \s i -> s (\a -> case a of Auto a -> a.step a.state i)
14+
15+main = Debug.Trace.trace "Done"
examples/passing/AutoPrelude.purs+1
@@ -1,5 +1,6 @@
11module Main where
22
3+import Prelude
34import Debug.Trace
45
56f x = x * 10.0
examples/passing/AutoPrelude2.purs+1
@@ -1,5 +1,6 @@
11module Main where
22
3+import Prelude
34import qualified Prelude as P
45import Debug.Trace
56
examples/passing/BindersInFunctions.purs+1−7
@@ -1,16 +1,10 @@
11module Main where
22
33import Prelude
4+import Assert
45
56snd = \[_, y] -> y
67
7−foreign import error
8− """
9− function error(msg) {
10− throw msg;
11− }
12− """ :: forall a. String -> a
13−
148main =
159 let ts = snd [1.0, 2.0] in
1610 if ts == 2.0
examples/passing/BindingGroups.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35foo = bar
46 where bar r = r + 1.0
57
examples/passing/BlockString.purs+3−7
@@ -1,12 +1,8 @@
11module Main where
22
3−foreign import foo """
4− function foo(s) {
5− return s;
6− }
7−""" :: String -> String
3+import Prelude
84
9−bar :: String -> String
10−bar _ = foo "test"
5+foo :: String
6+foo = """foo"""
117
128main = Debug.Trace.trace "Done"
examples/passing/CaseInDo.purs+5−6
@@ -1,20 +1,19 @@
11module Main where
22
3+import Prelude
34import Debug.Trace
45import Control.Monad.Eff
56
6−foreign import doIt "function doIt() { global.flag = true; }" :: forall eff. Eff eff Unit
7−
8−foreign import get "function get() { return global.flag; }" :: forall eff. Eff eff Boolean
7+doIt :: forall eff. Eff eff Boolean
8+doIt = return true
99
1010set = do
1111 trace "Testing..."
1212 case 0 of
1313 0 -> doIt
14− _ -> return unit
14+ _ -> return false
1515
1616main = do
17− set
18− b <- get
17+ b <- set
1918 case b of
2019 true -> trace "Done"
examples/passing/CaseStatement.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35data A = A | B | C
46
57f a _ A = a
examples/passing/CheckFunction.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35test = ((\x -> x+1.0) >>> (\x -> x*2.0)) 4.0
46
57main = Debug.Trace.trace "Done"
examples/passing/CheckSynonymBug.purs+4−11
@@ -1,16 +1,9 @@
11module Main where
22
3− import Prelude
3+import Prelude
44
5− type Foo a = Array a
5+type Foo a = Array a
66
7− foreign import length
8− """
9− function length(a) {
10− return a.length;
11− }
12− """ :: forall a. Array a -> Number
7+foo _ = length ([] :: Foo Number)
138
14− foo _ = length ([] :: Foo Number)
15−
16− main = Debug.Trace.trace "Done"
9+main = Debug.Trace.trace "Done"
examples/passing/CheckTypeClass.purs+11−9
@@ -1,16 +1,18 @@
11module Main where
22
3− data Bar a = Bar
4− data Baz
3+import Prelude
54
6− class Foo a where
7− foo :: Bar a -> Baz
5+data Bar a = Bar
6+data Baz
87
9− foo_ :: forall a. (Foo a) => a -> Baz
10− foo_ x = foo ((mkBar :: forall a. (Foo a) => a -> Bar a) x)
8+class Foo a where
9+ foo :: Bar a -> Baz
1110
12− mkBar :: forall a. a -> Bar a
13− mkBar _ = Bar
11+foo_ :: forall a. (Foo a) => a -> Baz
12+foo_ x = foo ((mkBar :: forall a. (Foo a) => a -> Bar a) x)
1413
15− main = Debug.Trace.trace "Done"
14+mkBar :: forall a. a -> Bar a
15+mkBar _ = Bar
16+
17+main = Debug.Trace.trace "Done"
1618
examples/passing/Church.purs+10−10
@@ -1,18 +1,18 @@
11module Main where
22
3− import Prelude ()
3+import Prelude ()
44
5− type List a = forall r. r -> (a -> r -> r) -> r
5+type List a = forall r. r -> (a -> r -> r) -> r
66
7− empty :: forall a. List a
8− empty = \r f -> r
7+empty :: forall a. List a
8+empty = \r f -> r
99
10− cons :: forall a. a -> List a -> List a
11− cons = \a l r f -> f a (l r f)
10+cons :: forall a. a -> List a -> List a
11+cons = \a l r f -> f a (l r f)
1212
13− append :: forall a. List a -> List a -> List a
14− append = \l1 l2 r f -> l2 (l1 r f) f
13+append :: forall a. List a -> List a -> List a
14+append = \l1 l2 r f -> l2 (l1 r f) f
1515
16− test = append (cons 1 empty) (cons 2 empty)
16+test = append (cons 1 empty) (cons 2 empty)
1717
18− main = Debug.Trace.trace "Done"
18+main = Debug.Trace.trace "Done"
examples/passing/Collatz.purs+1−12
@@ -1,20 +1,9 @@
11module Main where
22
3+import Prelude
34import Control.Monad.Eff
45import Control.Monad.ST
56
6−foreign import jsMod
7− """
8− function jsMod(x) {
9− return function (y) {
10− return x % y;
11− };
12− }
13− """ :: Number -> Number -> Number
14−
15−infixl 7 %
16−(%) = jsMod
17−
187collatz :: Number -> Number
198collatz n = runPure (runST (do
209 r <- newSTRef n
examples/passing/Comparisons.purs+2−12
@@ -1,19 +1,9 @@
11module Main where
22
3+import Prelude
34import Control.Monad.Eff
45import Debug.Trace
5−
6−foreign import data Assert :: !
7−
8−foreign import assert
9− """
10− function assert(x) {
11− return function() {
12− if (!x) throw new Error('assertion failed');
13− return {};
14− };
15− }
16− """ :: forall e. Boolean -> Eff (assert :: Assert | e) Unit
6+import Assert
177
188main = do
199 assert (1.0 < 2.0)
examples/passing/Conditional.purs+4−4
@@ -1,9 +1,9 @@
11module Main where
22
3− import Prelude ()
3+import Prelude ()
44
5− fns = \f -> if f true then f else \x -> x
5+fns = \f -> if f true then f else \x -> x
66
7− not = \x -> if x then false else true
7+not = \x -> if x then false else true
88
9− main = Debug.Trace.trace "Done"
9+main = Debug.Trace.trace "Done"
examples/passing/DataAndType.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35data A = A B
46
57type B = A
examples/passing/DeepArrayBinder.purs+3−8
@@ -1,6 +1,8 @@
11module Main where
22
3+import Prelude
34import Control.Monad.Eff
5+import Assert
46
57data List a = Cons a (List a) | Nil
68
@@ -8,13 +10,6 @@ match2 :: List Number -> Number
810match2 (Cons x (Cons y xs)) = x * y + match2 xs
911match2 _ = 0.0
1012
11−foreign import explode
12− """
13− function explode() {
14− throw new Error('Incorrect result');
15− }
16− """ :: forall eff a. Eff eff a
17−
1813main = 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
1914 100.0 -> Debug.Trace.trace "Done"
20− _ -> explode
15+ _ -> error "Incorrect result!"
examples/passing/DeepCase.purs+1
@@ -1,5 +1,6 @@
11module Main where
22
3+import Prelude
34import Debug.Trace
45import Control.Monad.Eff
56import Control.Monad.ST
examples/passing/EmptyDataDecls.purs+1−16
@@ -1,6 +1,7 @@
11module Main where
22
33import Prelude
4+import Assert
45
56data Z
67data S n
@@ -10,25 +11,9 @@ data ArrayBox n a = ArrayBox (Array a)
1011nil :: forall a. ArrayBox Z a
1112nil = ArrayBox []
1213
13−foreign import concat
14− """
15− function concat(l1) {
16− return function(l2) {
17− return l1.concat(l2);
18− };
19− }
20− """ :: forall a. Array a -> Array a -> Array a
21−
2214cons' :: forall a n. a -> ArrayBox n a -> ArrayBox (S n) a
2315cons' x (ArrayBox xs) = ArrayBox $ concat [x] xs
2416
25−foreign import error
26− """
27− function error(msg) {
28− throw msg;
29− }
30− """ :: forall a. String -> a
31−
3217main = case cons' 1 $ cons' 2 $ cons' 3 nil of
3318 ArrayBox [1, 2, 3] -> Debug.Trace.trace "Done"
3419 _ -> error "Failed"
examples/passing/EmptyRow.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35data Foo r = Foo { | r }
46
57test :: Foo ()
examples/passing/EqOrd.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35data Pair a b = Pair a b
46
57instance ordPair :: (Ord a, Ord b) => Ord (Pair a b) where
examples/passing/ExtendedInfixOperators.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35comparing :: forall a b. (Ord b) => (a -> b) -> a -> a -> Ordering
46comparing f = compare `Data.Function.on` f
57
examples/passing/ExternData.pursdeleted−13
@@ -1,13 +0,0 @@
1−module Main where
2−
3− foreign import data IO :: * -> *
4−
5− foreign import bind "function bind() {}" :: forall a b. IO a -> (a -> IO b) -> IO b
6−
7− foreign import showMessage "function showMessage() {}" :: String -> IO { }
8−
9− foreign import prompt "function prompt() {}" :: IO String
10−
11− test _ = prompt `bind` \s -> showMessage s
12−
13− main = Debug.Trace.trace "Done"
examples/passing/ExternRaw.pursdeleted−26
@@ -1,26 +0,0 @@
1−module Main where
2−
3−foreign import first
4− """
5− function first(xs) {
6− return xs[0];
7− }
8− """ :: forall a. Array a -> a
9−
10−foreign import loop
11− """
12− function loop() {
13− while (true) {}
14− }
15− """ :: forall a. a
16−
17−foreign import concat
18− """
19− function concat(xs) {
20− return function(ys) {
21− return xs.concat(ys);
22− };
23− }
24− """ :: forall a. Array a -> Array a -> Array a
25−
26−main = Debug.Trace.trace "Done"
examples/passing/FFI.pursdeleted−13
@@ -1,13 +0,0 @@
1−module Main where
2−
3−foreign import foo
4− """
5− function foo(s) {
6− return s;
7− }
8− """ :: String -> String
9−
10−bar :: String -> String
11−bar _ = foo "test"
12−
13−main = Debug.Trace.trace "Done"
examples/passing/ForeignInstance.pursdeleted−20
@@ -1,20 +0,0 @@
1−module Main where
2−
3−class Foo a where
4− foo :: a -> String
5−
6−foreign import instance fooArray :: (Foo a) => Foo (Array a)
7−
8−foreign import instance fooNumber :: Foo Number
9−
10−foreign import instance fooString :: Foo String
11−
12−foreign import fooString "var fooString = {};" :: Unit
13−foreign import fooNumber "var fooNumber = {};" :: Unit
14−foreign import fooArray "var fooArray = {};" :: Unit
15−
16−test1 _ = foo [1.0, 2.0, 3.0]
17−
18−test2 _ = foo "Test"
19−
20−main = Debug.Trace.trace "Done"
examples/passing/FunctionScope.purs+9−15
@@ -1,19 +1,13 @@
11module Main where
22
3− import Prelude
3+import Prelude
4+import Assert
45
5− mkValue :: Number -> Number
6− mkValue id = id
6+mkValue :: Number -> Number
7+mkValue id = id
78
8− foreign import error
9− """
10− function error(msg) {
11− throw msg;
12− }
13− """ :: forall a. String -> a
14−
15− main = do
16− let value = mkValue 1.0
17− if value == 1.0
18− then Debug.Trace.trace "Done"
19− else error "Not done"
9+main = do
10+ let value = mkValue 1.0
11+ if value == 1.0
12+ then Debug.Trace.trace "Done"
13+ else error "Not done"
examples/passing/Functions.purs+7−7
@@ -1,15 +1,15 @@
11module Main where
22
3− import Prelude
3+import Prelude
44
5− test1 = \_ -> 0.0
5+test1 = \_ -> 0.0
66
7− test2 = \a b -> a + b + 1.0
7+test2 = \a b -> a + b + 1.0
88
9− test3 = \a -> a
9+test3 = \a -> a
1010
11− test4 = \(%%) -> 1.0 %% 2.0
11+test4 = \(%%) -> 1.0 %% 2.0
1212
13− test5 = \(+++) (***) -> 1.0 +++ 2.0 *** 3.0
13+test5 = \(+++) (***) -> 1.0 +++ 2.0 *** 3.0
1414
15− main = Debug.Trace.trace "Done"
15+main = Debug.Trace.trace "Done"
examples/passing/Functions2.purs+9−15
@@ -1,19 +1,13 @@
11module Main where
22
3− import Prelude
3+import Prelude
4+import Assert
45
5− test :: forall a b. a -> b -> a
6− test = \const _ -> const
6+test :: forall a b. a -> b -> a
7+test = \const _ -> const
78
8− foreign import error
9− """
10− function error(msg) {
11− throw msg;
12− }
13− """ :: forall a. String -> a
14−
15− main = do
16− let value = test "Done" {}
17− if value == "Done"
18− then Debug.Trace.trace "Done"
19− else error "Not done"
9+main = do
10+ let value = test "Done" {}
11+ if value == "Done"
12+ then Debug.Trace.trace "Done"
13+ else error "Not done"
examples/passing/Guards.purs+1−11
@@ -1,16 +1,6 @@
11module Main where
22
3−foreign import jsMod
4− """
5− function jsMod(x) {
6− return function (y) {
7− return x % y;
8− };
9− }
10− """ :: Number -> Number -> Number
11−
12−infixl 7 %
13−(%) = jsMod
3+import Prelude
144
155collatz = \x -> case x of
166 y | y % 2.0 == 0.0 -> y / 2.0
examples/passing/HoistError.purs+3−10
@@ -1,19 +1,12 @@
11module Main where
22
3+import Prelude
34import Control.Monad.Eff
45import Debug.Trace
5−
6−foreign import f
7− """
8− function f(x) {
9− return function() {
10− if (x !== 0) throw new Error('x is not 0');
11− };
12− }
13− """ :: forall e. Number -> Eff e Number
6+import Assert
147
158main = do
169 let x = 0.0
17− f x
10+ assert $ x == 0.0
1811 let x = 1.0 + 1.0
1912 trace "Done"
examples/passing/IfThenElseMaybe.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35data Maybe a = Nothing | Just a
46
57test1 = if true then Just 10 else Nothing
examples/passing/ImplicitEmptyImport.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35main = do
46 Debug.Trace.trace "Hello"
57 Debug.Trace.trace "Goodbye"
examples/passing/InstanceBeforeClass.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35instance fooNumber :: Foo Number where
46 foo = 0.0
57
examples/passing/IntAndChar.purs+6−13
@@ -1,6 +1,8 @@
11module Main where
22
3+import Prelude
34import Control.Monad.Eff
5+import Assert
46
57f 1 = 1
68f _ = 0
@@ -8,18 +10,9 @@ f _ = 0
810g 'a' = 'a'
911g _ = 'b'
1012
11−foreign import assertEqual
12− """
13− function assertEqual(a) { return function(b) { return function() {
14− if (a != b) {
15− throw new Error('Assertion failed!');
16− }
17− }; }; }
18− """ :: forall eff a. a -> a -> Eff eff Unit
19−
2013main = do
21− assertEqual (f 1) 1
22− assertEqual (f 0) 0
23− assertEqual (g 'a') 'a'
24− assertEqual (g 'b') 'b'
14+ assert $ f 1 == 1
15+ assert $ f 0 == 0
16+ assert $ g 'a' == 'a'
17+ assert $ g 'b' == 'b'
2518 Debug.Trace.trace "Done"
examples/passing/JSReserved.purs+6−6
@@ -1,12 +1,12 @@
11module Main where
22
3− import Prelude
3+import Prelude
44
5− yield = 0
6− member = 1
5+yield = 0
6+member = 1
77
8− public = \return -> return
8+public = \return -> return
99
10− this catch = catch
10+this catch = catch
1111
12− main = Debug.Trace.trace "Done"
12+main = Debug.Trace.trace "Done"
examples/passing/KindedType.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35type Star2Star f = f :: * -> *
46
57type Star t = t :: *
examples/passing/Let2.purs+3−1
@@ -1,6 +1,8 @@
11module Main where
22
3−test =
3+import Prelude
4+
5+test =
46 let f :: Number -> Boolean
57 f 0.0 = false
68 f n = g (n - 1.0)
examples/passing/LetInInstance.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35class Foo a where
46 foo :: a -> String
57
examples/passing/LiberalTypeSynonyms.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35type Reader = (->) String
46
57foo :: Reader String
examples/passing/Match.purs+5−3
@@ -1,7 +1,9 @@
11module Main where
22
3− data Foo a = Foo
3+import Prelude
44
5− foo = \f -> case f of Foo -> "foo"
5+data Foo a = Foo
66
7− main = Debug.Trace.trace "Done"
7+foo = \f -> case f of Foo -> "foo"
8+
9+main = Debug.Trace.trace "Done"
examples/passing/Monad.purs+21−21
@@ -1,32 +1,32 @@
11module Main where
22
3− import Prelude ()
3+import Prelude ()
44
5− type Monad m = { return :: forall a. a -> m a
6− , bind :: forall a b. m a -> (a -> m b) -> m b }
5+type Monad m = { return :: forall a. a -> m a
6+ , bind :: forall a b. m a -> (a -> m b) -> m b }
77
8− data Id a = Id a
8+data Id a = Id a
99
10− id :: Monad Id
11− id = { return : Id
12− , bind : \ma f -> case ma of Id a -> f a }
10+id :: Monad Id
11+id = { return : Id
12+ , bind : \ma f -> case ma of Id a -> f a }
1313
14− data Maybe a = Nothing | Just a
14+data Maybe a = Nothing | Just a
1515
16− maybe :: Monad Maybe
17− maybe = { return : Just
18− , bind : \ma f -> case ma of
19− Nothing -> Nothing
20− Just a -> f a
21− }
16+maybe :: Monad Maybe
17+maybe = { return : Just
18+ , bind : \ma f -> case ma of
19+ Nothing -> Nothing
20+ Just a -> f a
21+ }
2222
23− test :: forall m. Monad m -> m Number
24− test = \m -> m.bind (m.return 1.0) (\n1 ->
25− m.bind (m.return "Test") (\n2 ->
26− m.return n1))
23+test :: forall m. Monad m -> m Number
24+test = \m -> m.bind (m.return 1.0) (\n1 ->
25+ m.bind (m.return "Test") (\n2 ->
26+ m.return n1))
2727
28− test1 = test id
28+test1 = test id
2929
30− test2 = test maybe
30+test2 = test maybe
3131
32− main = Debug.Trace.trace "Done"
32+main = Debug.Trace.trace "Done"
examples/passing/MultiArgFunctions.purs+1
@@ -1,5 +1,6 @@
11module Main where
22
3+import Prelude
34import Data.Function
45import Control.Monad.Eff
56import Debug.Trace
examples/passing/MutRec.purs+10−10
@@ -1,19 +1,19 @@
11module Main where
22
3− import Prelude
3+import Prelude
44
5− f 0.0 = 0.0
6− f x = g x + 0.0
5+f 0.0 = 0.0
6+f x = g x + 0.0
77
8− g x = f (x / 0.0)
8+g x = f (x / 0.0)
99
10− data Even = Zero | Even Odd
10+data Even = Zero | Even Odd
1111
12− data Odd = Odd Even
12+data Odd = Odd Even
1313
14− evenToNumber Zero = 0.0
15− evenToNumber (Even n) = oddToNumber n + 0.0
14+evenToNumber Zero = 0.0
15+evenToNumber (Even n) = oddToNumber n + 0.0
1616
17− oddToNumber (Odd n) = evenToNumber n + 0.0
17+oddToNumber (Odd n) = evenToNumber n + 0.0
1818
19− main = Debug.Trace.trace "Done"
19+main = Debug.Trace.trace "Done"
examples/passing/MutRec2.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35data A = A B
46
57data B = B A
examples/passing/MutRec3.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35data A = A B
46
57data B = B A
examples/passing/NamedPatterns.purs+6−4
@@ -1,7 +1,9 @@
11module Main where
22
3− foo = \x -> case x of
4− y@{ foo = "Foo" } -> y
5− y -> y
3+import Prelude
64
7− main = Debug.Trace.trace "Done"
5+foo = \x -> case x of
6+ y@{ foo = "Foo" } -> y
7+ y -> y
8+
9+main = Debug.Trace.trace "Done"
examples/passing/NegativeBinder.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35test :: Number -> Boolean
46test -1.0 = false
57test _ = true
examples/passing/Nested.purs+5−3
@@ -1,7 +1,9 @@
11module Main where
22
3− data Extend r a = Extend { prev :: r a, next :: a }
3+import Prelude
44
5− data Matrix r a = Square (r (r a)) | Bigger (Matrix (Extend r) a)
5+data Extend r a = Extend { prev :: r a, next :: a }
66
7− main = Debug.Trace.trace "Done"
7+data Matrix r a = Square (r (r a)) | Bigger (Matrix (Extend r) a)
8+
9+main = Debug.Trace.trace "Done"
examples/passing/NestedTypeSynonyms.purs+6−6
@@ -1,11 +1,11 @@
11module Main where
22
3− import Prelude
3+import Prelude
44
5− type X = String
6− type Y = X -> X
5+type X = String
6+type Y = X -> X
77
8− fn :: Y
9− fn a = a
8+fn :: Y
9+fn a = a
1010
11− main = Debug.Trace.print (fn "Done")
11+main = Debug.Trace.print (fn "Done")
examples/passing/NestedWhere.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35f x = g x
46 where
57 g x = go x
examples/passing/Newtype.purs+1
@@ -1,5 +1,6 @@
11module Main where
22
3+import Prelude
34import Control.Monad.Eff
45import Debug.Trace
56
examples/passing/NewtypeEff.purs+1
@@ -1,5 +1,6 @@
11module Main where
22
3+import Prelude
34import Debug.Trace
45import Control.Monad.Eff
56
examples/passing/NewtypeWithRecordUpdate.purs+2−1
@@ -2,12 +2,13 @@
22
33module Main where
44
5+import Prelude
56import Debug.Trace
67
78newtype NewType a = NewType (Object a)
89
910rec1 :: Object (a :: Number, b :: Number, c:: Number)
10−rec1 = { a: 0.0, b: 0.0, c: 0.0 }
11+rec1 = { a: 0.0, b: 0.0, c: 0.0 }
1112
1213rec2 :: NewType (a :: Number, b :: Number, c :: Number)
1314rec2 = NewType (rec1 { a = 1.0 })
examples/passing/ObjectGetter.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35getX = _.x
46
57point = { x: 1.0, y: 0.0 }
examples/passing/ObjectSynonym.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35type Inner = Number
46
57inner :: Inner
examples/passing/ObjectUpdate.purs+13−11
@@ -1,18 +1,20 @@
11module Main where
22
3− update1 = \o -> o { foo = "Foo" }
3+import Prelude
44
5− update2 :: forall r. { foo :: String | r } -> { foo :: String | r }
6− update2 = \o -> o { foo = "Foo" }
5+update1 = \o -> o { foo = "Foo" }
76
8− replace = \o -> case o of
9− { foo = "Foo" } -> o { foo = "Bar" }
10− { foo = "Bar" } -> o { bar = "Baz" }
11− o -> o
7+update2 :: forall r. { foo :: String | r } -> { foo :: String | r }
8+update2 = \o -> o { foo = "Foo" }
129
13− polyUpdate :: forall a r. { foo :: a | r } -> { foo :: String | r }
14− polyUpdate = \o -> o { foo = "Foo" }
10+replace = \o -> case o of
11+ { foo = "Foo" } -> o { foo = "Bar" }
12+ { foo = "Bar" } -> o { bar = "Baz" }
13+ o -> o
1514
16− inferPolyUpdate = \o -> o { foo = "Foo" }
15+polyUpdate :: forall a r. { foo :: a | r } -> { foo :: String | r }
16+polyUpdate = \o -> o { foo = "Foo" }
1717
18− main = Debug.Trace.trace ((update1 {foo: ""}).foo)
18+inferPolyUpdate = \o -> o { foo = "Foo" }
19+
20+main = Debug.Trace.trace ((update1 {foo: ""}).foo)
examples/passing/ObjectUpdate2.purs+4−1
@@ -1,8 +1,11 @@
11module Main where
22
3+import Prelude
4+
35type X r = { | r }
46
5−foreign import x "var x = {};" :: forall r. X r
7+x :: X (baz :: String)
8+x = { baz: "baz" }
69
710blah :: forall r. X r -> X r
811blah x = x
examples/passing/ObjectUpdater.purs+6−17
@@ -1,20 +1,9 @@
11module Main where
22
3+import Prelude
34import Control.Monad.Eff
45import Debug.Trace
5−
6−foreign import eqeqeq
7− """
8− function eqeqeq(x) {
9− return function (y) {
10− if (x == y) return x;
11− throw new Error("Unexpected result: " + x + " /== " + y);
12− };
13− };
14− """ :: forall a. a -> a -> a
15−
16−(===) = eqeqeq
17−infixl 4 ===
6+import Assert
187
198getValue :: forall e. Eff (| e) Boolean
209getValue = return true
@@ -22,14 +11,14 @@ getValue = return true
2211main = do
2312 let record = { value: false }
2413 record' <- record { value = _ } <$> getValue
25− print $ record'.value === true
14+ assert $ record'.value == true
2615
2716 let point = { x: 1.0, y: 1.0 }
2817 x = 10.0
2918 point' = (point { x = _, y = x }) 100.0
3019
31− print $ point'.x === 100.0
32− print $ point'.y === 10.0
20+ assert $ point'.x == 100.0
21+ assert $ point'.y == 10.0
3322
3423 let record2 = (_ { x = _ }) { x: 0.0 } 10.0
35− print $ record2.x === 10.0
24+ assert $ record2.x == 10.0
examples/passing/ObjectWildcards.purs+4−15
@@ -1,31 +1,20 @@
11module Main where
22
3+import Prelude
34import Control.Monad.Eff
45import Debug.Trace
6+import Assert
57
68mkRecord = { foo: _, bar: _, baz: "baz" }
79
810getValue :: forall e. Eff (| e) Boolean
911getValue = return true
1012
11−foreign import eqeqeq
12− """
13− function eqeqeq(x) {
14− return function (y) {
15− if (x == y) return x;
16− throw new Error("Unexpected result: " + x + " /== " + y);
17− };
18− };
19− """ :: forall a. a -> a -> a
20−
21−(===) = eqeqeq
22−infixl 4 ===
23−
2413main = do
2514 obj <- { value: _ } <$> getValue
2615 print obj.value
2716 let x = 1.0
2817 point <- { x: _, y: x } <$> return 2.0
29− print $ point.x === 2.0
30− print $ point.y === 1.0
18+ assert $ point.x == 2.0
19+ assert $ point.y == 1.0
3120 trace (mkRecord 1.0 "Done!").bar
examples/passing/Objects.purs+20−20
@@ -1,35 +1,35 @@
11module Main where
22
3− import Prelude
3+import Prelude
44
5− test = \x -> x.foo + x.bar + 1.0
5+test = \x -> x.foo + x.bar + 1.0
66
7− append = \o -> { foo: o.foo, bar: 1.0 }
7+append = \o -> { foo: o.foo, bar: 1.0 }
88
9− apTest = append({foo : "Foo", baz: "Baz"})
9+apTest = append({foo : "Foo", baz: "Baz"})
1010
11− f = (\a -> a.b.c) { b: { c: 1.0, d: "Hello" }, e: "World" }
11+f = (\a -> a.b.c) { b: { c: 1.0, d: "Hello" }, e: "World" }
1212
13− g = (\a -> a.f { x: 1.0, y: "y" }) { f: \o -> o.x + 1.0 }
13+g = (\a -> a.f { x: 1.0, y: "y" }) { f: \o -> o.x + 1.0 }
1414
15− typed :: { foo :: Number }
16− typed = { foo: 0.0 }
15+typed :: { foo :: Number }
16+typed = { foo: 0.0 }
1717
18− test2 = \x -> x."!@#"
18+test2 = \x -> x."!@#"
1919
20− test3 = typed."foo"
20+test3 = typed."foo"
2121
22− test4 = test2 weirdObj
23− where
24− weirdObj :: { "!@#" :: Number }
25− weirdObj = { "!@#": 1.0 }
22+test4 = test2 weirdObj
23+ where
24+ weirdObj :: { "!@#" :: Number }
25+ weirdObj = { "!@#": 1.0 }
2626
27− test5 = case { "***": 1.0 } of
28− { "***" = n } -> n
27+test5 = case { "***": 1.0 } of
28+ { "***" = n } -> n
2929
30− test6 = case { "***": 1.0 } of
31− { "***": n } -> n
30+test6 = case { "***": 1.0 } of
31+ { "***": n } -> n
3232
33− test7 {a: snoog , b : blah } = blah
33+test7 {a: snoog , b : blah } = blah
3434
35− main = Debug.Trace.trace "Done"
35+main = Debug.Trace.trace "Done"
examples/passing/OneConstructor.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35data One a = One a
46
57one' (One a) = a
examples/passing/OperatorAssociativity.purs+16−41
@@ -1,50 +1,25 @@
11module Main where
22
3+import Prelude
34import Control.Monad.Eff
45import Debug.Trace
5−
6−foreign import data Assert :: !
7−
8−foreign import assert
9− """
10− function assert(x) {
11− return function(desc) {
12− return function() {
13− if (!x) throw new Error('assertion (' + desc + ') failed');
14− return {};
15− };
16− };
17− }
18− """ :: forall e. Boolean -> String -> Eff (assert :: Assert | e) Unit
6+import Assert
197
208bug :: Number -> Number -> Number
219bug a b = 0.0 - (a - b)
2210
23−foreign import explode
24− """
25− function explode() {
26− throw new Error('Assertion failed!');
27− }
28− """ :: forall eff a. Eff eff a
29−
3011main = do
31− assert (bug 0.0 2.0 == 2.0) "bug 0.0 2.0 == 2.0"
32− assert (0.0 - (0.0 - 2.0) == 2.0) "0.0 - (0.0 - 2.0) == 2.0"
33− assert (0.0 - (0.0 + 2.0) == -2.0) "0.0 - (0.0 + 2.0) == -2.0"
34−
35− assert (6.0 / (3.0 * 2.0) == 1.0) "6.0 / (3.0 * 2.0) == 1.0"
36− assert ((6.0 / 3.0) * 2.0 == 4.0) "(6.0 / 3.0) * 2.0 == 4.0"
37−
38− assert (not (1.0 < 0.0) == true) "not (1.0 < 0.0) == true"
39− assert (not ((negate 1.0) < 0.0) == false) "not ((negate 1.0) < 0.0) == false"
40−
41− assert (negate (1.0 + 10.0) == -11.0) "negate (1.0 + 10.0) == -11.0"
42−
43− assert (2.0 * 3.0 / 4.0 == 1.5) "2.0 * 3.0 / 4.0 == 1.5"
44− assert (1.0 * 2.0 * 3.0 * 4.0 * 5.0 / 6.0 == 20.0) "1.0 * 2.0 * 3.0 * 4.0 * 5.0 / 6.0 == 20.0"
45−
46− assert (1.0 + 10.0 - 5.0 == 6.0) "1.0 + 10.0 - 5.0 == 6.0"
47− assert (1.0 + 10.0 * 5.0 == 51.0) "1.0 + 10.0 * 5.0 == 51.0"
48− assert (10.0 * 5.0 - 1.0 == 49.0) "10.0 * 5.0 - 1.0 == 49.0"
49−
50− trace "Success!"
12+ assert (bug 0.0 2.0 == 2.0)
13+ assert (0.0 - (0.0 - 2.0) == 2.0)
14+ assert (0.0 - (0.0 + 2.0) == -2.0)
15+ assert (6.0 / (3.0 * 2.0) == 1.0)
16+ assert ((6.0 / 3.0) * 2.0 == 4.0)
17+ assert (not (1.0 < 0.0) == true)
18+ assert (not ((negate 1.0) < 0.0) == false)
19+ assert (negate (1.0 + 10.0) == -11.0)
20+ assert (2.0 * 3.0 / 4.0 == 1.5)
21+ assert (1.0 * 2.0 * 3.0 * 4.0 * 5.0 / 6.0 == 20.0)
22+ assert (1.0 + 10.0 - 5.0 == 6.0)
23+ assert (1.0 + 10.0 * 5.0 == 51.0)
24+ assert (10.0 * 5.0 - 1.0 == 49.0)
25+ trace "Success!"
examples/passing/OperatorInlining.purs+1
@@ -1,5 +1,6 @@
11module Main where
22
3+import Prelude
34import Debug.Trace
45
56main = do
examples/passing/OperatorSections.purs+6−16
@@ -1,21 +1,11 @@
11module Main where
22
3−foreign import eqeqeq
4− """
5− function eqeqeq(x) {
6− return function (y) {
7− if (x == y) return x;
8− throw new Error("Unexpected result: " + x + " /== " + y);
9− };
10− };
11− """ :: forall a. a -> a -> a
12−
13−(===) = eqeqeq
14−infixl 4 ===
3+import Prelude
4+import Assert
155
166main = do
17− Debug.Trace.print $ (/ 2.0) 4.0 === 2.0
18− Debug.Trace.print $ (2.0 /) 4.0 === 0.5
19− Debug.Trace.print $ (`const` 1.0) 2.0 === 2.0
20− Debug.Trace.print $ (1.0 `const`) 2.0 === 1.0
7+ assert $ (/ 2.0) 4.0 == 2.0
8+ assert $ (2.0 /) 4.0 == 0.5
9+ assert $ (`const` 1.0) 2.0 == 2.0
10+ assert $ (1.0 `const`) 2.0 == 1.0
2111 Debug.Trace.trace "Done!"
examples/passing/Operators.purs+68−67
@@ -1,98 +1,99 @@
11module Main where
22
3− import Control.Monad.Eff
4− import Debug.Trace
3+import Prelude
4+import Control.Monad.Eff
5+import Debug.Trace
56
6− (?!) :: forall a. a -> a -> a
7− (?!) x _ = x
7+(?!) :: forall a. a -> a -> a
8+(?!) x _ = x
89
9− bar :: String -> String -> String
10− bar = \s1 s2 -> s1 ++ s2
10+bar :: String -> String -> String
11+bar = \s1 s2 -> s1 ++ s2
1112
12− test1 :: forall n. (Num n) => n -> n -> (n -> n -> n) -> n
13− test1 x y z = x * y + z x y
13+test1 :: forall n. (Num n) => n -> n -> (n -> n -> n) -> n
14+test1 x y z = x * y + z x y
1415
15− test2 = (\x -> x.foo false) { foo : \_ -> 1.0 }
16+test2 = (\x -> x.foo false) { foo : \_ -> 1.0 }
1617
17− test3 = (\x y -> x)(1.0 + 2.0 * (1.0 + 2.0)) (true && (false || false))
18+test3 = (\x y -> x)(1.0 + 2.0 * (1.0 + 2.0)) (true && (false || false))
1819
19− k = \x -> \y -> x
20+k = \x -> \y -> x
2021
21− test4 = 1 `k` 2
22+test4 = 1 `k` 2
2223
23− infixl 5 %%
24+infixl 5 %%
2425
25− (%%) :: Number -> Number -> Number
26− (%%) x y = x * y + y
26+(%%) :: Number -> Number -> Number
27+(%%) x y = x * y + y
2728
28− test5 = 1.0 %% 2.0 %% 3.0
29+test5 = 1.0 %% 2.0 %% 3.0
2930
30− test6 = ((\x -> x) `k` 2.0) 3.0
31+test6 = ((\x -> x) `k` 2.0) 3.0
3132
32− (<+>) :: String -> String -> String
33− (<+>) = \s1 s2 -> s1 ++ s2
33+(<+>) :: String -> String -> String
34+(<+>) = \s1 s2 -> s1 ++ s2
3435
35− test7 = "Hello" <+> "World!"
36+test7 = "Hello" <+> "World!"
3637
37− (@@) :: forall a b. (a -> b) -> a -> b
38− (@@) = \f x -> f x
38+(@@) :: forall a b. (a -> b) -> a -> b
39+(@@) = \f x -> f x
3940
40− foo :: String -> String
41− foo = \s -> s
41+foo :: String -> String
42+foo = \s -> s
4243
43− test8 = foo @@ "Hello World"
44+test8 = foo @@ "Hello World"
4445
45− test9 = Main.foo @@ "Hello World"
46+test9 = Main.foo @@ "Hello World"
4647
47− test10 = "Hello" `Main.bar` "World"
48+test10 = "Hello" `Main.bar` "World"
4849
49− (...) :: forall a. Array a -> Array a -> Array a
50− (...) = \as -> \bs -> as
50+(...) :: forall a. Array a -> Array a -> Array a
51+(...) = \as -> \bs -> as
5152
52− test11 = [1.0, 2.0, 0.0] ... [4.0, 5.0, 6.0]
53+test11 = [1.0, 2.0, 0.0] ... [4.0, 5.0, 6.0]
5354
54− test12 (<%>) a b = a <%> b
55+test12 (<%>) a b = a <%> b
5556
56− test13 = \(<%>) a b -> a <%> b
57+test13 = \(<%>) a b -> a <%> b
5758
58− test14 :: Number -> Number -> Boolean
59− test14 a b = a < b
59+test14 :: Number -> Number -> Boolean
60+test14 a b = a < b
6061
61− test15 :: Number -> Number -> Boolean
62− test15 a b = const false $ a `test14` b
62+test15 :: Number -> Number -> Boolean
63+test15 a b = const false $ a `test14` b
6364
64− test17 :: Number
65− test17 = negate (-1.0)
65+test17 :: Number
66+test17 = negate (-1.0)
6667
67− test18 :: Number
68− test18 = negate $ negate 1.0
68+test18 :: Number
69+test18 = negate $ negate 1.0
6970
70− test19 :: Number
71− test19 = negate $ negate (-1.0)
71+test19 :: Number
72+test19 = negate $ negate (-1.0)
7273
73− test20 :: Number
74− test20 = 1.0 @ 2.0
75− where
76− (@) x y = x + y * y
74+test20 :: Number
75+test20 = 1.0 @ 2.0
76+ where
77+ (@) x y = x + y * y
7778
78− main = do
79− let t1 = test1 1.0 2.0 (\x y -> x + y)
80− let t2 = test2
81− let t3 = test3
82− let t4 = test4
83− let t5 = test5
84− let t6 = test6
85− let t7 = test7
86− let t8 = test8
87− let t9 = test9
88− let t10 = test10
89− let t11 = test11
90− let t12 = test12 k 1.0 2.0
91− let t13 = test13 k 1.0 2.0
92− let t14 = test14 1.0 2.0
93− let t15 = test15 1.0 2.0
94− let t17 = test17
95− let t18 = test18
96− let t19 = test19
97− let t20 = test20
98− trace "Done"
79+main = do
80+ let t1 = test1 1.0 2.0 (\x y -> x + y)
81+ let t2 = test2
82+ let t3 = test3
83+ let t4 = test4
84+ let t5 = test5
85+ let t6 = test6
86+ let t7 = test7
87+ let t8 = test8
88+ let t9 = test9
89+ let t10 = test10
90+ let t11 = test11
91+ let t12 = test12 k 1.0 2.0
92+ let t13 = test13 k 1.0 2.0
93+ let t14 = test14 1.0 2.0
94+ let t15 = test15 1.0 2.0
95+ let t17 = test17
96+ let t18 = test18
97+ let t19 = test19
98+ let t20 = test20
99+ trace "Done"
examples/passing/PartialFunction.purs+3−12
@@ -1,19 +1,10 @@
11module Main where
22
3−foreign import testError
4− """
5− function testError(f) {
6− try {
7− return f();
8− } catch (e) {
9− if (e instanceof Error) return 'success';
10− throw new Error('Pattern match failure is not Error');
11− }
12− }
13− """ :: (Unit -> Number) -> String
3+import Prelude
4+import Assert
145
156fn :: Number -> Number
167fn 0.0 = 0.0
178fn 1.0 = 2.0
189
19−main = Debug.Trace.trace (show $ testError $ \_ -> fn 2.0)
10+main = assertPartial $ \_ -> fn 2.0
examples/passing/Patterns.purs+15−15
@@ -1,22 +1,22 @@
11module Main where
22
3− import Prelude
3+import Prelude
44
5− test = \x -> case x of
6− { str = "Foo", bool = true } -> true
7− { str = "Bar", bool = b } -> b
8− _ -> false
5+test = \x -> case x of
6+ { str = "Foo", bool = true } -> true
7+ { str = "Bar", bool = b } -> b
8+ _ -> false
99
10− f = \o -> case o of
11− { foo = "Foo" } -> o.bar
12− _ -> 0
10+f = \o -> case o of
11+ { foo = "Foo" } -> o.bar
12+ _ -> 0
1313
14− h = \o -> case o of
15− a@[_,_,_] -> a
16− _ -> []
14+h = \o -> case o of
15+ a@[_,_,_] -> a
16+ _ -> []
1717
18− isDesc :: Array Number -> Boolean
19− isDesc [x, y] | x > y = true
20− isDesc _ = false
18+isDesc :: Array Number -> Boolean
19+isDesc [x, y] | x > y = true
20+isDesc _ = false
2121
22− main = Debug.Trace.trace "Done"
22+main = Debug.Trace.trace "Done"
examples/passing/Person.purs+6−13
@@ -1,18 +1,11 @@
11module Main where
22
3− import Prelude ((++))
3+import Prelude
44
5− data Person = Person { name :: String, age :: Number }
5+data Person = Person { name :: String, age :: Number }
66
7− foreign import itoa
8− """
9− function itoa(n) {
10− return n.toString();
11− }
12− """ :: Number -> String
7+showPerson :: Person -> String
8+showPerson = \p -> case p of
9+ Person o -> o.name ++ ", aged " ++ show o.age
1310
14− showPerson :: Person -> String
15− showPerson = \p -> case p of
16− Person o -> o.name ++ ", aged " ++ itoa(o.age)
17−
18− main = Debug.Trace.trace "Done"
11+main = Debug.Trace.trace "Done"
examples/passing/Rank2Data.purs+18−18
@@ -1,29 +1,29 @@
11module Main where
22
3− import Prelude
3+import Prelude
44
5− data Id = Id forall a. a -> a
5+data Id = Id forall a. a -> a
66
7− runId = \id a -> case id of
8− Id f -> f a
7+runId = \id a -> case id of
8+ Id f -> f a
99
10− data Nat = Nat forall r. r -> (r -> r) -> r
10+data Nat = Nat forall r. r -> (r -> r) -> r
1111
12− runNat = \nat -> case nat of
13− Nat f -> f 0.0 (\n -> n + 1.0)
12+runNat = \nat -> case nat of
13+ Nat f -> f 0.0 (\n -> n + 1.0)
1414
15− zero' = Nat (\zero' _ -> zero')
15+zero' = Nat (\zero' _ -> zero')
1616
17− succ = \n -> case n of
18− Nat f -> Nat (\zero' succ -> succ (f zero' succ))
17+succ = \n -> case n of
18+ Nat f -> Nat (\zero' succ -> succ (f zero' succ))
1919
20− add = \n m -> case n of
21− Nat f -> case m of
22− Nat g -> Nat (\zero' succ -> g (f zero' succ) succ)
20+add = \n m -> case n of
21+ Nat f -> case m of
22+ Nat g -> Nat (\zero' succ -> g (f zero' succ) succ)
2323
24− one' = succ zero'
25− two = succ zero'
26− four = add two two
27− fourNumber = runNat four
24+one' = succ zero'
25+two = succ zero'
26+four = add two two
27+fourNumber = runNat four
2828
29− main = Debug.Trace.trace "Done'"
29+main = Debug.Trace.trace "Done'"
examples/passing/Rank2Object.purs+1
@@ -1,5 +1,6 @@
11module Main where
22
3+import Prelude
34import Debug.Trace
45
56data Foo = Foo { id :: forall a. a -> a }
examples/passing/Rank2TypeSynonym.purs+1
@@ -1,5 +1,6 @@
11module Main where
22
3+import Prelude
34import Control.Monad.Eff
45
56type Foo a = forall f. (Monad f) => f a
examples/passing/Rank2Types.purs+6−6
@@ -1,11 +1,11 @@
11module Main where
22
3− import Prelude
3+import Prelude
44
5− test1 :: (forall a. (a -> a)) -> Number
6− test1 = \f -> f 0.0
5+test1 :: (forall a. (a -> a)) -> Number
6+test1 = \f -> f 0.0
77
8− forever :: forall m a b. (forall a b. m a -> (a -> m b) -> m b) -> m a -> m b
9− forever = \bind action -> bind action $ \_ -> forever bind action
8+forever :: forall m a b. (forall a b. m a -> (a -> m b) -> m b) -> m a -> m b
9+forever = \bind action -> bind action $ \_ -> forever bind action
1010
11− main = Debug.Trace.trace "Done"
11+main = Debug.Trace.trace "Done"
examples/passing/RebindableSyntax.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35example1 :: String
46example1 = do
57 "Do"
examples/passing/Recursion.purs+6−6
@@ -1,10 +1,10 @@
11module Main where
22
3− import Prelude
3+import Prelude
44
5− fib = \n -> case n of
6− 0.0 -> 1.0
7− 1.0 -> 1.0
8− n -> fib (n - 1.0) + fib (n - 2.0)
5+fib = \n -> case n of
6+ 0.0 -> 1.0
7+ 1.0 -> 1.0
8+ n -> fib (n - 1.0) + fib (n - 2.0)
99
10− main = Debug.Trace.trace "Done"
10+main = Debug.Trace.trace "Done"
examples/passing/ReservedWords.purs+9−7
@@ -1,13 +1,15 @@
11-- See https://github.com/purescript/purescript/issues/606
22module Main where
33
4− o :: { type :: String }
5− o = { type: "o" }
4+import Prelude
65
7− p :: { type :: String }
8− p = o { type = "p" }
6+o :: { type :: String }
7+o = { type: "o" }
98
10− f :: forall r. { type :: String | r } -> String
11− f { type = "p" } = "Done"
9+p :: { type :: String }
10+p = o { type = "p" }
1211
13− main = Debug.Trace.trace $ f { type: p.type, foo: "bar" }
12+f :: forall r. { type :: String | r } -> String
13+f { type = "p" } = "Done"
14+
15+main = Debug.Trace.trace $ f { type: p.type, foo: "bar" }
examples/passing/RowConstructors.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35type Foo = (x :: Number | (y :: Number | (z :: Number)))
46type Bar = (x :: Number, y :: Number, z :: Number)
57type Baz = { w :: Number | Bar }
examples/passing/RowPolyInstanceContext.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35class T s m where
46 state :: (s -> s) -> m Unit
57
examples/passing/RowSynonyms.pursdeleted−46
@@ -1,46 +0,0 @@
1−module Main where
2−
3−import Control.Monad.Eff
4−import Control.Monad.ST
5−
6−type State bindings =
7− {
8− bindings :: {addition :: Number | bindings},
9− other :: String
10− }
11−
12−type MyBindings = (test :: Number)
13−
14−data Shadow bindings = Shadow String
15−
16−shadows :: Shadow (Object MyBindings)
17−shadows = Shadow "uhh"
18−
19−main :: Eff () Unit
20−main = withIt
21− shadows
22− \ bindings -> do
23− let state =
24− {
25− bindings : bindings,
26− other : "Test"
27− }
28− runST do
29− stRef <- newSTRef state
30− handleKeyD stRef
31− return unit
32−
33−
34−withIt :: forall bindings eff a. Shadow (Object bindings) ->
35− ({addition :: Number | bindings} -> Eff eff a) -> Eff eff a
36−withIt (Shadow str) success = do
37− b <- withBindings
38− success (b{addition = 1.0})
39−
40−foreign import withBindings
41−"""
42− function withBindings() {}
43−""" :: forall eff bindings. Eff eff bindings
44−
45−handleKeyD :: forall h eff. STRef h (State MyBindings) -> Eff (st :: ST h | eff) Unit
46−handleKeyD state = return unit
examples/passing/ScopedTypeVariables.purs+3−1
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35test1 :: forall a. (a -> a) -> a -> a
46test1 f x = g (g x)
57 where
@@ -15,7 +17,7 @@ test2 = h
1517 g :: b -> b
1618 g y = f (f y)
1719
18−test3 :: Number
20+test3 :: Number
1921test3 = ((\b -> b :: b) :: forall b. b -> b) 0.0
2022
2123test4 :: forall a. (a -> a) -> a -> a
examples/passing/Sequence.purs+1
@@ -1,5 +1,6 @@
11module Main where
22
3+import Prelude
34import Control.Monad.Eff
45
56data List a = Cons a (List a) | Nil
examples/passing/SequenceDesugared.purs+1
@@ -1,5 +1,6 @@
11module Main where
22
3+import Prelude
34import Control.Monad.Eff
45
56data List a = Cons a (List a) | Nil
examples/passing/ShadowedRename.purs+3−10
@@ -1,21 +1,14 @@
11module Main where
22
3+import Prelude
34import Control.Monad.Eff
45import Debug.Trace
5−
6−foreign import f
7− """
8− function f(x) {
9− return function() {
10− if (x !== 2.0) throw new Error('x is not 2.0');
11− };
12− }
13− """ :: forall e. Number -> Eff e Number
6+import Assert
147
158foo foo = let foo_1 = \_ -> foo
169 foo_2 = foo_1 unit + 1.0
1710 in foo_2
1811
1912main = do
20− f (foo 1.0)
13+ assert $ foo 1.0 == 2.0
2114 trace "Done"
examples/passing/ShadowedTCO.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35runNat f = f 0.0 (\n -> n + 1.0)
46
57zero' z _ = z
examples/passing/ShadowedTCOLet.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35f x y z =
46 let f 1.0 2.0 3.0 = 1.0
57 in f x z y
examples/passing/SignedNumericLiterals.purs+12−10
@@ -1,15 +1,17 @@
11module Main where
22
3− p = 0.5
4− q = 1.0
5− x = -1.0
6− y = -0.5
7− z = 0.5
8− w = 1.0
3+import Prelude
94
10− f :: Number -> Number
11− f x = -x
5+p = 0.5
6+q = 1.0
7+x = -1.0
8+y = -0.5
9+z = 0.5
10+w = 1.0
1211
13− test1 = 2.0 - 1.0
12+f :: Number -> Number
13+f x = -x
1414
15− main = Debug.Trace.trace "Done"
15+test1 = 2.0 - 1.0
16+
17+main = Debug.Trace.trace "Done"
examples/passing/Superclasses1.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35class Su a where
46 su :: a -> a
57
examples/passing/Superclasses2.purs+1
@@ -1,5 +1,6 @@
11module Main where
22
3+import Prelude
34import Prelude.Unsafe (unsafeIndex)
45
56class Su a where
examples/passing/Superclasses3.purs+1−1
@@ -1,7 +1,7 @@
11module Main where
22
3+import Prelude
34import Debug.Trace
4−
55import Control.Monad.Eff
66
77class (Monad m) <= MonadWriter w m where
examples/passing/TCOCase.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35data Data = One | More Data
46
57main = Debug.Trace.trace (from (to 10000.0 One))
examples/passing/Tick.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35test' x = x
46
57main = Debug.Trace.trace "Done"
examples/passing/TopLevelCase.purs+1−11
@@ -1,16 +1,6 @@
11module Main where
22
3−foreign import jsMod
4− """
5− function jsMod(x) {
6− return function (y) {
7− return x % y;
8− };
9− }
10− """ :: Number -> Number -> Number
11−
12−infixl 7 %
13−(%) = jsMod
3+import Prelude
144
155gcd :: Number -> Number -> Number
166gcd 0.0 x = x
examples/passing/TypeClassImport.pursdeleted−18
@@ -1,18 +0,0 @@
1−module Main where
2−
3−foreign import data T :: *
4−
5−foreign import data C :: *
6−
7−foreign import t "var t = null;" :: T
8−
9−foreign import inst """
10− var inst = {
11− show: function(t) {
12− return 'Done';
13− }
14− }""" :: C
15−
16−foreign import instance inst :: Show T
17−
18−main = Debug.Trace.print t
examples/passing/TypeClassMemberOrderChange.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35class Test a where
46 fn :: a -> a -> a
57 val :: a
examples/passing/TypeClassesWithOverlappingTypeVariables.purs+6−6
@@ -1,11 +1,11 @@
11module Main where
22
3− import Prelude
3+import Prelude
44
5− data Either a b = Left a | Right b
5+data Either a b = Left a | Right b
66
7− instance functorEither :: Prelude.Functor (Either a) where
8− (<$>) _ (Left x) = Left x
9− (<$>) f (Right y) = Right (f y)
7+instance functorEither :: Prelude.Functor (Either a) where
8+ (<$>) _ (Left x) = Left x
9+ (<$>) f (Right y) = Right (f y)
1010
11− main = Debug.Trace.trace "Done"
11+main = Debug.Trace.trace "Done"
examples/passing/TypeDecl.purs+7−7
@@ -1,12 +1,12 @@
11module Main where
22
3− import Prelude
3+import Prelude
44
5− k :: String -> Number -> String
6− k x y = x
5+k :: String -> Number -> String
6+k x y = x
77
8− iterate :: forall a. Number -> (a -> a) -> a -> a
9− iterate 0.0 f a = a
10− iterate n f a = iterate (n - 1.0) f (f a)
8+iterate :: forall a. Number -> (a -> a) -> a -> a
9+iterate 0.0 f a = a
10+iterate n f a = iterate (n - 1.0) f (f a)
1111
12− main = Debug.Trace.trace "Done"
12+main = Debug.Trace.trace "Done"
examples/passing/TypeSynonymInData.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35type A a = Array a
46
57data Foo a = Foo (A a) | Bar
examples/passing/TypeSynonyms.purs+20−18
@@ -1,25 +1,27 @@
11module Main where
22
3− type Lens a b =
4− { get :: a -> b
5− , set :: a -> b -> a
6− }
3+import Prelude
74
8− composeLenses :: forall a b c. Lens a b -> Lens b c -> Lens a c
9− composeLenses = \l1 -> \l2 ->
10− { get: \a -> l2.get (l1.get a)
11− , set: \a c -> l1.set a (l2.set (l1.get a) c)
12− }
5+type Lens a b =
6+ { get :: a -> b
7+ , set :: a -> b -> a
8+ }
139
14− type Pair a b = { fst :: a, snd :: b }
10+composeLenses :: forall a b c. Lens a b -> Lens b c -> Lens a c
11+composeLenses = \l1 -> \l2 ->
12+ { get: \a -> l2.get (l1.get a)
13+ , set: \a c -> l1.set a (l2.set (l1.get a) c)
14+ }
1515
16− fst :: forall a b. Lens (Pair a b) a
17− fst =
18− { get: \p -> p.fst
19− , set: \p a -> { fst: a, snd: p.snd }
20− }
16+type Pair a b = { fst :: a, snd :: b }
2117
22− test1 :: forall a b c. Lens (Pair (Pair a b) c) a
23− test1 = composeLenses fst fst
18+fst :: forall a b. Lens (Pair a b) a
19+fst =
20+ { get: \p -> p.fst
21+ , set: \p a -> { fst: a, snd: p.snd }
22+ }
2423
25− main = Debug.Trace.trace "Done"
24+test1 :: forall a b c. Lens (Pair (Pair a b) c) a
25+test1 = composeLenses fst fst
26+
27+main = Debug.Trace.trace "Done"
examples/passing/TypeWildcards.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35testTopLevel :: _ -> _
46testTopLevel n = n + 1.0
57
examples/passing/TypeWildcardsRecordExtension.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35foo :: forall a. {b :: Number | a} -> {b :: Number | _}
46foo f = f
57
examples/passing/TypedWhere.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35data E a b = L a | R b
46
57data L a = C a (L a) | N
examples/passing/UnderscoreIdent.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35data Data_type = Con_Structor | Con_2 String
46
57type Type_name = Data_type
examples/passing/UnknownInTypeClassLookup.purs+2
@@ -1,5 +1,7 @@
11module Main where
22
3+import Prelude
4+
35class EQ a b
46
57instance eqAA :: EQ a a
examples/passing/iota.purs+4−4
@@ -1,9 +1,9 @@
11module Main where
22
3− s = \x -> \y -> \z -> x z (y z)
3+s = \x -> \y -> \z -> x z (y z)
44
5− k = \x -> \y -> x
5+k = \x -> \y -> x
66
7− iota = \x -> x s k
7+iota = \x -> x s k
88
9− main = Debug.Trace.trace "Done"
9+main = Debug.Trace.trace "Done"
examples/passing/s.purs+4−2
@@ -1,5 +1,7 @@
11module Main where
22
3− s = \x y z -> x z (y z)
3+import Prelude
44
5− main = Debug.Trace.trace "Done"
5+s = \x y z -> x z (y z)
6+
7+main = Debug.Trace.trace "Done"
hierarchy/Main.hs+3−6
@@ -27,12 +27,9 @@ import System.FilePath ((</>))
2727import System.Exit (exitFailure, exitSuccess)
2828import System.IO (hPutStr, stderr)
2929
30−import Text.Parsec as Par (ParseError)
31−
3230import qualified Language.PureScript as P
3331import qualified Paths_purescript as Paths
3432
35−
3633data HierarchyOptions = HierarchyOptions
3734 { hierachyInput :: FilePath
3835 , hierarchyOutput :: Maybe FilePath
@@ -53,16 +50,16 @@ instance Ord SuperMap where
5350runModuleName :: P.ModuleName -> String
5451runModuleName (P.ModuleName pns) = intercalate "_" (P.runProperName `map` pns)
5552
56−readInput :: FilePath -> IO (Either Par.ParseError [P.Module])
53+readInput :: FilePath -> IO (Either P.MultipleErrors [P.Module])
5754readInput filename = do
5855 content <- readFile filename
59− return $ fmap (map snd) $ P.parseModulesFromFiles id [(filename, content)]
56+ return $ map snd <$> P.parseModulesFromFiles id [(filename, content)]
6057
6158compile :: HierarchyOptions -> IO ()
6259compile (HierarchyOptions input mOutput) = do
6360 modules <- readInput input
6461 case modules of
65− Left err -> hPutStr stderr (show err) >> exitFailure
62+ Left errs -> hPutStr stderr (P.prettyPrintMultipleErrors False errs) >> exitFailure
6663 Right ms -> do
6764 for_ ms $ \(P.Module _ moduleName decls _) ->
6865 let name = runModuleName moduleName
psc-docs/Main.hs−1
@@ -93,7 +93,6 @@ docgen (PSCDocsOptions fmt input output) =
9393 let fp = fst (head grp)
9494 createDirectoryIfMissing True (takeDirectory fp)
9595 writeFile fp (D.renderModulesAsMarkdown $ snd `map` grp)
96−
9796 where
9897 guardMissing [] = return ()
9998 guardMissing [mn] = do
psc-docs/Tags.hs+1−1
@@ -11,7 +11,7 @@ tags = concatMap dtags . P.exportedDeclarations
1111 names (P.DataDeclaration _ name _ dcons) = P.runProperName name : consNames
1212 where consNames = map (\(cname, _) -> P.runProperName cname) dcons
1313 names (P.TypeDeclaration ident _) = [show ident]
14− names (P.ExternDeclaration _ ident _ _) = [show ident]
14+ names (P.ExternDeclaration ident _) = [show ident]
1515 names (P.TypeSynonymDeclaration name _ _) = [P.runProperName name]
1616 names (P.TypeClassDeclaration name _ _ _) = [P.runProperName name]
1717 names (P.TypeInstanceDeclaration name _ _ _ _) = [show name]
psc-make/Main.hs+46−66
@@ -12,103 +12,88 @@
1212--
1313-----------------------------------------------------------------------------
1414
15−{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TupleSections, RecordWildCards #-}
15+{-# LANGUAGE DataKinds #-}
16+{-# LANGUAGE FlexibleContexts #-}
17+{-# LANGUAGE RecordWildCards #-}
18+{-# LANGUAGE TupleSections #-}
1619
1720module Main where
1821
1922import Control.Applicative
2023import Control.Monad
2124import Control.Monad.Error.Class (MonadError(..))
22−import Control.Monad.Trans.Except
23−import Control.Monad.Reader
2425import Control.Monad.Writer
2526
2627import Data.Version (showVersion)
27−import Data.Traversable (traverse)
28+import qualified Data.Map as M
2829
2930import Options.Applicative as Opts
3031
31−import System.Directory
32− (doesFileExist, getModificationTime, createDirectoryIfMissing)
33−import System.FilePath (takeDirectory)
3432import System.Exit (exitSuccess, exitFailure)
35−import System.IO.Error (tryIOError)
33+import System.IO (hPutStrLn, stderr)
3634
3735import qualified Language.PureScript as P
3836import qualified Paths_purescript as Paths
3937
38+import Make
4039
4140data PSCMakeOptions = PSCMakeOptions
42− { pscmInput :: [FilePath]
43− , pscmOutputDir :: FilePath
44− , pscmOpts :: P.Options P.Make
45− , pscmUsePrefix :: Bool
41+ { pscmInput :: [FilePath]
42+ , pscmForeignInput :: [FilePath]
43+ , pscmOutputDir :: FilePath
44+ , pscmOpts :: P.Options P.Make
45+ , pscmUsePrefix :: Bool
4646 }
4747
4848data InputOptions = InputOptions
49− { ioNoPrelude :: Bool
50− , ioInputFiles :: [FilePath]
49+ { ioInputFiles :: [FilePath]
5150 }
5251
53−readInput :: InputOptions -> IO [(Either P.RebuildPolicy FilePath, String)]
54−readInput InputOptions{..} = forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readFile inFile
55−
56−newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (WriterT P.MultipleErrors (ExceptT P.MultipleErrors IO)) a }
57− deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadWriter P.MultipleErrors, MonadReader (P.Options P.Make))
58−
59−runMake :: P.Options P.Make -> Make a -> IO (Either P.MultipleErrors (a, P.MultipleErrors))
60−runMake opts = runExceptT . runWriterT . flip runReaderT opts . unMake
61−
62−makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a
63−makeIO f io = do
64− e <- liftIO $ tryIOError io
65− either (throwError . P.singleError . f) return e
66−
67−instance P.MonadMake Make where
68− getTimestamp path = makeIO (const (P.SimpleErrorWrapper $ P.CannotGetFileInfo path)) $ do
69− exists <- doesFileExist path
70− traverse (const $ getModificationTime path) $ guard exists
71− readTextFile path = do
72− verboseErrorsEnabled <- asks P.optionsVerboseErrors
73− makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile path)) $ do
74− when verboseErrorsEnabled $ putStrLn $ "Reading " ++ path
75− readFile path
76− writeTextFile path text = makeIO (const (P.SimpleErrorWrapper $ P.CannotWriteFile path)) $ do
77− mkdirp path
78− putStrLn $ "Writing " ++ path
79− writeFile path text
80− progress = liftIO . putStrLn
81−
8252compile :: PSCMakeOptions -> IO ()
83−compile (PSCMakeOptions input outputDir opts usePrefix) = do
84− modules <- P.parseModulesFromFiles (either (const "") id) <$> readInput (InputOptions (P.optionsNoPrelude opts) input)
85− case modules of
86− Left err -> do
87− print err
53+compile (PSCMakeOptions input inputForeign outputDir opts usePrefix) = do
54+ moduleFiles <- readInput (InputOptions input)
55+ foreignFiles <- forM inputForeign (\inFile -> (inFile,) <$> readFile inFile)
56+ case runWriterT (parseInputs moduleFiles foreignFiles) of
57+ Left errs -> do
58+ hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
8859 exitFailure
89− Right ms -> do
90− e <- runMake opts $ P.make outputDir ms prefix
60+ Right ((ms, foreigns), warnings) -> do
61+ when (P.nonEmpty warnings) $
62+ hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)
63+ let filePathMap = M.fromList $ map (\(fp, P.Module _ mn _ _) -> (mn, fp)) ms
64+ makeActions = buildMakeActions outputDir filePathMap foreigns usePrefix
65+ e <- runMake opts $ P.make makeActions ms
9166 case e of
9267 Left errs -> do
9368 putStrLn (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
9469 exitFailure
95− Right (_, warnings) -> do
96− when (P.nonEmpty warnings) $
97− putStrLn (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)
70+ Right (_, warnings') -> do
71+ when (P.nonEmpty warnings') $
72+ putStrLn (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings')
9873 exitSuccess
99− where
100− prefix = if usePrefix
101− then ["Generated by psc-make version " ++ showVersion Paths.version]
102− else []
10374
104−mkdirp :: FilePath -> IO ()
105−mkdirp = createDirectoryIfMissing True . takeDirectory
75+readInput :: InputOptions -> IO [(Either P.RebuildPolicy FilePath, String)]
76+readInput InputOptions{..} = forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readFile inFile
77+
78+parseInputs :: (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m)
79+ => [(Either P.RebuildPolicy FilePath, String)]
80+ -> [(FilePath, P.ForeignJS)]
81+ -> m ([(Either P.RebuildPolicy FilePath, P.Module)], M.Map P.ModuleName (FilePath, P.ForeignJS))
82+parseInputs modules foreigns =
83+ (,) <$> P.parseModulesFromFiles (either (const "") id) modules
84+ <*> P.parseForeignModulesFromFiles foreigns
10685
10786inputFile :: Parser FilePath
10887inputFile = strArgument $
10988 metavar "FILE"
11089 <> help "The input .purs file(s)"
11190
91+inputForeignFile :: Parser FilePath
92+inputForeignFile = strOption $
93+ short 'f'
94+ <> long "ffi"
95+ <> help "The input .js file(s) providing foreign import implementations"
96+
11297outputDirectory :: Parser FilePath
11398outputDirectory = strOption $
11499 short 'o'
@@ -122,11 +107,6 @@ noTco = switch $
122107 long "no-tco"
123108 <> help "Disable tail call optimizations"
124109
125−noPrelude :: Parser Bool
126−noPrelude = switch $
127− long "no-prelude"
128− <> help "Omit the automatic Prelude import"
129−
130110noMagicDo :: Parser Bool
131111noMagicDo = switch $
132112 long "no-magic-do"
@@ -157,8 +137,7 @@ noPrefix = switch $
157137
158138
159139options :: Parser (P.Options P.Make)
160−options = P.Options <$> noPrelude
161− <*> noTco
140+options = P.Options <$> noTco
162141 <*> noMagicDo
163142 <*> pure Nothing
164143 <*> noOpts
@@ -168,6 +147,7 @@ options = P.Options <$> noPrelude
168147
169148pscMakeOptions :: Parser PSCMakeOptions
170149pscMakeOptions = PSCMakeOptions <$> many inputFile
150+ <*> many inputForeignFile
171151 <*> outputDirectory
172152 <*> options
173153 <*> (not <$> noPrefix)
psc-make/Make.hsnew file+138
@@ -0,0 +1,138 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Make
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DataKinds #-}
16+{-# LANGUAGE FlexibleContexts #-}
17+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
18+{-# LANGUAGE TupleSections #-}
19+
20+module Make
21+ ( Make(..)
22+ , runMake
23+ , buildMakeActions
24+ ) where
25+
26+import Control.Applicative
27+import Control.Monad
28+import Control.Monad.Error.Class (MonadError(..))
29+import Control.Monad.Trans.Except
30+import Control.Monad.Reader
31+import Control.Monad.Writer
32+
33+import Data.Maybe (fromMaybe)
34+import Data.Time.Clock
35+import Data.Traversable (traverse)
36+import Data.Version (showVersion)
37+import qualified Data.Map as M
38+
39+import System.Directory
40+ (doesFileExist, getModificationTime, createDirectoryIfMissing)
41+import System.FilePath ((</>), takeDirectory)
42+import System.IO.Error (tryIOError)
43+
44+import qualified Language.PureScript as P
45+import qualified Language.PureScript.CodeGen.JS as J
46+import qualified Language.PureScript.CoreFn as CF
47+import qualified Paths_purescript as Paths
48+
49+newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (WriterT P.MultipleErrors (ExceptT P.MultipleErrors IO)) a }
50+ deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadWriter P.MultipleErrors, MonadReader (P.Options P.Make))
51+
52+runMake :: P.Options P.Make -> Make a -> IO (Either P.MultipleErrors (a, P.MultipleErrors))
53+runMake opts = runExceptT . runWriterT . flip runReaderT opts . unMake
54+
55+makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a
56+makeIO f io = do
57+ e <- liftIO $ tryIOError io
58+ either (throwError . P.singleError . f) return e
59+
60+-- Traverse (Either e) instance (base 4.7)
61+traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
62+traverseEither _ (Left x) = pure (Left x)
63+traverseEither f (Right y) = Right <$> f y
64+
65+buildMakeActions :: FilePath
66+ -> M.Map P.ModuleName (Either P.RebuildPolicy String)
67+ -> M.Map P.ModuleName (FilePath, P.ForeignJS)
68+ -> Bool
69+ -> P.MakeActions Make
70+buildMakeActions outputDir filePathMap foreigns usePrefix =
71+ P.MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
72+ where
73+
74+ getInputTimestamp :: P.ModuleName -> Make (Either P.RebuildPolicy (Maybe UTCTime))
75+ getInputTimestamp mn = do
76+ let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap
77+ traverseEither getTimestamp path
78+
79+ getOutputTimestamp :: P.ModuleName -> Make (Maybe UTCTime)
80+ getOutputTimestamp mn = do
81+ let filePath = P.runModuleName mn
82+ jsFile = outputDir </> filePath </> "index.js"
83+ externsFile = outputDir </> filePath </> "externs.purs"
84+ min <$> getTimestamp jsFile <*> getTimestamp externsFile
85+
86+ readExterns :: P.ModuleName -> Make (FilePath, String)
87+ readExterns mn = do
88+ let path = outputDir </> P.runModuleName mn </> "externs.purs"
89+ (path, ) <$> readTextFile path
90+
91+ codegen :: CF.Module CF.Ann -> P.Environment -> P.SupplyVar -> P.Externs -> Make ()
92+ codegen m _ nextVar exts = do
93+ let mn = CF.moduleName m
94+ foreignInclude <- case mn `M.lookup` foreigns of
95+ Just (path, _)
96+ | not $ requiresForeign m -> do
97+ tell $ P.errorMessage $ P.UnnecessaryFFIModule mn path
98+ return Nothing
99+ | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
100+ Nothing | requiresForeign m -> throwError . P.errorMessage $ P.MissingFFIModule mn
101+ | otherwise -> return Nothing
102+ pjs <- P.evalSupplyT nextVar $ P.prettyPrintJS <$> J.moduleToJs m foreignInclude
103+ let filePath = P.runModuleName mn
104+ jsFile = outputDir </> filePath </> "index.js"
105+ externsFile = outputDir </> filePath </> "externs.purs"
106+ foreignFile = outputDir </> filePath </> "foreign.js"
107+ prefix = ["Generated by psc-make version " ++ showVersion Paths.version | usePrefix]
108+ js = unlines $ map ("// " ++) prefix ++ [pjs]
109+ writeTextFile jsFile js
110+ maybe (return ()) (writeTextFile foreignFile . snd) $ mn `M.lookup` foreigns
111+ writeTextFile externsFile exts
112+
113+ requiresForeign :: CF.Module a -> Bool
114+ requiresForeign = not . null . CF.moduleForeign
115+
116+ getTimestamp :: FilePath -> Make (Maybe UTCTime)
117+ getTimestamp path = makeIO (const (P.SimpleErrorWrapper $ P.CannotGetFileInfo path)) $ do
118+ exists <- doesFileExist path
119+ traverse (const $ getModificationTime path) $ guard exists
120+
121+ readTextFile :: FilePath -> Make String
122+ readTextFile path = do
123+ verboseErrorsEnabled <- asks P.optionsVerboseErrors
124+ makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile path)) $ do
125+ when verboseErrorsEnabled $ putStrLn $ "Reading " ++ path
126+ readFile path
127+
128+ writeTextFile :: FilePath -> String -> Make ()
129+ writeTextFile path text = makeIO (const (P.SimpleErrorWrapper $ P.CannotWriteFile path)) $ do
130+ mkdirp path
131+ putStrLn $ "Writing " ++ path
132+ writeFile path text
133+ where
134+ mkdirp :: FilePath -> IO ()
135+ mkdirp = createDirectoryIfMissing True . takeDirectory
136+
137+ progress :: String -> Make ()
138+ progress = liftIO . putStrLn
psc/Main.hs+46−33
@@ -12,12 +12,17 @@
1212--
1313-----------------------------------------------------------------------------
1414
15−{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TupleSections, RecordWildCards #-}
15+{-# LANGUAGE DataKinds #-}
16+{-# LANGUAGE FlexibleContexts #-}
17+{-# LANGUAGE RecordWildCards #-}
18+{-# LANGUAGE ScopedTypeVariables #-}
19+{-# LANGUAGE TupleSections #-}
1620
1721module Main where
1822
1923import Control.Applicative
2024import Control.Monad
25+import Control.Monad.Error.Class (MonadError(..))
2126import Control.Monad.Reader
2227import Control.Monad.Writer
2328
@@ -25,27 +30,29 @@ import Data.Maybe (fromMaybe)
2530import Data.Version (showVersion)
2631
2732import Options.Applicative as Opts
33+
2834import System.Directory (createDirectoryIfMissing)
29−import System.FilePath (takeDirectory)
3035import System.Exit (exitSuccess, exitFailure)
36+import System.FilePath (takeDirectory)
3137import System.IO (hPutStrLn, stderr)
3238
39+import qualified Data.Map as M
3340import qualified Language.PureScript as P
3441import qualified Paths_purescript as Paths
3542
3643data PSCOptions = PSCOptions
37− { pscInput :: [FilePath]
38− , pscOpts :: P.Options P.Compile
39− , pscStdIn :: Bool
40− , pscOutput :: Maybe FilePath
41− , pscExterns :: Maybe FilePath
42− , pscUsePrefix :: Bool
44+ { pscInput :: [FilePath]
45+ , pscForeignInput :: [FilePath]
46+ , pscOpts :: P.Options P.Compile
47+ , pscStdIn :: Bool
48+ , pscOutput :: Maybe FilePath
49+ , pscExterns :: Maybe FilePath
50+ , pscUsePrefix :: Bool
4351 }
4452
4553data InputOptions = InputOptions
46− { ioNoPrelude :: Bool
47− , ioUseStdIn :: Bool
48− , ioInputFiles :: [FilePath]
54+ { ioUseStdIn :: Bool
55+ , ioInputFiles :: [FilePath]
4956 }
5057
5158readInput :: InputOptions -> IO [(Maybe FilePath, String)]
@@ -59,20 +66,24 @@ runPSC :: P.Options P.Compile -> PSC a -> Either P.MultipleErrors (a, P.Multiple
5966runPSC opts rwe = runWriterT (runReaderT rwe opts)
6067
6168compile :: PSCOptions -> IO ()
62−compile (PSCOptions input opts stdin output externs usePrefix) = do
63− modules <- P.parseModulesFromFiles (fromMaybe "") <$> readInput (InputOptions (P.optionsNoPrelude opts) stdin input)
64− case modules of
65− Left err -> do
66− hPutStrLn stderr $ show err
69+compile (PSCOptions input inputForeign opts stdin output externs usePrefix) = do
70+ let prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
71+ moduleFiles <- readInput (InputOptions stdin input)
72+ foreignFiles <- forM inputForeign (\inFile -> (inFile,) <$> readFile inFile)
73+ case runWriterT (parseInputs moduleFiles foreignFiles) of
74+ Left errs -> do
75+ hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
6776 exitFailure
68− Right ms -> do
69− case runPSC opts (P.compile (map snd ms) prefix) of
77+ Right ((ms, foreigns), warnings) -> do
78+ when (P.nonEmpty warnings) $
79+ hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)
80+ case runPSC opts (P.compileJS ms foreigns prefix) of
7081 Left errs -> do
7182 hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
7283 exitFailure
73− Right ((js, exts, _), warnings) -> do
74− when (P.nonEmpty warnings) $
75− hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)
84+ Right ((js, exts, _), warnings') -> do
85+ when (P.nonEmpty warnings') $
86+ hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings')
7687 case output of
7788 Just path -> mkdirp path >> writeFile path js
7889 Nothing -> putStrLn js
@@ -80,10 +91,12 @@ compile (PSCOptions input opts stdin output externs usePrefix) = do
8091 Just path -> mkdirp path >> writeFile path exts
8192 Nothing -> return ()
8293 exitSuccess
83− where
84− prefix = if usePrefix
85− then ["Generated by psc version " ++ showVersion Paths.version]
86− else []
94+
95+parseInputs :: (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m)
96+ => [(Maybe FilePath, String)] -> [(FilePath, P.ForeignJS)] -> m ([P.Module], M.Map P.ModuleName (FilePath, P.ForeignJS))
97+parseInputs modules foreigns =
98+ (,) <$> (map snd <$> P.parseModulesFromFiles (fromMaybe "") modules)
99+ <*> P.parseForeignModulesFromFiles foreigns
87100
88101mkdirp :: FilePath -> IO ()
89102mkdirp = createDirectoryIfMissing True . takeDirectory
@@ -139,11 +152,6 @@ noTco = switch $
139152 long "no-tco"
140153 <> help "Disable tail call optimizations"
141154
142−noPrelude :: Parser Bool
143−noPrelude = switch $
144− long "no-prelude"
145− <> help "Omit the automatic Prelude import"
146−
147155comments :: Parser Bool
148156comments = switch $
149157 short 'c'
@@ -161,6 +169,12 @@ inputFile = strArgument $
161169 metavar "FILE"
162170 <> help "The input .purs file(s)"
163171
172+inputForeignFile :: Parser FilePath
173+inputForeignFile = strOption $
174+ short 'f'
175+ <> long "ffi"
176+ <> help "The input .js file(s) providing foreign import implementations"
177+
164178outputFile :: Parser (Maybe FilePath)
165179outputFile = optional . strOption $
166180 short 'o'
@@ -180,8 +194,7 @@ noPrefix = switch $
180194 <> help "Do not include comment header"
181195
182196options :: Parser (P.Options P.Compile)
183−options = P.Options <$> noPrelude
184− <*> noTco
197+options = P.Options <$> noTco
185198 <*> noMagicDo
186199 <*> runMain
187200 <*> noOpts
@@ -196,6 +209,7 @@ options = P.Options <$> noPrelude
196209
197210pscOptions :: Parser PSCOptions
198211pscOptions = PSCOptions <$> many inputFile
212+ <*> many inputForeignFile
199213 <*> options
200214 <*> useStdIn
201215 <*> outputFile
@@ -212,4 +226,3 @@ main = execParser opts >>= compile
212226
213227 version :: Parser (a -> a)
214228 version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
215−
psci/Completion.hs+1−1
@@ -199,7 +199,7 @@ identNames = nubOnFst . mapMaybe getDeclName . P.exportedDeclarations
199199 where
200200 getDeclName :: P.Declaration -> Maybe (P.Ident, P.Declaration)
201201 getDeclName d@(P.ValueDeclaration ident _ _ _) = Just (ident, d)
202− getDeclName d@(P.ExternDeclaration _ ident _ _) = Just (ident, d)
202+ getDeclName d@(P.ExternDeclaration ident _) = Just (ident, d)
203203 getDeclName (P.PositionedDeclaration _ _ d) = getDeclName d
204204 getDeclName _ = Nothing
205205
psci/IO.hsnew file+21
@@ -0,0 +1,21 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : IO
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module IO where
16+
17+import System.Directory (createDirectoryIfMissing)
18+import System.FilePath (takeDirectory)
19+
20+mkdirp :: FilePath -> IO ()
21+mkdirp = createDirectoryIfMissing True . takeDirectory
psci/Make.hsnew file+127
@@ -0,0 +1,127 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Make
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DataKinds #-}
16+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
17+{-# LANGUAGE TupleSections #-}
18+
19+module Make where
20+
21+import Data.List (isPrefixOf)
22+import Data.Maybe (fromMaybe)
23+import Data.Time.Clock
24+import Data.Traversable (traverse)
25+import qualified Data.Map as M
26+
27+import Control.Applicative
28+import Control.Monad
29+import Control.Monad.Error.Class (MonadError(..))
30+import Control.Monad.IO.Class (MonadIO, liftIO)
31+import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)
32+import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
33+import Control.Monad.Writer (MonadWriter, WriterT, runWriterT, tell)
34+
35+import System.Directory (getModificationTime, doesFileExist)
36+import System.FilePath ((</>), pathSeparator)
37+import System.IO.Error (tryIOError)
38+
39+import qualified Language.PureScript as P
40+import qualified Language.PureScript.CodeGen.JS as J
41+import qualified Language.PureScript.CoreFn as CF
42+
43+import IO (mkdirp)
44+
45+options :: P.Options P.Make
46+options = P.Options False False Nothing False False False P.MakeOptions
47+
48+modulesDir :: FilePath
49+modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"
50+
51+newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (WriterT P.MultipleErrors (ExceptT P.MultipleErrors IO)) a }
52+ deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadWriter P.MultipleErrors, MonadReader (P.Options P.Make))
53+
54+runMake :: Make a -> IO (Either P.MultipleErrors a)
55+runMake = runExceptT . fmap fst . runWriterT . flip runReaderT options . unMake
56+
57+makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a
58+makeIO f io = do
59+ e <- liftIO $ tryIOError io
60+ either (throwError . P.singleError . f) return e
61+
62+-- Traverse (Either e) instance (base 4.7)
63+traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
64+traverseEither _ (Left x) = pure (Left x)
65+traverseEither f (Right y) = Right <$> f y
66+
67+buildMakeActions :: M.Map P.ModuleName (Either P.RebuildPolicy String)
68+ -> M.Map P.ModuleName P.ForeignJS
69+ -> P.MakeActions Make
70+buildMakeActions filePathMap foreigns =
71+ P.MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
72+ where
73+
74+ getInputTimestamp :: P.ModuleName -> Make (Either P.RebuildPolicy (Maybe UTCTime))
75+ getInputTimestamp mn = do
76+ let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap
77+ traverseEither getTimestamp path
78+
79+ getOutputTimestamp :: P.ModuleName -> Make (Maybe UTCTime)
80+ getOutputTimestamp mn = do
81+ let filePath = P.runModuleName mn
82+ jsFile = modulesDir </> filePath </> "index.js"
83+ externsFile = modulesDir </> filePath </> "externs.purs"
84+ min <$> getTimestamp jsFile <*> getTimestamp externsFile
85+
86+ readExterns :: P.ModuleName -> Make (FilePath, String)
87+ readExterns mn = do
88+ let path = modulesDir </> P.runModuleName mn </> "externs.purs"
89+ (path, ) <$> readTextFile path
90+
91+ codegen :: CF.Module CF.Ann -> P.Environment -> P.SupplyVar -> P.Externs -> Make ()
92+ codegen m _ nextVar exts = do
93+ let mn = CF.moduleName m
94+ foreignInclude <- case CF.moduleName m `M.lookup` foreigns of
95+ Just path
96+ | not $ requiresForeign m -> do tell $ P.errorMessage $ P.UnnecessaryFFIModule mn path
97+ return Nothing
98+ | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
99+ Nothing | requiresForeign m -> throwError . P.errorMessage $ P.MissingFFIModule mn
100+ | otherwise -> return Nothing
101+ pjs <- P.evalSupplyT nextVar $ P.prettyPrintJS <$> J.moduleToJs m foreignInclude
102+ let filePath = P.runModuleName $ CF.moduleName m
103+ jsFile = modulesDir </> filePath </> "index.js"
104+ externsFile = modulesDir </> filePath </> "externs.purs"
105+ foreignFile = modulesDir </> filePath </> "foreign.js"
106+ writeTextFile jsFile pjs
107+ maybe (return ()) (writeTextFile foreignFile) $ CF.moduleName m `M.lookup` foreigns
108+ writeTextFile externsFile exts
109+
110+ requiresForeign :: CF.Module a -> Bool
111+ requiresForeign = not . null . CF.moduleForeign
112+
113+ getTimestamp :: FilePath -> Make (Maybe UTCTime)
114+ getTimestamp path = makeIO (const (P.SimpleErrorWrapper $ P.CannotGetFileInfo path)) $ do
115+ exists <- doesFileExist path
116+ traverse (const $ getModificationTime path) $ guard exists
117+
118+ readTextFile :: FilePath -> Make String
119+ readTextFile path = makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile path)) $ readFile path
120+
121+ writeTextFile :: FilePath -> String -> Make ()
122+ writeTextFile path text = makeIO (const (P.SimpleErrorWrapper $ P.CannotWriteFile path)) $ do
123+ mkdirp path
124+ writeFile path text
125+
126+ progress :: String -> Make ()
127+ progress s = unless ("Compiling $PSCI" `isPrefixOf` s) $ liftIO . putStrLn $ s
psci/PSCi.hs+60−86
@@ -13,50 +13,47 @@
1313--
1414-----------------------------------------------------------------------------
1515
16−{-# LANGUAGE DataKinds #-}
1716{-# LANGUAGE DoAndIfThenElse #-}
18−{-# LANGUAGE FlexibleContexts #-}
1917{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2018{-# LANGUAGE RecordWildCards #-}
19+{-# LANGUAGE TupleSections #-}
2120
2221module PSCi where
2322
2423import Data.Foldable (traverse_)
25−import Data.List (intercalate, nub, sort, isPrefixOf)
24+import Data.List (intercalate, nub, sort)
2625import Data.Traversable (traverse)
26+import Data.Tuple (swap)
2727import Data.Version (showVersion)
2828import qualified Data.Map as M
2929
3030import Control.Applicative
31+import Control.Arrow (first)
3132import Control.Monad
32−import Control.Monad.IO.Class (MonadIO, liftIO)
33−import Control.Monad.Error.Class (MonadError(..))
34−import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
35−import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)
36−import Control.Monad.Writer (MonadWriter, WriterT, runWriterT, runWriter)
3733import Control.Monad.Trans.Class
34+import Control.Monad.Trans.Except (runExceptT)
3835import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
3936import Control.Monad.Trans.State.Strict
37+import Control.Monad.Writer (runWriter)
4038import qualified Control.Monad.Trans.State.Lazy as L
4139
4240import Options.Applicative as Opts
4341
4442import System.Console.Haskeline
45−import System.Directory (createDirectoryIfMissing, getModificationTime, doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory)
43+import System.Directory (doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory)
4644import System.Exit
47−import System.FilePath (pathSeparator, takeDirectory, (</>), isPathSeparator)
48−import System.IO.Error (tryIOError)
45+import System.FilePath (pathSeparator, (</>), isPathSeparator)
4946import System.Process (readProcessWithExitCode)
5047
51−import qualified Text.Parsec as Par (ParseError)
52−
5348import qualified Language.PureScript as P
5449import qualified Language.PureScript.Names as N
5550import qualified Paths_purescript as Paths
5651
5752import qualified Directive as D
58−import Parser (parseCommand)
5953import Completion (completion)
54+import IO (mkdirp)
55+import Make
56+import Parser (parseCommand)
6057import Types
6158
6259-- | The name of the PSCI support module
@@ -65,7 +62,7 @@ supportModuleName = P.ModuleName [P.ProperName "$PSCI", P.ProperName "Support"]
6562
6663-- | Support module, contains code to evaluate terms
6764supportModule :: P.Module
68−supportModule =
65+supportModule =
6966 case P.parseModulesFromFiles id [("", code)] of
7067 Right [(_, P.Module cs _ ds exps)] -> P.Module cs supportModuleName ds exps
7168 _ -> error "Support module could not be parsed"
@@ -90,11 +87,6 @@ supportModule =
9087 ]
9188
9289-- File helpers
93−-- |
94−-- Load the necessary modules.
95−--
96−defaultImports :: [ImportedModule]
97−defaultImports = [(P.ModuleName [P.ProperName "Prelude"], P.Implicit, Nothing)]
9890
9991-- |
10092-- Locates the node executable.
@@ -120,12 +112,12 @@ getHistoryFilename = do
120112loadModule :: FilePath -> IO (Either String [P.Module])
121113loadModule filename = do
122114 content <- readFile filename
123− return $ either (Left . show) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]
115+ return $ either (Left . P.prettyPrintMultipleErrors False) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]
124116
125117-- |
126−-- Load all modules, including the Prelude
118+-- Load all modules.
127119--
128−loadAllModules :: [FilePath] -> IO (Either Par.ParseError [(Either P.RebuildPolicy FilePath, P.Module)])
120+loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(Either P.RebuildPolicy FilePath, P.Module)])
129121loadAllModules files = do
130122 filesAndContent <- forM files $ \filename -> do
131123 content <- readFile filename
@@ -140,7 +132,7 @@ loadAllImportedModules = do
140132 files <- PSCI . lift $ fmap psciImportedFilenames get
141133 modulesOrFirstError <- psciIO $ loadAllModules files
142134 case modulesOrFirstError of
143− Left err -> psciIO $ print err
135+ Left errs -> printErrors errs
144136 Right modules -> PSCI . lift . modify $ \st -> st { psciLoadedModules = modules }
145137
146138-- |
@@ -149,6 +141,7 @@ loadAllImportedModules = do
149141expandTilde :: FilePath -> IO FilePath
150142expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory
151143expandTilde p = return p
144+
152145-- Messages
153146
154147-- |
@@ -162,13 +155,12 @@ helpMessage = "The following commands are available:\n\n " ++
162155 line :: (Directive, String, String) -> String
163156 line (dir, arg, desc) =
164157 let cmd = ':' : D.stringFor dir
165− in intercalate " "
166− [ cmd
167− , replicate (11 - length cmd) ' '
168− , arg
169− , replicate (11 - length arg) ' '
170− , desc
171− ]
158+ in unwords [ cmd
159+ , replicate (11 - length cmd) ' '
160+ , arg
161+ , replicate (11 - length arg) ' '
162+ , desc
163+ ]
172164
173165 extraHelp =
174166 "Further information is available on the PureScript wiki:\n" ++
@@ -196,14 +188,6 @@ prologueMessage = intercalate "\n"
196188quitMessage :: String
197189quitMessage = "See ya!"
198190
199−
200−-- Compilation
201−
202−-- | Compilation options.
203−--
204−options :: P.Options P.Make
205−options = P.Options False False False Nothing False False False P.MakeOptions
206−
207191-- |
208192-- PSCI monad
209193--
@@ -212,30 +196,6 @@ newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Fu
212196psciIO :: IO a -> PSCI a
213197psciIO io = PSCI . lift $ lift io
214198
215−newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (WriterT P.MultipleErrors (ExceptT P.MultipleErrors IO)) a }
216− deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadWriter P.MultipleErrors, MonadReader (P.Options P.Make))
217−
218−runMake :: Make a -> IO (Either P.MultipleErrors a)
219−runMake = runExceptT . fmap fst . runWriterT . flip runReaderT options . unMake
220−
221−makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a
222−makeIO f io = do
223− e <- liftIO $ tryIOError io
224− either (throwError . P.singleError . f) return e
225−
226−instance P.MonadMake Make where
227− getTimestamp path = makeIO (const (P.SimpleErrorWrapper $ P.CannotGetFileInfo path)) $ do
228− exists <- doesFileExist path
229− traverse (const $ getModificationTime path) $ guard exists
230− readTextFile path = makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile path)) $ readFile path
231− writeTextFile path text = makeIO (const (P.SimpleErrorWrapper $ P.CannotWriteFile path)) $ do
232− mkdirp path
233− writeFile path text
234− progress s = unless ("Compiling $PSCI" `isPrefixOf` s) $ liftIO . putStrLn $ s
235−
236−mkdirp :: FilePath -> IO ()
237−mkdirp = createDirectoryIfMissing True . takeDirectory
238−
239199-- |
240200-- Makes a volatile module to execute the current expression.
241201--
@@ -245,8 +205,8 @@ createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindi
245205 moduleName = P.ModuleName [P.ProperName "$PSCI"]
246206 trace = P.Var (P.Qualified (Just supportModuleName) (P.Ident "eval"))
247207 mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))
248− itDecl = P.ValueDeclaration (P.Ident "it") P.Value [] $ Right val
249− mainDecl = P.ValueDeclaration (P.Ident "main") P.Value [] $ Right mainValue
208+ itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] $ Right val
209+ mainDecl = P.ValueDeclaration (P.Ident "main") P.Public [] $ Right mainValue
250210 decls = if exec then [itDecl, mainDecl] else [itDecl]
251211 in
252212 P.Module [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing
@@ -276,12 +236,14 @@ createTemporaryModuleForImports PSCiState{psciImportedModules = imports} =
276236importDecl :: ImportedModule -> P.Declaration
277237importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ
278238
279−modulesDir :: FilePath
280−modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"
281−
282239indexFile :: FilePath
283240indexFile = ".psci_modules" ++ pathSeparator : "index.js"
284241
242+make :: PSCiState -> [(Either P.RebuildPolicy FilePath, P.Module)] -> Make P.Environment
243+make PSCiState{..} ms =
244+ let filePathMap = M.fromList $ (first P.getModuleName . swap) `map` (psciLoadedModules ++ ms)
245+ in P.make (buildMakeActions filePathMap (M.map snd psciForeignFiles)) (psciLoadedModules ++ ms)
246+
285247-- |
286248-- Takes a value declaration and evaluates it with the current state.
287249--
@@ -290,7 +252,7 @@ handleDeclaration val = do
290252 st <- PSCI $ lift get
291253 let m = createTemporaryModule True st val
292254 let nodeArgs = psciNodeFlags st ++ [indexFile]
293− e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, supportModule), (Left P.RebuildAlways, m)]) []
255+ e <- psciIO . runMake $ make st [(Left P.RebuildAlways, supportModule), (Left P.RebuildAlways, m)]
294256 case e of
295257 Left errs -> printErrors errs
296258 Right _ -> do
@@ -311,7 +273,7 @@ handleDecls ds = do
311273 st <- PSCI $ lift get
312274 let st' = updateLets ds st
313275 let m = createTemporaryModule False st' (P.ObjectLiteral [])
314− e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st' ++ [(Left P.RebuildAlways, m)]) []
276+ e <- psciIO . runMake $ make st' [(Left P.RebuildAlways, m)]
315277 case e of
316278 Left err -> printErrors err
317279 Right _ -> PSCI $ lift (put st')
@@ -364,7 +326,7 @@ handleImport :: ImportedModule -> PSCI ()
364326handleImport im = do
365327 st <- updateImportedModules im <$> PSCI (lift get)
366328 let m = createTemporaryModuleForImports st
367− e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
329+ e <- psciIO . runMake $ make st [(Left P.RebuildAlways, m)]
368330 case e of
369331 Left errs -> printErrors errs
370332 Right _ -> do
@@ -378,7 +340,7 @@ handleTypeOf :: P.Expr -> PSCI ()
378340handleTypeOf val = do
379341 st <- PSCI $ lift get
380342 let m = createTemporaryModule False st val
381− e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
343+ e <- psciIO . runMake $ make st [(Left P.RebuildAlways, m)]
382344 case e of
383345 Left errs -> printErrors errs
384346 Right env' ->
@@ -411,12 +373,11 @@ printModuleSignatures moduleName env =
411373handleBrowse :: P.ModuleName -> PSCI ()
412374handleBrowse moduleName = do
413375 st <- PSCI $ lift get
414− let loadedModules = psciLoadedModules st
415− env <- psciIO . runMake $ P.make modulesDir loadedModules []
376+ env <- psciIO . runMake $ make st []
416377 case env of
417378 Left errs -> printErrors errs
418379 Right env' ->
419− if moduleName `notElem` (nub . map ((\ (P.Module _ modName _ _ ) -> modName) . snd)) loadedModules
380+ if moduleName `notElem` (nub . map ((\ (P.Module _ modName _ _ ) -> modName) . snd)) (psciLoadedModules st)
420381 then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid."
421382 else printModuleSignatures moduleName env'
422383
@@ -432,7 +393,7 @@ handleKindOf typ = do
432393 st <- PSCI $ lift get
433394 let m = createTemporaryModuleForKind st typ
434395 mName = P.ModuleName [P.ProperName "$PSCI"]
435− e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
396+ e <- psciIO . runMake $ make st [(Left P.RebuildAlways, m)]
436397 case e of
437398 Left errs -> printErrors errs
438399 Right env' ->
@@ -485,7 +446,7 @@ handleCommand ResetState = do
485446 files <- psciImportedFilenames <$> PSCI (lift get)
486447 PSCI . lift . modify $ \st -> st
487448 { psciImportedFilenames = files
488− , psciImportedModules = defaultImports
449+ , psciImportedModules = []
489450 , psciLetBindings = []
490451 }
491452 loadAllImportedModules
@@ -521,18 +482,24 @@ loop PSCiOptions{..} = do
521482 config <- loadUserConfig
522483 modulesOrFirstError <- loadAllModules psciInputFile
523484 case modulesOrFirstError of
524− Left err -> print err >> exitFailure
485+ Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure
525486 Right modules -> do
526487 historyFilename <- getHistoryFilename
527488 let settings = defaultSettings { historyFile = Just historyFilename }
528− flip evalStateT (PSCiState psciInputFile defaultImports modules [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do
529− outputStrLn prologueMessage
530− traverse_ (mapM_ (runPSCI . handleCommand)) config
531− unless (consoleIsDefined (map snd modules)) . outputStrLn $ unlines
532− [ "PSCi requires the purescript-console module to be installed."
533− , "For help getting started, visit http://wiki.purescript.org/PSCi"
534− ]
535− go
489+ foreignsOrError <- runMake $ do
490+ foreignFiles <- forM psciForeignInputFiles (\inFile -> (inFile,) <$> makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile inFile)) (readFile inFile))
491+ P.parseForeignModulesFromFiles foreignFiles
492+ case foreignsOrError of
493+ Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure
494+ Right foreigns ->
495+ flip evalStateT (PSCiState psciInputFile [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do
496+ outputStrLn prologueMessage
497+ traverse_ (mapM_ (runPSCI . handleCommand)) config
498+ unless (consoleIsDefined (map snd modules)) . outputStrLn $ unlines
499+ [ "PSCi requires the purescript-console module to be installed."
500+ , "For help getting started, visit http://wiki.purescript.org/PSCi"
501+ ]
502+ go
536503 where
537504 go :: InputT (StateT PSCiState IO) ()
538505 go = do
@@ -554,6 +521,12 @@ inputFile = strArgument $
554521 metavar "FILE"
555522 <> Opts.help "Optional .purs files to load on start"
556523
524+inputForeignFile :: Parser FilePath
525+inputForeignFile = strOption $
526+ short 'f'
527+ <> long "ffi"
528+ <> help "The input .js file(s) providing foreign import implementations"
529+
557530nodeFlagsFlag :: Parser [String]
558531nodeFlagsFlag = option parser $
559532 long "node-opts"
@@ -566,6 +539,7 @@ nodeFlagsFlag = option parser $
566539psciOptions :: Parser PSCiOptions
567540psciOptions = PSCiOptions <$> multiLineMode
568541 <*> many inputFile
542+ <*> many inputForeignFile
569543 <*> nodeFlagsFlag
570544
571545runPSCi :: IO ()
psci/Parser.hs+7−7
@@ -122,13 +122,13 @@ discardPositionInfo (P.PositionedDeclaration _ _ d) = d
122122discardPositionInfo d = d
123123
124124acceptable :: P.Declaration -> Bool
125−acceptable (P.DataDeclaration _ _ _ _) = True
126−acceptable (P.TypeSynonymDeclaration _ _ _) = True
127−acceptable (P.ExternDeclaration _ _ _ _) = True
128−acceptable (P.ExternDataDeclaration _ _) = True
129−acceptable (P.ExternInstanceDeclaration _ _ _ _) = True
130−acceptable (P.TypeClassDeclaration _ _ _ _) = True
131−acceptable (P.TypeInstanceDeclaration _ _ _ _ _) = True
125+acceptable P.DataDeclaration{} = True
126+acceptable P.TypeSynonymDeclaration{} = True
127+acceptable P.ExternDeclaration{} = True
128+acceptable P.ExternDataDeclaration{} = True
129+acceptable P.ExternInstanceDeclaration{} = True
130+acceptable P.TypeClassDeclaration{} = True
131+acceptable P.TypeInstanceDeclaration{} = True
132132acceptable _ = False
133133
134134parseReplQuery' :: String -> Either String ReplQuery
psci/Types.hs+6−3
@@ -15,12 +15,14 @@
1515
1616module Types where
1717
18+import qualified Data.Map as M
1819import qualified Language.PureScript as P
1920
2021data PSCiOptions = PSCiOptions
21− { psciMultiLineMode :: Bool
22− , psciInputFile :: [FilePath]
23− , psciInputNodeFlags :: [String]
22+ { psciMultiLineMode :: Bool
23+ , psciInputFile :: [FilePath]
24+ , psciForeignInputFiles :: [FilePath]
25+ , psciInputNodeFlags :: [String]
2426 }
2527
2628-- |
@@ -33,6 +35,7 @@ data PSCiState = PSCiState
3335 { psciImportedFilenames :: [FilePath]
3436 , psciImportedModules :: [ImportedModule]
3537 , psciLoadedModules :: [(Either P.RebuildPolicy FilePath, P.Module)]
38+ , psciForeignFiles :: M.Map P.ModuleName (FilePath, P.ForeignJS)
3639 , psciLetBindings :: [P.Declaration]
3740 , psciNodeFlags :: [String]
3841 }
psci/tests/Main.hs+17−8
@@ -1,16 +1,19 @@
1−{-# LANGUAGE RecordWildCards #-}
1+{-# LANGUAGE RecordWildCards, TupleSections #-}
22
33module Main where
44
55import Control.Monad.Trans.State.Strict (runStateT)
6−import Control.Monad (when)
6+import Control.Monad (when, forM)
7+import Control.Applicative
8+import Control.Monad.Writer (runWriterT)
9+import Control.Monad.Trans.Except (runExceptT)
710
8−import Data.List (sort)
11+import Data.List (isSuffixOf, sort)
912
1013import System.Exit (exitFailure)
1114import System.Console.Haskeline
1215import System.FilePath ((</>))
13−import System.Directory (getCurrentDirectory)
16+import System.Directory (getCurrentDirectory, getDirectoryContents)
1417
1518import Test.HUnit
1619
@@ -104,7 +107,8 @@ completionTestData =
104107 , ("Control.Monad.ST.new", ["Control.Monad.ST.newSTRef"])
105108 ]
106109 where
107− allModuleNames = [ "Control.Monad.Eff"
110+ allModuleNames = [ "Assert"
111+ , "Control.Monad.Eff"
108112 , "Control.Monad.ST"
109113 , "Data.Function"
110114 , "Debug.Trace"
@@ -127,13 +131,18 @@ runCM act = do
127131getPSCiState :: IO PSCiState
128132getPSCiState = do
129133 cwd <- getCurrentDirectory
130− modulesOrFirstError <- loadAllModules [ cwd </> "tests" </> "prelude.purs" ]
134+ let preludeDir = cwd </> "tests" </> "prelude"
135+ jsDir = preludeDir </> "js"
136+ modulesOrFirstError <- loadAllModules [ preludeDir </> "prelude.purs" ]
137+ jsFiles <- map (jsDir </>) . filter (".js" `isSuffixOf`) <$> getDirectoryContents jsDir
138+ foreignFiles <- forM jsFiles (\f -> (f,) <$> readFile f)
139+ Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles
131140 case modulesOrFirstError of
132141 Left err ->
133142 print err >> exitFailure
134143 Right modules ->
135− let imports = controlMonadSTasST : defaultImports
136− in return (PSCiState [] imports modules [] [])
144+ let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName "Prelude"], P.Implicit, Nothing)]
145+ in return (PSCiState [] imports modules foreigns [] [])
137146
138147controlMonadSTasST :: ImportedModule
139148controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST"))
purescript.cabal+9−5
@@ -46,6 +46,7 @@ library
4646 bytestring -any,
4747 text -any,
4848 split -any
49+
4950 exposed-modules: Language.PureScript
5051 Language.PureScript.AST
5152 Language.PureScript.AST.Binders
@@ -89,6 +90,7 @@ library
8990 Language.PureScript.Parser.Lexer
9091 Language.PureScript.Parser.Common
9192 Language.PureScript.Parser.Declarations
93+ Language.PureScript.Parser.JS
9294 Language.PureScript.Parser.Kinds
9395 Language.PureScript.Parser.State
9496 Language.PureScript.Parser.Types
@@ -155,18 +157,18 @@ executable psc
155157executable psc-make
156158 build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
157159 mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,
158− transformers -any, transformers-compat -any
160+ time -any, transformers -any, transformers-compat -any
159161 main-is: Main.hs
160162 buildable: True
161163 hs-source-dirs: psc-make
162− other-modules:
164+ other-modules: Make
163165 ghc-options: -Wall -O2 -fno-warn-unused-do-bind
164166
165167executable psci
166168 build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
167169 mtl -any, optparse-applicative >= 0.10.0, parsec -any,
168170 haskeline >= 0.7.0.0, purescript -any, transformers -any,
169− transformers-compat -any, process -any
171+ transformers-compat -any, process -any, time -any
170172
171173 main-is: Main.hs
172174 buildable: True
@@ -176,6 +178,8 @@ executable psci
176178 Directive
177179 Completion
178180 PSCi
181+ Make
182+ IO
179183 ghc-options: -Wall -O2
180184
181185executable psc-docs
@@ -219,7 +223,7 @@ executable psc-hierarchy
219223test-suite tests
220224 build-depends: base >=4 && <5, containers -any, directory -any,
221225 filepath -any, mtl -any, parsec -any, purescript -any,
222− transformers -any, process -any
226+ transformers -any, process -any, transformers-compat -any
223227 type: exitcode-stdio-1.0
224228 main-is: Main.hs
225229 buildable: True
@@ -229,7 +233,7 @@ test-suite psci-tests
229233 build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
230234 mtl -any, optparse-applicative >= 0.10.0, parsec -any,
231235 haskeline >= 0.7.0.0, purescript -any, transformers -any,
232− transformers-compat -any, process -any, HUnit -any
236+ transformers-compat -any, process -any, HUnit -any, time -any
233237 type: exitcode-stdio-1.0
234238 main-is: Main.hs
235239 buildable: True
src/Language/PureScript.hs+110−105
@@ -14,17 +14,19 @@
1414-----------------------------------------------------------------------------
1515
1616{-# LANGUAGE DataKinds #-}
17−{-# LANGUAGE QuasiQuotes #-}
18−{-# LANGUAGE TemplateHaskell #-}
1917{-# LANGUAGE FlexibleContexts #-}
18+{-# LANGUAGE RecordWildCards #-}
2019{-# LANGUAGE ScopedTypeVariables #-}
2120
2221module Language.PureScript
2322 ( module P
2423 , compile
2524 , compile'
25+ , compileJS
2626 , RebuildPolicy(..)
27− , MonadMake(..)
27+ , MakeActions(..)
28+ , SupplyVar()
29+ , Externs()
2830 , make
2931 , version
3032 ) where
@@ -34,7 +36,6 @@ import Data.List (sortBy, groupBy, intercalate)
3436import Data.Maybe (fromMaybe)
3537import Data.Time.Clock
3638import Data.Version (Version)
37−import qualified Data.Traversable as T (traverse)
3839import qualified Data.Map as M
3940import qualified Data.Set as S
4041
@@ -44,12 +45,11 @@ import Control.Monad
4445import Control.Monad.Error.Class (MonadError(..))
4546import Control.Monad.Reader
4647import Control.Monad.Writer
47−
48−import System.FilePath ((</>))
48+import Control.Monad.Supply.Class (MonadSupply, fresh)
4949
5050import Language.PureScript.AST as P
5151import Language.PureScript.Comments as P
52−import Language.PureScript.CodeGen as P
52+import Language.PureScript.CodeGen.Externs (moduleToPs)
5353import Language.PureScript.DeadCodeElimination as P
5454import Language.PureScript.Environment as P
5555import Language.PureScript.Errors as P
@@ -67,6 +67,7 @@ import Language.PureScript.TypeChecker as P
6767import Language.PureScript.Types as P
6868import qualified Language.PureScript.CoreFn as CoreFn
6969import qualified Language.PureScript.Constants as C
70+import qualified Language.PureScript.CodeGen.JS as J
7071
7172import qualified Paths_purescript as Paths
7273
@@ -90,17 +91,15 @@ import qualified Paths_purescript as Paths
9091-- * Pretty-print the generated Javascript
9192--
9293compile :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadReader (Options Compile) m)
93− => [Module] -> [String] -> m (String, String, Environment)
94+ => [Module] -> m ([CoreFn.Module CoreFn.Ann], Environment, SupplyVar, Externs)
9495compile = compile' initEnvironment
9596
9697compile' :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadReader (Options Compile) m)
97− => Environment -> [Module] -> [String] -> m (String, String, Environment)
98−compile' env ms prefix = do
99− noPrelude <- asks optionsNoPrelude
100− unless noPrelude (checkPreludeIsDefined ms)
98+ => Environment -> [Module] -> m ([CoreFn.Module CoreFn.Ann], Environment, SupplyVar, Externs)
99+compile' env ms = do
101100 additional <- asks optionsAdditional
102101 mainModuleIdent <- asks (fmap moduleNameFromString . optionsMain)
103− (sorted, _) <- sortModules $ map importPrim $ if noPrelude then ms else map importPrelude ms
102+ (sorted, _) <- sortModules $ map importPrim ms
104103 mapM_ lint sorted
105104 (desugared, nextVar) <- runSupplyT 0 $ desugar sorted
106105 (elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent
@@ -111,46 +110,92 @@ compile' env ms prefix = do
111110 renamed = renameInModules elim
112111 codeGenModuleNames = moduleNameFromString `map` codeGenModules additional
113112 modulesToCodeGen = if null codeGenModuleNames then renamed else filter (\(CoreFn.Module _ mn _ _ _ _) -> mn `elem` codeGenModuleNames) renamed
114− js <- concat <$> (evalSupplyT nextVar $ T.traverse moduleToJs modulesToCodeGen)
115− let exts = intercalate "\n" . map (`moduleToPs` env') $ regrouped
116− js' <- generateMain env' js
117− let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js']
118− return (pjs, exts, env')
113+ exts = intercalate "\n" . map (`moduleToPs` env') $ regrouped
114+ return (modulesToCodeGen, env', nextVar, exts)
119115
120−generateMain :: (MonadError MultipleErrors m, MonadReader (Options Compile) m) => Environment -> [JS] -> m [JS]
121−generateMain env js = do
122− main <- asks optionsMain
123− additional <- asks optionsAdditional
124− case moduleNameFromString <$> main of
125− Just mmi -> do
126− when ((mmi, Ident C.main) `M.notMember` names env) $
127− throwError . errorMessage $ NameIsUndefined (Ident C.main)
128− return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (browserNamespace additional)))) []]
129− _ -> return js
116+-- |
117+-- Compile a collection of modules to JavaScript and externs files
118+--
119+compileJS :: forall m. (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m, MonadReader (P.Options P.Compile) m)
120+ => [P.Module] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> [String] -> m (String, String, Environment)
121+compileJS ms foreigns prefix = do
122+ (modulesToCodeGen, env, nextVar, exts) <- compile ms
123+ js <- concat <$> evalSupplyT nextVar (P.parU modulesToCodeGen codegenModule)
124+ js' <- generateMain env js
125+ let pjs = unlines $ map ("// " ++) prefix ++ [P.prettyPrintJS js']
126+ return (pjs, exts, env)
127+
128+ where
129+
130+ codegenModule :: (Functor n, Applicative n, MonadError P.MultipleErrors n, MonadWriter P.MultipleErrors n, MonadReader (P.Options P.Compile) n, MonadSupply n)
131+ => CoreFn.Module CoreFn.Ann -> n [J.JS]
132+ codegenModule m =
133+ let requiresForeign = not $ null (CoreFn.moduleForeign m)
134+ mn = CoreFn.moduleName m
135+ in case mn `M.lookup` foreigns of
136+ Just (path, js)
137+ | not requiresForeign -> do
138+ tell $ P.errorMessage $ P.UnnecessaryFFIModule mn path
139+ J.moduleToJs m Nothing
140+ | otherwise -> J.moduleToJs m $ Just $
141+ J.JSApp (J.JSFunction Nothing [] $
142+ J.JSBlock [ J.JSVariableIntroduction "exports" (Just $ J.JSObjectLiteral [])
143+ , J.JSRaw js
144+ , J.JSReturn (J.JSVar "exports")
145+ ]) []
146+ Nothing | requiresForeign -> throwError . P.errorMessage $ P.MissingFFIModule mn
147+ | otherwise -> J.moduleToJs m Nothing
148+
149+ generateMain :: P.Environment -> [J.JS] -> m [J.JS]
150+ generateMain env js = do
151+ mainName <- asks P.optionsMain
152+ additional <- asks P.optionsAdditional
153+ case P.moduleNameFromString <$> mainName of
154+ Just mmi -> do
155+ when ((mmi, P.Ident C.main) `M.notMember` P.names env) $
156+ throwError . P.errorMessage $ P.NameIsUndefined (P.Ident C.main)
157+ return $ js ++ [J.mainCall mmi (P.browserNamespace additional)]
158+ _ -> return js
130159
131160-- |
132−-- A type class which collects the IO actions we need to be able to run in "make" mode
161+-- Actions that require implementations when running in "make" mode.
133162--
134−class (MonadReader (P.Options P.Make) m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MonadMake m where
163+data MakeActions m = MakeActions {
135164 -- |
136− -- Get a file timestamp
165+ -- Get the timestamp for the input file(s) for a module. If there are multiple
166+ -- files (.purs and foreign files, for example) the timestamp should be for
167+ -- the most recently modified file.
137168 --
138− getTimestamp :: FilePath -> m (Maybe UTCTime)
139−
169+ getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime))
140170 -- |
141− -- Read a file as a string
171+ -- Get the timestamp for the output files for a module. This should be the
172+ -- timestamp for the oldest modified file, or Nothing if any of the required
173+ -- output files are missing.
142174 --
143− readTextFile :: FilePath -> m String
144−
175+ , getOutputTimestamp :: ModuleName -> m (Maybe UTCTime)
176+ -- |
177+ -- Read the externs file for a module as a string and also return the actual
178+ -- path for the file.
179+ , readExterns :: ModuleName -> m (FilePath, String)
145180 -- |
146− -- Write a text file
181+ -- Run the code generator for the module and write any required output files.
147182 --
148− writeTextFile :: FilePath -> String -> m ()
149−
183+ , codegen :: CoreFn.Module CoreFn.Ann -> Environment -> SupplyVar -> Externs -> m ()
150184 -- |
151− -- Respond to a progress update
185+ -- Respond to a progress update.
152186 --
153− progress :: String -> m ()
187+ , progress :: String -> m ()
188+ }
189+
190+-- |
191+-- Generated code for an externs file.
192+--
193+type Externs = String
194+
195+-- |
196+-- A value to be used in the Supply monad.
197+--
198+type SupplyVar = Integer
154199
155200-- |
156201-- Determines when to rebuild a module
@@ -161,79 +206,47 @@ data RebuildPolicy
161206 -- | Always rebuild this module
162207 | RebuildAlways deriving (Show, Eq, Ord)
163208
164−-- Traverse (Either e) instance (base 4.7)
165−traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
166−traverseEither _ (Left x) = pure (Left x)
167−traverseEither f (Right y) = Right <$> f y
168−
169209-- |
170210-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
171211--
172212-- If timestamps have not changed, the externs file can be used to provide the module's types without
173213-- having to typecheck the module again.
174214--
175−make :: forall m. (Functor m, Applicative m, Monad m, MonadMake m)
176− => FilePath -> [(Either RebuildPolicy FilePath, Module)] -> [String] -> m Environment
177−make outputDir ms prefix = do
178− noPrelude <- asks optionsNoPrelude
179− unless noPrelude (checkPreludeIsDefined (map snd ms))
180− let filePathMap = M.fromList (map (\(fp, Module _ mn _ _) -> (mn, fp)) ms)
181−
182− (sorted, graph) <- sortModules $ map importPrim $ if noPrelude then map snd ms else map (importPrelude . snd) ms
183−
215+make :: forall m. (Functor m, Applicative m, Monad m, MonadReader (P.Options P.Make) m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
216+ => MakeActions m
217+ -> [(Either RebuildPolicy FilePath, Module)]
218+ -> m Environment
219+make MakeActions{..} ms = do
220+ (sorted, graph) <- sortModules $ map (importPrim . snd) ms
184221 mapM_ lint sorted
185−
186222 toRebuild <- foldM (\s (Module _ moduleName' _ _) -> do
187− let filePath = runModuleName moduleName'
188−
189− jsFile = outputDir </> filePath </> "index.js"
190− externsFile = outputDir </> filePath </> "externs.purs"
191− inputFile = fromMaybe (error "Module has no filename in 'make'") $ M.lookup moduleName' filePathMap
192−
193− jsTimestamp <- getTimestamp jsFile
194− externsTimestamp <- getTimestamp externsFile
195− inputTimestamp <- traverseEither getTimestamp inputFile
196−
197− return $ case (inputTimestamp, jsTimestamp, externsTimestamp) of
198− (Right (Just t1), Just t2, Just t3) | t1 < min t2 t3 -> s
199− (Left RebuildNever, Just _, Just _) -> s
223+ inputTimestamp <- getInputTimestamp moduleName'
224+ outputTimestamp <- getOutputTimestamp moduleName'
225+ return $ case (inputTimestamp, outputTimestamp) of
226+ (Right (Just t1), Just t2) | t1 < t2 -> s
227+ (Left RebuildNever, Just _) -> s
200228 _ -> S.insert moduleName' s) S.empty sorted
201229
202230 marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
203−
204231 (desugared, nextVar) <- runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
205−
206232 evalSupplyT nextVar $ go initEnvironment desugared
207−
208233 where
234+
209235 go :: Environment -> [(Bool, Module)] -> SupplyT m Environment
210236 go env [] = return env
211237 go env ((False, m) : ms') = do
212238 (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m
213−
214239 go env' ms'
215240 go env ((True, m@(Module coms moduleName' _ exps)) : ms') = do
216− let filePath = runModuleName moduleName'
217− jsFile = outputDir </> filePath </> "index.js"
218− externsFile = outputDir </> filePath </> "externs.purs"
219−
220− lift . progress $ "Compiling " ++ runModuleName moduleName'
221−
241+ lift $ progress $ "Compiling " ++ runModuleName moduleName'
222242 (Module _ _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m
223−
224243 regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated
225−
226244 let mod' = Module coms moduleName' regrouped exps
227245 corefn = CoreFn.moduleToCoreFn env' mod'
228246 [renamed] = renameInModules [corefn]
229−
230− pjs <- prettyPrintJS <$> moduleToJs renamed
231− let js = unlines $ map ("// " ++) prefix ++ [pjs]
232− let exts = unlines $ map ("-- " ++) prefix ++ [moduleToPs mod' env']
233−
234− lift $ writeTextFile jsFile js
235− lift $ writeTextFile externsFile exts
236−
247+ exts = moduleToPs mod' env'
248+ nextVar <- fresh
249+ lift $ codegen renamed env' nextVar exts
237250 go env' ms'
238251
239252 rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
@@ -243,18 +256,16 @@ make outputDir ms prefix = do
243256 toRebuild' = toRebuild `S.union` S.fromList deps
244257 (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'
245258 rebuildIfNecessary graph toRebuild (Module _ moduleName' _ _ : ms') = do
246− let externsFile = outputDir </> runModuleName moduleName' </> "externs.purs"
247− externs <- readTextFile externsFile
248− externsModules <- fmap (map snd) . either (throwError . errorMessage . ErrorParsingExterns) return $ P.parseModulesFromFiles id [(externsFile, externs)]
259+ (path, externs) <- readExterns moduleName'
260+ externsModules <- fmap (map snd) . alterErrors $ P.parseModulesFromFiles id [(path, externs)]
249261 case externsModules of
250262 [m'@(Module _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
251− _ -> throwError . errorMessage . InvalidExternsFile $ externsFile
252−
253−checkPreludeIsDefined :: (MonadWriter MultipleErrors m) => [Module] -> m ()
254−checkPreludeIsDefined ms = do
255− let mns = map getModuleName ms
256− unless (preludeModuleName `elem` mns) $
257− tell (errorMessage PreludeNotPresent)
263+ _ -> throwError . errorMessage . InvalidExternsFile $ path
264+ where
265+ alterErrors = flip catchError $ \(MultipleErrors errs) ->
266+ throwError . MultipleErrors $ flip map errs $ \e -> case e of
267+ SimpleErrorWrapper (ErrorParsingModule err) -> SimpleErrorWrapper (ErrorParsingExterns err)
268+ _ -> e
258269
259270reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
260271reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
@@ -277,11 +288,5 @@ addDefaultImport toImport m@(Module coms mn decls exps) =
277288importPrim :: Module -> Module
278289importPrim = addDefaultImport (ModuleName [ProperName C.prim])
279290
280−preludeModuleName :: ModuleName
281−preludeModuleName = ModuleName [ProperName C.prelude]
282−
283−importPrelude :: Module -> Module
284−importPrelude = addDefaultImport preludeModuleName
285−
286291version :: Version
287292version = Paths.version
src/Language/PureScript/AST/Declarations.hs+3−4
@@ -26,7 +26,6 @@ import Language.PureScript.Names
2626import Language.PureScript.Kinds
2727import Language.PureScript.TypeClassDictionaries
2828import Language.PureScript.Comments
29−import Language.PureScript.CodeGen.JS.AST
3029import Language.PureScript.Environment
3130
3231-- |
@@ -122,9 +121,9 @@ data Declaration
122121 --
123122 | BindingGroupDeclaration [(Ident, NameKind, Expr)]
124123 -- |
125− -- A foreign import declaration (type, name, optional inline Javascript, type)
124+ -- A foreign import declaration (name, type)
126125 --
127− | ExternDeclaration ForeignImportType Ident (Maybe JS) Type
126+ | ExternDeclaration Ident Type
128127 -- |
129128 -- A data type foreign import (name, kind)
130129 --
@@ -255,7 +254,7 @@ data Expr
255254 --
256255 | StringLiteral String
257256 -- |
258− -- A character literal
257+ -- A character literal
259258 --
260259 | CharLiteral Char
261260 -- |
src/Language/PureScript/AST/Exported.hs+1−1
@@ -109,7 +109,7 @@ isExported (Just exps) decl = any (matches decl) exps
109109 where
110110 matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident'
111111 matches (ValueDeclaration ident _ _ _) (ValueRef ident') = ident == ident'
112− matches (ExternDeclaration _ ident _ _) (ValueRef ident') = ident == ident'
112+ matches (ExternDeclaration ident _) (ValueRef ident') = ident == ident'
113113 matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident'
114114 matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'
115115 matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'
src/Language/PureScript/AST/Traversals.hs+1−1
@@ -387,7 +387,7 @@ accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder
387387accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)
388388 where
389389 forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)
390− forDecls (ExternDeclaration _ _ _ ty) = f ty
390+ forDecls (ExternDeclaration _ ty) = f ty
391391 forDecls (ExternInstanceDeclaration _ cs _ tys) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)
392392 forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . snd) implies)
393393 forDecls (TypeInstanceDeclaration _ cs _ tys _) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)
src/Language/PureScript/CodeGen/Externs.hs+4−4
@@ -24,13 +24,13 @@ import qualified Data.Map as M
2424import Control.Monad.Writer
2525
2626import Language.PureScript.AST
27+import Language.PureScript.Comments
2728import Language.PureScript.Environment
2829import Language.PureScript.Kinds
2930import Language.PureScript.Names
3031import Language.PureScript.Pretty
3132import Language.PureScript.TypeClassDictionaries
3233import Language.PureScript.Types
33−import Language.PureScript.Comments
3434
3535-- |
3636-- Generate foreign imports for all declarations in a module
@@ -54,7 +54,7 @@ moduleToPs (Module _ moduleName ds (Just exts)) env = intercalate "\n" . execWri
5454 exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r
5555 exportsOp (ValueRef ident') = ident' == Op op
5656 exportsOp _ = False
57− declToPs (PositionedDeclaration _ com d) = mapM commentToPs com >> declToPs d
57+ declToPs (PositionedDeclaration _ com d) = mapM_ commentToPs com >> declToPs d
5858 declToPs _ = return ()
5959
6060 commentToPs :: Comment -> Writer [String] ()
@@ -63,7 +63,7 @@ moduleToPs (Module _ moduleName ds (Just exts)) env = intercalate "\n" . execWri
6363
6464 exportToPs :: DeclarationRef -> Writer [String] ()
6565 exportToPs (PositionedDeclarationRef _ _ r) = exportToPs r
66− exportToPs (TypeRef pn dctors) = do
66+ exportToPs (TypeRef pn dctors) =
6767 case Qualified (Just moduleName) pn `M.lookup` types env of
6868 Nothing -> error $ show pn ++ " has no kind in exportToPs"
6969 Just (kind, ExternData) ->
@@ -90,7 +90,7 @@ moduleToPs (Module _ moduleName ds (Just exts)) env = intercalate "\n" . execWri
9090 exportToPs (ValueRef ident) =
9191 case (moduleName, ident) `M.lookup` names env of
9292 Nothing -> error $ show ident ++ " has no type in exportToPs"
93− Just (ty, nameKind, _) | nameKind == Value || nameKind == Extern ForeignImport || nameKind == Extern InlineJavascript ->
93+ Just (ty, nk, _) | nk == Public || nk == External ->
9494 tell ["foreign import " ++ show ident ++ " :: " ++ prettyPrintType ty]
9595 _ -> return ()
9696 exportToPs (TypeClassRef className) =
src/Language/PureScript/CodeGen/JS.hs+27−12
@@ -18,14 +18,14 @@
1818{-# LANGUAGE FlexibleContexts #-}
1919{-# LANGUAGE ScopedTypeVariables #-}
2020
21−module Language.PureScript.CodeGen.JS (
22− module AST,
23− module Common,
24− moduleToJs
25−) where
21+module Language.PureScript.CodeGen.JS
22+ ( module AST
23+ , module Common
24+ , moduleToJs
25+ , mainCall
26+ ) where
2627
27−import Data.List ((\\), delete)
28−import Data.Maybe (mapMaybe)
28+import Data.List ((\\), delete, intersect)
2929import qualified Data.Traversable as T (traverse)
3030
3131import Control.Applicative
@@ -49,19 +49,22 @@ import qualified Language.PureScript.Constants as C
4949-- module.
5050--
5151moduleToJs :: forall m mode. (Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)
52− => Module Ann -> m [JS]
53−moduleToJs (Module coms mn imps exps foreigns decls) = do
52+ => Module Ann -> Maybe JS -> m [JS]
53+moduleToJs (Module coms mn imps exps foreigns decls) foreign = do
5454 additional <- asks optionsAdditional
5555 jsImports <- T.traverse importToJs . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ imps
56− let foreigns' = mapMaybe (\(_, js, _) -> js) foreigns
5756 jsDecls <- mapM bindToJs decls
5857 optimized <- T.traverse (T.traverse optimize) jsDecls
5958 let isModuleEmpty = null exps
6059 comments <- not <$> asks optionsNoComments
6160 let strict = JSStringLiteral "use strict"
6261 let header = if comments && not (null coms) then JSComment coms strict else strict
63− let moduleBody = header : jsImports ++ foreigns' ++ concat optimized
64− let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) exps
62+ let foreign' = [JSVariableIntroduction "$foreign" foreign | not $ null foreigns || foreign == Nothing]
63+ let moduleBody = header : foreign' ++ jsImports ++ concat optimized
64+ let foreignExps = exps `intersect` (fst `map` foreigns)
65+ let standardExps = exps \\ foreignExps
66+ let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) standardExps
67+ ++ map (runIdent &&& foreignIdent) foreignExps
6568 return $ case additional of
6669 MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps']
6770 CompileOptions ns _ _ | not isModuleEmpty ->
@@ -171,6 +174,12 @@ moduleToJs (Module coms mn imps exps foreigns decls) = do
171174 unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
172175 unApp (App _ val arg) args = unApp val (arg : args)
173176 unApp other args = (other, args)
177+ valueToJs (Var (_, _, _, Just IsForeign) qi@(Qualified (Just mn') ident)) =
178+ return $ if mn' == mn
179+ then foreignIdent ident
180+ else varToJs qi
181+ valueToJs (Var (_, _, _, Just IsForeign) ident) =
182+ error $ "Encountered an unqualified reference to a foreign ident " ++ show ident
174183 valueToJs (Var _ ident) =
175184 return $ varToJs ident
176185 valueToJs (Case (maybeSpan, _, _, _) values binders) = do
@@ -247,6 +256,9 @@ moduleToJs (Module coms mn imps exps foreigns decls) = do
247256 qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (JSVar (moduleNameToJs mn'))
248257 qualifiedToJS f (Qualified _ a) = JSVar $ identToJs (f a)
249258
259+ foreignIdent :: Ident -> JS
260+ foreignIdent ident = accessorString (runIdent ident) (JSVar "$foreign")
261+
250262 -- |
251263 -- Generate code in the simplified Javascript intermediate representation for pattern match binders
252264 -- and guards.
@@ -352,3 +364,6 @@ moduleToJs (Module coms mn imps exps foreigns decls) = do
352364 done'' <- go done' (index + 1) bs'
353365 js <- binderToJs elVar done'' binder
354366 return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)
367+
368+mainCall :: ModuleName -> String -> JS
369+mainCall mmi ns = JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar ns))) []
src/Language/PureScript/CoreFn/Desugar.hs+13−4
@@ -102,7 +102,7 @@ moduleToCoreFn env (A.Module coms mn decls (Just exps)) =
102102 exprToCoreFn ss com ty (A.App v1 v2) =
103103 App (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing v1) (exprToCoreFn ss [] Nothing v2)
104104 exprToCoreFn ss com ty (A.Var ident) =
105− Var (ss, com, ty, Nothing) ident
105+ Var (ss, com, ty, getValueMeta ident) ident
106106 exprToCoreFn ss com ty (A.IfThenElse v1 v2 v3) =
107107 Case (ss, com, ty, Nothing) [exprToCoreFn ss [] Nothing v1]
108108 [ CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral True]
@@ -167,6 +167,15 @@ moduleToCoreFn env (A.Module coms mn decls (Just exps)) =
167167 binderToCoreFn _ com (A.PositionedBinder ss com1 b) =
168168 binderToCoreFn (Just ss) (com ++ com1) b
169169
170+ -- |
171+ -- Gets metadata for values.
172+ --
173+ getValueMeta :: Qualified Ident -> Maybe Meta
174+ getValueMeta name =
175+ case lookupValue env name of
176+ Just (_, External, _) -> Just IsForeign
177+ _ -> Nothing
178+
170179 -- |
171180 -- Gets metadata for data constructors.
172181 --
@@ -198,7 +207,7 @@ findQualModules decls =
198207 fqValues (A.Var (Qualified (Just mn) _)) = [mn]
199208 fqValues (A.Constructor (Qualified (Just mn) _)) = [mn]
200209 fqValues _ = []
201−
210+
202211 fqBinders :: A.Binder -> [ModuleName]
203212 fqBinders (A.ConstructorBinder (Qualified (Just mn) _) _) = [mn]
204213 fqBinders _ = []
@@ -215,8 +224,8 @@ importToCoreFn _ = Nothing
215224-- Desugars foreign declarations from AST to CoreFn representation.
216225--
217226externToCoreFn :: A.Declaration -> Maybe ForeignDecl
218−externToCoreFn (A.ExternDeclaration _ name js ty) = Just (name, js, ty)
219−externToCoreFn (A.ExternInstanceDeclaration name _ _ _) = Just (name, Nothing, tyObject)
227+externToCoreFn (A.ExternDeclaration name ty) = Just (name, ty)
228+externToCoreFn (A.ExternInstanceDeclaration name _ _ _) = Just (name, tyObject)
220229externToCoreFn (A.PositionedDeclaration _ _ d) = externToCoreFn d
221230externToCoreFn _ = Nothing
222231
src/Language/PureScript/CoreFn/Meta.hs+5−1
@@ -35,7 +35,11 @@ data Meta
3535 -- |
3636 -- The contained value is a typeclass dictionary constructor
3737 --
38− | IsTypeClassConstructor deriving (Show, D.Data, D.Typeable)
38+ | IsTypeClassConstructor
39+ -- |
40+ -- The contained reference is for a foreign member
41+ --
42+ | IsForeign deriving (Show, D.Data, D.Typeable)
3943
4044-- |
4145-- Data constructor metadata
src/Language/PureScript/CoreFn/Module.hs+1−2
@@ -14,7 +14,6 @@
1414
1515module Language.PureScript.CoreFn.Module where
1616
17−import Language.PureScript.CodeGen.JS.AST
1817import Language.PureScript.Comments
1918import Language.PureScript.CoreFn.Expr
2019import Language.PureScript.Names
@@ -29,4 +28,4 @@ data Module a = Module
2928 , moduleDecls :: [Bind a]
3029 } deriving (Show)
3130
32−type ForeignDecl = (Ident, Maybe JS, Type)
31+type ForeignDecl = (Ident, Type)
src/Language/PureScript/DeadCodeElimination.hs+1−1
@@ -50,7 +50,7 @@ bindIdents (Rec names) = map fst names
5050-- Extract the ident for a foreign declaration.
5151--
5252foreignIdent :: ForeignDecl -> Ident
53−foreignIdent (name, _, _) = name
53+foreignIdent = fst
5454
5555-- |
5656-- Key type to use in graph
src/Language/PureScript/Docs/ParseAndDesugar.hs+2−6
@@ -16,14 +16,13 @@ import Control.Monad.IO.Class (MonadIO(..))
1616
1717import Web.Bower.PackageMeta (PackageName)
1818
19−import qualified Text.Parsec as Parsec
2019import qualified Language.PureScript as P
2120import qualified Language.PureScript.Constants as C
2221import Language.PureScript.Docs.Types
2322import Language.PureScript.Docs.Render
2423
2524data ParseDesugarError
26− = ParseError Parsec.ParseError
25+ = ParseError P.MultipleErrors
2726 | SortModulesError P.MultipleErrors
2827 | DesugarError P.MultipleErrors
2928 deriving (Show)
@@ -58,7 +57,7 @@ parseAndDesugar inputFiles depsFiles callback = do
5857 ms <- throwLeft ParseError eParsed
5958
6059 let depsModules = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) ms)
61− let eSorted = P.sortModules . map (importPrim . importPrelude . snd) $ ms
60+ let eSorted = P.sortModules . map (importPrim . snd) $ ms
6261 (ms', _) <- throwLeft SortModulesError eSorted
6362
6463 modules <- throwLeft DesugarError (desugar ms')
@@ -94,9 +93,6 @@ addDefaultImport toImport m@(P.Module coms mn decls exps) =
9493importPrim :: P.Module -> P.Module
9594importPrim = addDefaultImport (P.ModuleName [P.ProperName C.prim])
9695
97−importPrelude :: P.Module -> P.Module
98−importPrelude = addDefaultImport (P.ModuleName [P.ProperName C.prelude])
99−
10096desugar :: [P.Module] -> Either P.MultipleErrors [P.Module]
10197desugar = P.evalSupplyT 0 . desugar'
10298 where
src/Language/PureScript/Docs/Render.hs+2−2
@@ -74,7 +74,7 @@ groupChildren (partitionEithers -> (children, toplevels)) =
7474
7575getDeclarationTitle :: P.Declaration -> Maybe String
7676getDeclarationTitle (P.TypeDeclaration name _) = Just (show name)
77−getDeclarationTitle (P.ExternDeclaration _ name _ _) = Just (show name)
77+getDeclarationTitle (P.ExternDeclaration name _) = Just (show name)
7878getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (show name)
7979getDeclarationTitle (P.ExternDataDeclaration name _) = Just (show name)
8080getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (show name)
@@ -93,7 +93,7 @@ renderDeclaration (P.TypeDeclaration ident' ty) title =
9393 code = ident (show ident')
9494 <> sp <> syntax "::" <> sp
9595 <> renderType ty
96−renderDeclaration (P.ExternDeclaration _ ident' _ ty) title =
96+renderDeclaration (P.ExternDeclaration ident' ty) title =
9797 basicDeclaration title code
9898 where
9999 code = ident (show ident')
src/Language/PureScript/Environment.hs+16−32
@@ -62,19 +62,6 @@ data Environment = Environment {
6262initEnvironment :: Environment
6363initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty M.empty
6464
65−-- |
66−-- The type of a foreign import
67−--
68−data ForeignImportType
69− -- |
70− -- A regular foreign import
71− --
72− = ForeignImport
73− -- |
74− -- A foreign import which contains inline Javascript as a string literal
75− --
76− | InlineJavascript deriving (Show, Eq, Data, Typeable)
77−
7865-- |
7966-- The visibility of a name in scope
8067--
@@ -89,33 +76,23 @@ data NameVisibility
8976 | Defined deriving (Show, Eq)
9077
9178-- |
92−-- The kind of a name
79+-- A flag for whether a name is for an private or public value - only public values will be
80+-- included in a generated externs file.
9381--
9482data NameKind
9583 -- |
96− -- A value introduced as a binding in a module
97− --
98− = Value
99− -- |
100− -- A type class dictionary member accessor import, generated during desugaring of type class declarations
101− --
102− | TypeClassAccessorImport
103− -- |
104− -- A foreign import
105− --
106− | Extern ForeignImportType
107− -- |
108− -- A local name introduced using a lambda abstraction, variable introduction or binder
84+ -- A private value introduced as an artifact of code generation (class instances, class member
85+ -- accessors, etc.)
10986 --
110− | LocalVariable
87+ = Private
11188 -- |
112− -- A data constructor
89+ -- A public value for a module member or foreing import declaration
11390 --
114− | DataConstructor
91+ | Public
11592 -- |
116− -- A type class dictionary, generated during desugaring of type class declarations
93+ -- A name for member introduced by foreign import
11794 --
118− | TypeInstanceDictionaryValue deriving (Show, Eq, Data, Typeable)
95+ | External deriving (Show, Eq, Data, Typeable)
11996
12097-- |
12198-- The kinds of a type
@@ -261,3 +238,10 @@ isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool
261238isNewtypeConstructor e ctor = case lookupConstructor e ctor of
262239 (Newtype, _, _, _) -> True
263240 (Data, _, _, _) -> False
241+
242+-- |
243+-- Finds information about values from the current environment.
244+--
245+lookupValue :: Environment -> Qualified Ident -> Maybe (Type, NameKind, NameVisibility)
246+lookupValue env (Qualified (Just mn) ident) = (mn, ident) `M.lookup` names env
247+lookupValue _ _ = Nothing
src/Language/PureScript/Errors.hs+299−201
@@ -51,7 +51,11 @@ import qualified Text.Parsec as P
5151--
5252data SimpleErrorMessage
5353 = ErrorParsingExterns P.ParseError
54− | ErrorParsingPrelude P.ParseError
54+ | ErrorParsingFFIModule FilePath
55+ | ErrorParsingModule P.ParseError
56+ | MissingFFIModule ModuleName
57+ | MultipleFFIModules ModuleName [FilePath]
58+ | UnnecessaryFFIModule ModuleName FilePath
5559 | InvalidExternsFile FilePath
5660 | CannotGetFileInfo FilePath
5761 | CannotReadFile FilePath
@@ -115,13 +119,12 @@ data SimpleErrorMessage
115119 | TransitiveExportError DeclarationRef [DeclarationRef]
116120 | ShadowedName Ident
117121 | WildcardInferredType Type
118− | PreludeNotPresent
119122 deriving (Show)
120123
121124-- |
122125-- Wrapper of simpler errors
123126--
124−data ErrorMessage
127+data ErrorMessage
125128 = NotYetDefined [Ident] ErrorMessage
126129 | ErrorUnifyingTypes Type Type ErrorMessage
127130 | ErrorInExpression Expr ErrorMessage
@@ -142,10 +145,10 @@ data ErrorMessage
142145 | PositionedError SourceSpan ErrorMessage
143146 | SimpleErrorWrapper SimpleErrorMessage
144147 deriving (Show)
145−
148+
146149instance UnificationError Type ErrorMessage where
147150 occursCheckFailed t = SimpleErrorWrapper $ InfiniteType t
148−
151+
149152instance UnificationError Kind ErrorMessage where
150153 occursCheckFailed k = SimpleErrorWrapper $ InfiniteKind k
151154
@@ -155,7 +158,11 @@ instance UnificationError Kind ErrorMessage where
155158errorCode :: ErrorMessage -> String
156159errorCode em = case unwrapErrorMessage em of
157160 (ErrorParsingExterns _) -> "ErrorParsingExterns"
158− (ErrorParsingPrelude _) -> "ErrorParsingPrelude"
161+ (ErrorParsingFFIModule _) -> "ErrorParsingFFIModule"
162+ (ErrorParsingModule _) -> "ErrorParsingModule"
163+ MissingFFIModule{} -> "MissingFFIModule"
164+ MultipleFFIModules{} -> "MultipleFFIModules"
165+ UnnecessaryFFIModule{} -> "UnnecessaryFFIModule"
159166 (InvalidExternsFile _) -> "InvalidExternsFile"
160167 (CannotGetFileInfo _) -> "CannotGetFileInfo"
161168 (CannotReadFile _) -> "CannotReadFile"
@@ -219,17 +226,16 @@ errorCode em = case unwrapErrorMessage em of
219226 (TransitiveExportError _ _) -> "TransitiveExportError"
220227 (ShadowedName _) -> "ShadowedName"
221228 (WildcardInferredType _) -> "WildcardInferredType"
222− PreludeNotPresent -> "PreludeNotPresent"
223229
224230-- |
225231-- A stack trace for an error
226232--
227−newtype MultipleErrors = MultipleErrors
233+newtype MultipleErrors = MultipleErrors
228234 { runMultipleErrors :: [ErrorMessage] } deriving (Show, Monoid)
229−
235+
230236instance UnificationError Type MultipleErrors where
231237 occursCheckFailed = occursCheckFailed
232−
238+
233239instance UnificationError Kind MultipleErrors where
234240 occursCheckFailed = occursCheckFailed
235241
@@ -288,7 +294,7 @@ unwrapErrorMessage em = case em of
288294 (SimpleErrorWrapper sem) -> sem
289295
290296replaceUnknowns :: Type -> State UnknownMap Type
291−replaceUnknowns = everywhereOnTypesM replaceTypes
297+replaceUnknowns = everywhereOnTypesM replaceTypes
292298 where
293299 lookupTable :: (LabelType, Unknown) -> UnknownMap -> (Unknown, UnknownMap)
294300 lookupTable x m = case M.lookup x m of
@@ -348,195 +354,287 @@ prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessag
348354 where
349355 wikiUri :: String
350356 wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e
351−
357+
352358 go :: ErrorMessage -> Box.Box
353− goSimple (CannotGetFileInfo path) = paras [ line "Unable to read file info: "
354− , indent . line $ path
355− ]
356− goSimple (CannotReadFile path) = paras [ line "Unable to read file: "
357− , indent . line $ path
358− ]
359− goSimple (CannotWriteFile path) = paras [ line "Unable to write file: "
360− , indent . line $ path
361− ]
362− goSimple (ErrorParsingExterns err) = paras [ line "Error parsing externs files: "
363− , indent . line . show $ err
364− ]
365− goSimple (ErrorParsingPrelude err) = paras [ line "Error parsing prelude: "
366− , indent . line . show $ err
367− ]
368− goSimple (InvalidExternsFile path) = paras [ line "Externs file is invalid: "
369− , indent . line $ path
370− ]
371− goSimple InvalidDoBind = line "Bind statement cannot be the last statement in a do block"
372− goSimple InvalidDoLet = line "Let statement cannot be the last statement in a do block"
373− goSimple CannotReorderOperators = line "Unable to reorder operators"
374− goSimple UnspecifiedSkolemScope = line "Skolem variable scope is unspecified"
375− goSimple OverlappingNamesInLet = line "Overlapping names in let binding."
376− goSimple (InfiniteType ty) = paras [ line "Infinite type detected: "
377− , indent $ line $ prettyPrintType ty
378− ]
379− goSimple (InfiniteKind ki) = paras [ line "Infinite kind detected: "
380− , indent $ line $ prettyPrintKind ki
381− ]
382− goSimple (MultipleFixities name) = line $ "Multiple fixity declarations for " ++ show name
383− goSimple (OrphanTypeDeclaration nm) = line $ "Orphan type declaration for " ++ show nm
384− goSimple (OrphanFixityDeclaration op) = line $ "Orphan fixity declaration for " ++ show op
385− goSimple (RedefinedModule name) = line $ "Module " ++ show name ++ " has been defined multiple times"
386− goSimple (RedefinedIdent name) = line $ "Name " ++ show name ++ " has been defined multiple times"
387− goSimple (UnknownModule mn) = line $ "Unknown module " ++ show mn
388− goSimple (UnknownType name) = line $ "Unknown type " ++ show name
389− goSimple (UnknownTypeClass name) = line $ "Unknown type class " ++ show name
390− goSimple (UnknownValue name) = line $ "Unknown value " ++ show name
391− goSimple (UnknownTypeConstructor name) = line $ "Unknown type constructor " ++ show name
392− goSimple (UnknownDataConstructor dc tc) = line $ "Unknown data constructor " ++ show dc ++ foldMap ((" for type constructor " ++) . show) tc
393− goSimple (ConflictingImport nm mn) = line $ "Cannot declare `" ++ nm ++ "` since another declaration of that name was imported from `" ++ show mn ++ "`"
394− goSimple (ConflictingImports nm m1 m2) = line $ "Conflicting imports for " ++ nm ++ " from modules " ++ show m1 ++ " and " ++ show m2
395− goSimple (ConflictingTypeDecls nm) = line $ "Conflicting type declarations for " ++ show nm
396− goSimple (ConflictingCtorDecls nm) = line $ "Conflicting data constructor declarations for " ++ show nm
397− goSimple (TypeConflictsWithClass nm) = line $ "Type " ++ show nm ++ " conflicts with type class declaration of the same name"
398− goSimple (CtorConflictsWithClass nm) = line $ "Data constructor " ++ show nm ++ " conflicts with type class declaration of the same name"
399− goSimple (ClassConflictsWithType nm) = line $ "Type class " ++ show nm ++ " conflicts with type declaration of the same name"
400− goSimple (ClassConflictsWithCtor nm) = line $ "Type class " ++ show nm ++ " conflicts with data constructor declaration of the same name"
401− goSimple (DuplicateClassExport nm) = line $ "Duplicate export declaration for type class " ++ show nm
402− goSimple (DuplicateValueExport nm) = line $ "Duplicate export declaration for value " ++ show nm
403− goSimple (CycleInDeclaration nm) = line $ "Cycle in declaration of " ++ show nm
404− goSimple (CycleInModules mns) = line $ "Cycle in module dependencies: " ++ intercalate ", " (map show mns)
405− goSimple (CycleInTypeSynonym pn) = line $ "Cycle in type synonym" ++ foldMap ((" " ++) . show) pn
406− goSimple (NameIsUndefined ident) = line $ show ident ++ " is undefined"
407− goSimple (NameNotInScope ident) = line $ show ident ++ " may not be defined in the current scope"
408− goSimple (UndefinedTypeVariable name) = line $ "Type variable " ++ show name ++ " is undefined"
409− goSimple (PartiallyAppliedSynonym name) = line $ "Partially applied type synonym " ++ show name
410− goSimple (EscapedSkolem binding) = paras $ [ line "Rigid/skolem type variable has escaped." ]
411− <> foldMap (\expr -> [ line "Relevant expression: "
412− , indent $ line $ prettyPrintValue expr
413− ]) binding
414− goSimple (TypesDoNotUnify t1 t2) = paras [ line "Cannot unify type"
415− , indent $ line $ prettyPrintType t1
416− , line "with type"
417− , indent $ line $ prettyPrintType t2
418− ]
419− goSimple (KindsDoNotUnify k1 k2) = paras [ line "Cannot unify kind"
420− , indent $ line $ prettyPrintKind k1
421− , line "with kind"
422− , indent $ line $ prettyPrintKind k2
423− ]
424− goSimple (ConstrainedTypeUnified t1 t2) = paras [ line "Cannot unify constrained type"
425− , indent $ line $ prettyPrintType t1
426− , line "with type"
427− , indent $ line $ prettyPrintType t2
428− ]
429− goSimple (OverlappingInstances nm ts ds) = paras [ line $ "Overlapping instances found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"
430− , paras $ map prettyPrintDictionaryValue ds
431− ]
432− goSimple (NoInstanceFound nm ts) = line $ "No instance found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts)
433− goSimple (DuplicateLabel l expr) = paras $ [ line $ "Duplicate label " ++ show l ++ " in row." ]
434− <> foldMap (\expr' -> [ line "Relevant expression: "
435− , indent $ line $ prettyPrintValue expr'
436− ]) expr
437− goSimple (DuplicateTypeArgument name) = line $ "Duplicate type argument " ++ show name
438− goSimple (DuplicateValueDeclaration nm) = line $ "Duplicate value declaration for " ++ show nm
439− goSimple (ArgListLengthsDiffer ident) = line $ "Argument list lengths differ in declaration " ++ show ident
440− goSimple (OverlappingArgNames ident) = line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . show) ident
441− goSimple (MissingClassMember ident) = line $ "Member " ++ show ident ++ " has not been implemented"
442− goSimple (ExpectedType kind) = line $ "Expected type of kind *, was " ++ prettyPrintKind kind
443− goSimple (IncorrectConstructorArity nm) = line $ "Wrong number of arguments to constructor " ++ show nm
444− goSimple SubsumptionCheckFailed = line $ "Unable to check type subsumption"
445− goSimple (ExprDoesNotHaveType expr ty) = paras [ line "Expression"
446− , indent $ line $ prettyPrintValue expr
447− , line "does not have type"
448− , indent $ line $ prettyPrintType ty
449− ]
450− goSimple (PropertyIsMissing prop row) = line $ "Row " ++ prettyPrintRow row ++ " lacks required property " ++ show prop
451− goSimple (CannotApplyFunction fn arg) = paras [ line "Cannot apply function of type"
452− , indent $ line $ prettyPrintType fn
453− , line "to argument"
454− , indent $ line $ prettyPrintValue arg
455− ]
456− goSimple TypeSynonymInstance = line "Type synonym instances are disallowed"
457− goSimple InvalidNewtype = line "Newtypes must define a single constructor with a single argument"
458− goSimple (InvalidInstanceHead ty) = paras [ line "Invalid type in class instance head:"
459− , indent $ line $ prettyPrintType ty
460− ]
461− goSimple (TransitiveExportError x ys) = paras $ (line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")
462− : map (line . prettyPrintExport) ys
463− goSimple (ShadowedName nm) = line $ "Name '" ++ show nm ++ "' was shadowed."
464− goSimple (WildcardInferredType ty) = line $ "The wildcard type definition has the inferred type " ++ prettyPrintType ty
465− goSimple PreludeNotPresent = paras [ line $ "There is no Prelude module loaded, and the --no-prelude option was not specified."
466− , line $ "You probably need to install the Prelude and other dependencies using Bower."
467− ]
468− go (NotYetDefined names err) = paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map show names) ++ ":"
469− , indent $ go err
470− ]
471− go (ErrorUnifyingTypes t1 t2 err) = paras [ line "Error unifying type "
472− , indent $ line $ prettyPrintType t1
473− , line "with type"
474− , indent $ line $ prettyPrintType t2
475− , go err
476− ]
477− go (ErrorInExpression expr err) = paras [ line "Error in expression:"
478− , indent $ line $ prettyPrintValue expr
479− , go err
480− ]
481− go (ErrorInModule mn err) = paras [ line $ "Error in module " ++ show mn ++ ":"
482− , go err
483− ]
484− go (ErrorInSubsumption t1 t2 err) = paras [ line "Error checking that type "
485− , indent $ line $ prettyPrintType t1
486− , line "subsumes type"
487− , indent $ line $ prettyPrintType t2
488− , go err
489− ]
490− go (ErrorInInstance name ts err) = paras [ line $ "Error in type class instance " ++ show name ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"
491− , go err
492− ]
493− go (ErrorCheckingKind ty err) = paras [ line "Error checking kind of type "
494− , indent $ line $ prettyPrintType ty
495− , go err
496− ]
497− go (ErrorInferringType expr err) = paras [ line "Error inferring type of value "
498− , indent $ line $ prettyPrintValue expr
499− , go err
500− ]
501− go (ErrorCheckingType expr ty err) = paras [ line "Error checking that value "
502− , indent $ line $ prettyPrintValue expr
503− , line "has type"
504− , indent $ line $ prettyPrintType ty
505− , go err
506− ]
507− go (ErrorInApplication f t a err) = paras [ line "Error applying function"
508− , indent $ line $ prettyPrintValue f
509− , line "of type"
510− , indent $ line $ prettyPrintType t
511− , line "to argument"
512− , indent $ line $ prettyPrintValue a
513− , go err
514− ]
515− go (ErrorInDataConstructor nm err) = paras [ line $ "Error in data constructor " ++ show nm ++ ":"
516− , go err
517− ]
518− go (ErrorInTypeConstructor nm err) = paras [ line $ "Error in type constructor " ++ show nm ++ ":"
519− , go err
520− ]
521− go (ErrorInBindingGroup nms err) = paras [ line $ "Error in binding group " ++ intercalate ", " (map show nms) ++ ":"
522− , go err
523− ]
524− go (ErrorInDataBindingGroup err) = paras [ line $ "Error in data binding group:"
525− , go err
526− ]
527− go (ErrorInTypeSynonym name err) = paras [ line $ "Error in type synonym " ++ show name ++ ":"
528− , go err
529− ]
530− go (ErrorInValueDeclaration n err) = paras [ line $ "Error in value declaration " ++ show n ++ ":"
531− , go err
532− ]
533− go (ErrorInForeignImport nm err) = paras [ line $ "Error in foreign import " ++ show nm ++ ":"
534− , go err
535− ]
536− go (PositionedError srcSpan err) = paras [ line $ "Error at " ++ displaySourceSpan srcSpan ++ ":"
537− , indent $ go err
538− ]
539− go (SimpleErrorWrapper sem) = goSimple sem
359+ goSimple (CannotGetFileInfo path) =
360+ paras [ line "Unable to read file info: "
361+ , indent . line $ path
362+ ]
363+ goSimple (CannotReadFile path) =
364+ paras [ line "Unable to read file: "
365+ , indent . line $ path
366+ ]
367+ goSimple (CannotWriteFile path) =
368+ paras [ line "Unable to write file: "
369+ , indent . line $ path
370+ ]
371+ goSimple (ErrorParsingExterns err) =
372+ paras [ line "Error parsing externs files: "
373+ , indent . line . show $ err
374+ ]
375+ goSimple (ErrorParsingFFIModule path) =
376+ paras [ line "Unable to parse module from FFI file: "
377+ , indent . line $ path
378+ ]
379+ goSimple (ErrorParsingModule err) =
380+ paras [ line "Unable to parse module: "
381+ , indent . line . show $ err
382+ ]
383+ goSimple (MissingFFIModule mn) =
384+ line $ "Missing FFI implementations for module " ++ show mn
385+ goSimple (UnnecessaryFFIModule mn path) =
386+ paras [ line $ "Unnecessary FFI implementations have been provided for module " ++ show mn ++ ": "
387+ , indent . line $ path
388+ ]
389+ goSimple (MultipleFFIModules mn paths) =
390+ paras $ [ line $ "Multiple FFI implementations have been provided for module " ++ show mn ++ ": " ]
391+ ++ map (indent . line) paths
392+ goSimple (InvalidExternsFile path) =
393+ paras [ line "Externs file is invalid: "
394+ , indent . line $ path
395+ ]
396+ goSimple InvalidDoBind =
397+ line "Bind statement cannot be the last statement in a do block"
398+ goSimple InvalidDoLet =
399+ line "Let statement cannot be the last statement in a do block"
400+ goSimple CannotReorderOperators =
401+ line "Unable to reorder operators"
402+ goSimple UnspecifiedSkolemScope =
403+ line "Skolem variable scope is unspecified"
404+ goSimple OverlappingNamesInLet =
405+ line "Overlapping names in let binding."
406+ goSimple (InfiniteType ty) =
407+ paras [ line "Infinite type detected: "
408+ , indent $ line $ prettyPrintType ty
409+ ]
410+ goSimple (InfiniteKind ki) =
411+ paras [ line "Infinite kind detected: "
412+ , indent $ line $ prettyPrintKind ki
413+ ]
414+ goSimple (MultipleFixities name) =
415+ line $ "Multiple fixity declarations for " ++ show name
416+ goSimple (OrphanTypeDeclaration nm) =
417+ line $ "Orphan type declaration for " ++ show nm
418+ goSimple (OrphanFixityDeclaration op) =
419+ line $ "Orphan fixity declaration for " ++ show op
420+ goSimple (RedefinedModule name) =
421+ line $ "Module " ++ show name ++ " has been defined multiple times"
422+ goSimple (RedefinedIdent name) =
423+ line $ "Name " ++ show name ++ " has been defined multiple times"
424+ goSimple (UnknownModule mn) =
425+ line $ "Unknown module " ++ show mn
426+ goSimple (UnknownType name) =
427+ line $ "Unknown type " ++ show name
428+ goSimple (UnknownTypeClass name) =
429+ line $ "Unknown type class " ++ show name
430+ goSimple (UnknownValue name) =
431+ line $ "Unknown value " ++ show name
432+ goSimple (UnknownTypeConstructor name) =
433+ line $ "Unknown type constructor " ++ show name
434+ goSimple (UnknownDataConstructor dc tc) =
435+ line $ "Unknown data constructor " ++ show dc ++ foldMap ((" for type constructor " ++) . show) tc
436+ goSimple (ConflictingImport nm mn) =
437+ line $ "Cannot declare `" ++ nm ++ "` since another declaration of that name was imported from `" ++ show mn ++ "`"
438+ goSimple (ConflictingImports nm m1 m2) =
439+ line $ "Conflicting imports for " ++ nm ++ " from modules " ++ show m1 ++ " and " ++ show m2
440+ goSimple (ConflictingTypeDecls nm) =
441+ line $ "Conflicting type declarations for " ++ show nm
442+ goSimple (ConflictingCtorDecls nm) =
443+ line $ "Conflicting data constructor declarations for " ++ show nm
444+ goSimple (TypeConflictsWithClass nm) =
445+ line $ "Type " ++ show nm ++ " conflicts with type class declaration of the same name"
446+ goSimple (CtorConflictsWithClass nm) =
447+ line $ "Data constructor " ++ show nm ++ " conflicts with type class declaration of the same name"
448+ goSimple (ClassConflictsWithType nm) =
449+ line $ "Type class " ++ show nm ++ " conflicts with type declaration of the same name"
450+ goSimple (ClassConflictsWithCtor nm) =
451+ line $ "Type class " ++ show nm ++ " conflicts with data constructor declaration of the same name"
452+ goSimple (DuplicateClassExport nm) =
453+ line $ "Duplicate export declaration for type class " ++ show nm
454+ goSimple (DuplicateValueExport nm) =
455+ line $ "Duplicate export declaration for value " ++ show nm
456+ goSimple (CycleInDeclaration nm) =
457+ line $ "Cycle in declaration of " ++ show nm
458+ goSimple (CycleInModules mns) =
459+ line $ "Cycle in module dependencies: " ++ intercalate ", " (map show mns)
460+ goSimple (CycleInTypeSynonym pn) =
461+ line $ "Cycle in type synonym" ++ foldMap ((" " ++) . show) pn
462+ goSimple (NameIsUndefined ident) =
463+ line $ show ident ++ " is undefined"
464+ goSimple (NameNotInScope ident) =
465+ line $ show ident ++ " may not be defined in the current scope"
466+ goSimple (UndefinedTypeVariable name) =
467+ line $ "Type variable " ++ show name ++ " is undefined"
468+ goSimple (PartiallyAppliedSynonym name) =
469+ line $ "Partially applied type synonym " ++ show name
470+ goSimple (EscapedSkolem binding) =
471+ paras $ [ line "Rigid/skolem type variable has escaped." ]
472+ <> foldMap (\expr -> [ line "Relevant expression: "
473+ , indent $ line $ prettyPrintValue expr
474+ ]) binding
475+ goSimple (TypesDoNotUnify t1 t2)
476+ = paras [ line "Cannot unify type"
477+ , indent $ line $ prettyPrintType t1
478+ , line "with type"
479+ , indent $ line $ prettyPrintType t2
480+ ]
481+ goSimple (KindsDoNotUnify k1 k2) =
482+ paras [ line "Cannot unify kind"
483+ , indent $ line $ prettyPrintKind k1
484+ , line "with kind"
485+ , indent $ line $ prettyPrintKind k2
486+ ]
487+ goSimple (ConstrainedTypeUnified t1 t2) =
488+ paras [ line "Cannot unify constrained type"
489+ , indent $ line $ prettyPrintType t1
490+ , line "with type"
491+ , indent $ line $ prettyPrintType t2
492+ ]
493+ goSimple (OverlappingInstances nm ts ds) =
494+ paras [ line $ "Overlapping instances found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"
495+ , paras $ map prettyPrintDictionaryValue ds
496+ ]
497+ goSimple (NoInstanceFound nm ts) =
498+ line $ "No instance found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts)
499+ goSimple (DuplicateLabel l expr) =
500+ paras $ [ line $ "Duplicate label " ++ show l ++ " in row." ]
501+ <> foldMap (\expr' -> [ line "Relevant expression: "
502+ , indent $ line $ prettyPrintValue expr'
503+ ]) expr
504+ goSimple (DuplicateTypeArgument name) =
505+ line $ "Duplicate type argument " ++ show name
506+ goSimple (DuplicateValueDeclaration nm) =
507+ line $ "Duplicate value declaration for " ++ show nm
508+ goSimple (ArgListLengthsDiffer ident) =
509+ line $ "Argument list lengths differ in declaration " ++ show ident
510+ goSimple (OverlappingArgNames ident) =
511+ line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . show) ident
512+ goSimple (MissingClassMember ident) =
513+ line $ "Member " ++ show ident ++ " has not been implemented"
514+ goSimple (ExpectedType kind) =
515+ line $ "Expected type of kind *, was " ++ prettyPrintKind kind
516+ goSimple (IncorrectConstructorArity nm) =
517+ line $ "Wrong number of arguments to constructor " ++ show nm
518+ goSimple SubsumptionCheckFailed = line $ "Unable to check type subsumption"
519+ goSimple (ExprDoesNotHaveType expr ty) =
520+ paras [ line "Expression"
521+ , indent $ line $ prettyPrintValue expr
522+ , line "does not have type"
523+ , indent $ line $ prettyPrintType ty
524+ ]
525+ goSimple (PropertyIsMissing prop row) =
526+ line $ "Row " ++ prettyPrintRow row ++ " lacks required property " ++ show prop
527+ goSimple (CannotApplyFunction fn arg) =
528+ paras [ line "Cannot apply function of type"
529+ , indent $ line $ prettyPrintType fn
530+ , line "to argument"
531+ , indent $ line $ prettyPrintValue arg
532+ ]
533+ goSimple TypeSynonymInstance =
534+ line "Type synonym instances are disallowed"
535+ goSimple InvalidNewtype =
536+ line "Newtypes must define a single constructor with a single argument"
537+ goSimple (InvalidInstanceHead ty) =
538+ paras [ line "Invalid type in class instance head:"
539+ , indent $ line $ prettyPrintType ty
540+ ]
541+ goSimple (TransitiveExportError x ys) =
542+ paras $ (line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")
543+ : map (line . prettyPrintExport) ys
544+ goSimple (ShadowedName nm) =
545+ line $ "Name '" ++ show nm ++ "' was shadowed."
546+ goSimple (WildcardInferredType ty) =
547+ line $ "The wildcard type definition has the inferred type " ++ prettyPrintType ty
548+ go (NotYetDefined names err) =
549+ paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map show names) ++ ":"
550+ , indent $ go err
551+ ]
552+ go (ErrorUnifyingTypes t1 t2 err) =
553+ paras [ line "Error unifying type "
554+ , indent $ line $ prettyPrintType t1
555+ , line "with type"
556+ , indent $ line $ prettyPrintType t2
557+ , go err
558+ ]
559+ go (ErrorInExpression expr err) =
560+ paras [ line "Error in expression:"
561+ , indent $ line $ prettyPrintValue expr
562+ , go err
563+ ]
564+ go (ErrorInModule mn err) =
565+ paras [ line $ "Error in module " ++ show mn ++ ":"
566+ , go err
567+ ]
568+ go (ErrorInSubsumption t1 t2 err) =
569+ paras [ line "Error checking that type "
570+ , indent $ line $ prettyPrintType t1
571+ , line "subsumes type"
572+ , indent $ line $ prettyPrintType t2
573+ , go err
574+ ]
575+ go (ErrorInInstance name ts err) =
576+ paras [ line $ "Error in type class instance " ++ show name ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"
577+ , go err
578+ ]
579+ go (ErrorCheckingKind ty err) =
580+ paras [ line "Error checking kind of type "
581+ , indent $ line $ prettyPrintType ty
582+ , go err
583+ ]
584+ go (ErrorInferringType expr err) =
585+ paras [ line "Error inferring type of value "
586+ , indent $ line $ prettyPrintValue expr
587+ , go err
588+ ]
589+ go (ErrorCheckingType expr ty err) =
590+ paras [ line "Error checking that value "
591+ , indent $ line $ prettyPrintValue expr
592+ , line "has type"
593+ , indent $ line $ prettyPrintType ty
594+ , go err
595+ ]
596+ go (ErrorInApplication f t a err) =
597+ paras [ line "Error applying function"
598+ , indent $ line $ prettyPrintValue f
599+ , line "of type"
600+ , indent $ line $ prettyPrintType t
601+ , line "to argument"
602+ , indent $ line $ prettyPrintValue a
603+ , go err
604+ ]
605+ go (ErrorInDataConstructor nm err) =
606+ paras [ line $ "Error in data constructor " ++ show nm ++ ":"
607+ , go err
608+ ]
609+ go (ErrorInTypeConstructor nm err) =
610+ paras [ line $ "Error in type constructor " ++ show nm ++ ":"
611+ , go err
612+ ]
613+ go (ErrorInBindingGroup nms err) =
614+ paras [ line $ "Error in binding group " ++ intercalate ", " (map show nms) ++ ":"
615+ , go err
616+ ]
617+ go (ErrorInDataBindingGroup err) =
618+ paras [ line $ "Error in data binding group:"
619+ , go err
620+ ]
621+ go (ErrorInTypeSynonym name err) =
622+ paras [ line $ "Error in type synonym " ++ show name ++ ":"
623+ , go err
624+ ]
625+ go (ErrorInValueDeclaration n err) =
626+ paras [ line $ "Error in value declaration " ++ show n ++ ":"
627+ , go err
628+ ]
629+ go (ErrorInForeignImport nm err) =
630+ paras [ line $ "Error in foreign import " ++ show nm ++ ":"
631+ , go err
632+ ]
633+ go (PositionedError srcSpan err) =
634+ paras [ line $ "Error at " ++ displaySourceSpan srcSpan ++ ":"
635+ , indent $ go err
636+ ]
637+ go (SimpleErrorWrapper sem) = goSimple sem
540638
541639 line :: String -> Box.Box
542640 line = Box.text
@@ -570,10 +668,10 @@ prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessag
570668 prettyPrintDictionaryValue (SubclassDictionaryValue sup nm _) = paras [ line $ (show nm) ++ " via superclass"
571669 , indent $ prettyPrintDictionaryValue sup
572670 ]
573−
671+
574672 -- |
575673 -- Pretty print and export declaration
576− --
674+ --
577675 prettyPrintExport :: DeclarationRef -> String
578676 prettyPrintExport (TypeRef pn _) = show pn
579677 prettyPrintExport (ValueRef ident) = show ident
src/Language/PureScript/Linter.hs+8−8
@@ -39,35 +39,35 @@ lint (Module _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_ li
3939 where
4040 moduleNames :: S.Set Ident
4141 moduleNames = S.fromList (nub (mapMaybe getDeclIdent ds))
42−
42+
4343 getDeclIdent :: Declaration -> Maybe Ident
4444 getDeclIdent (PositionedDeclaration _ _ d) = getDeclIdent d
4545 getDeclIdent (ValueDeclaration ident _ _ _) = Just ident
46− getDeclIdent (ExternDeclaration _ ident _ _) = Just ident
46+ getDeclIdent (ExternDeclaration ident _) = Just ident
4747 getDeclIdent (ExternInstanceDeclaration ident _ _ _) = Just ident
4848 getDeclIdent (TypeInstanceDeclaration ident _ _ _ _) = Just ident
4949 getDeclIdent (BindingGroupDeclaration _) = error "lint: binding groups should not be desugared yet."
5050 getDeclIdent _ = Nothing
5151
5252 lintDeclaration :: Declaration -> m ()
53− lintDeclaration d =
53+ lintDeclaration d =
5454 let (f, _, _, _, _) = everythingWithContextOnValues moduleNames mempty mappend def stepE stepB def def
5555 in tell (f d)
5656 where
5757 def s _ = (s, mempty)
58−
58+
5959 stepE :: S.Set Ident -> Expr -> (S.Set Ident, MultipleErrors)
6060 stepE s (Abs (Left name) _) = bind s name
61− stepE s (Let ds' _) =
61+ stepE s (Let ds' _) =
6262 case mapAccumL bind s (nub (mapMaybe getDeclIdent ds')) of
6363 (s', es) -> (s', mconcat es)
6464 stepE s _ = (s, mempty)
65−
65+
6666 stepB :: S.Set Ident -> Binder -> (S.Set Ident, MultipleErrors)
6767 stepB s (VarBinder name) = bind s name
6868 stepB s (NamedBinder name _) = bind s name
6969 stepB s _ = (s, mempty)
70−
70+
7171 bind :: S.Set Ident -> Ident -> (S.Set Ident, MultipleErrors)
7272 bind s name | name `S.member` s = (s, errorMessage (ShadowedName name))
73− | otherwise = (S.insert name s, mempty)
73+ | otherwise = (S.insert name s, mempty)
src/Language/PureScript/Options.hs+3−7
@@ -44,14 +44,10 @@ deriving instance Show (ModeOptions mode)
4444-- The data type of compiler options
4545--
4646data Options mode = Options {
47− -- |
48− -- Disable inclusion of the built in Prelude
49− --
50− optionsNoPrelude :: Bool
5147 -- |
5248 -- Disable tail-call elimination
5349 --
54− , optionsNoTco :: Bool
50+ optionsNoTco :: Bool
5551 -- |
5652 -- Disable inlining of calls to return and bind for the Eff monad
5753 --
@@ -83,10 +79,10 @@ data Options mode = Options {
8379-- Default compiler options
8480--
8581defaultCompileOptions :: Options Compile
86−defaultCompileOptions = Options False False False Nothing False False False (CompileOptions "PS" [] [])
82+defaultCompileOptions = Options False False Nothing False False False (CompileOptions "PS" [] [])
8783
8884-- |
8985-- Default make options
9086--
9187defaultMakeOptions :: Options Make
92−defaultMakeOptions = Options False False False Nothing False False False MakeOptions
88+defaultMakeOptions = Options False False Nothing False False False MakeOptions
src/Language/PureScript/Parser.hs+1
@@ -33,3 +33,4 @@ import Language.PureScript.Parser.State as P
3333import Language.PureScript.Parser.Kinds as P
3434import Language.PureScript.Parser.Lexer as P
3535import Language.PureScript.Parser.Declarations as P
36+import Language.PureScript.Parser.JS as P
src/Language/PureScript/Parser/Declarations.hs+30−23
@@ -13,6 +13,8 @@
1313--
1414-----------------------------------------------------------------------------
1515
16+{-# LANGUAGE FlexibleContexts #-}
17+{-# LANGUAGE ScopedTypeVariables #-}
1618{-# LANGUAGE TupleSections #-}
1719
1820module Language.PureScript.Parser.Declarations (
@@ -30,22 +32,22 @@ module Language.PureScript.Parser.Declarations (
3032
3133import Prelude hiding (lex)
3234
33−import Data.Maybe (isJust, fromMaybe)
34−import Data.Traversable (forM)
35+import Data.Maybe (fromMaybe)
3536
3637import Control.Applicative
3738import Control.Arrow ((+++))
39+import Control.Monad.Error.Class (MonadError(..))
3840
39−import Language.PureScript.Kinds
4041import Language.PureScript.AST
4142import Language.PureScript.Comments
43+import Language.PureScript.Environment
44+import Language.PureScript.Errors
45+import Language.PureScript.Kinds
46+import Language.PureScript.Names
4247import Language.PureScript.Parser.Common
43−import Language.PureScript.Parser.Types
4448import Language.PureScript.Parser.Kinds
4549import Language.PureScript.Parser.Lexer
46−import Language.PureScript.Names
47−import Language.PureScript.CodeGen.JS.AST
48−import Language.PureScript.Environment
50+import Language.PureScript.Parser.Types
4951
5052import qualified Language.PureScript.Parser.Common as C
5153import qualified Text.Parsec as P
@@ -99,7 +101,7 @@ parseValueDeclaration = do
99101 <*> (indented *> equals *> parseValueWithWhereClause)
100102 ))
101103 <|> Right <$> (indented *> equals *> parseValueWithWhereClause)
102− return $ ValueDeclaration name Value binders value
104+ return $ ValueDeclaration name Public binders value
103105 where
104106 parseValueWithWhereClause :: TokenParser Expr
105107 parseValueWithWhereClause = do
@@ -118,17 +120,19 @@ parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "imp
118120 <|> (do reserved "instance"
119121 name <- parseIdent <* indented <* doubleColon
120122 deps <- P.option [] $ do
121− deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))
123+ deps' <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))
122124 indented
123125 rfatArrow
124− return deps
126+ return deps'
125127 className <- indented *> parseQualified properName
126128 tys <- P.many (indented *> noWildcards parseTypeAtom)
127129 return $ ExternInstanceDeclaration name deps className tys)
128130 <|> (do ident <- parseIdent
129− js <- P.optionMaybe (JSRaw <$> stringLiteral)
131+ -- TODO: add a wiki page link with migration info
132+ -- TODO: remove this deprecation warning in 0.8
133+ _ <- P.optional $ stringLiteral *> featureWasRemoved "Inline foreign string literals are no longer supported."
130134 ty <- indented *> doubleColon *> noWildcards parsePolyType
131− return $ ExternDeclaration (if isJust js then InlineJavascript else ForeignImport) ident js ty))
135+ return $ ExternDeclaration ident ty))
132136
133137parseAssociativity :: TokenParser Associativity
134138parseAssociativity =
@@ -151,7 +155,7 @@ parseImportDeclaration = do
151155 (mn, declType, asQ) <- parseImportDeclaration'
152156 return $ ImportDeclaration mn declType asQ
153157
154−parseImportDeclaration' :: TokenParser (ModuleName, ImportDeclarationType, (Maybe ModuleName))
158+parseImportDeclaration' :: TokenParser (ModuleName, ImportDeclarationType, Maybe ModuleName)
155159parseImportDeclaration' = do
156160 reserved "import"
157161 indented
@@ -177,7 +181,7 @@ parseImportDeclaration' = do
177181 asQ <- moduleName
178182 return (moduleName', declType, Just asQ)
179183 importDeclarationType expectedType = do
180− idents <- P.optionMaybe $ indented *> (parens $ commaSep parseDeclarationRef)
184+ idents <- P.optionMaybe $ indented *> parens (commaSep parseDeclarationRef)
181185 return $ fromMaybe Implicit (expectedType <$> idents)
182186
183187
@@ -213,14 +217,14 @@ parseTypeInstanceDeclaration = do
213217 rfatArrow
214218 return deps
215219 className <- indented *> parseQualified properName
216− ty <- P.many (indented *> (noWildcards parseTypeAtom))
220+ ty <- P.many (indented *> noWildcards parseTypeAtom)
217221 members <- P.option [] . P.try $ do
218222 indented *> reserved "where"
219223 mark (P.many (same *> positioned parseValueDeclaration))
220224 return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty members
221225
222226positioned :: TokenParser Declaration -> TokenParser Declaration
223−positioned d = withSourceSpan PositionedDeclaration d
227+positioned = withSourceSpan PositionedDeclaration
224228
225229-- |
226230-- Parse a single declaration
@@ -261,14 +265,18 @@ parseModule = do
261265-- |
262266-- Parse a collection of modules
263267--
264−parseModulesFromFiles :: (k -> String) -> [(k, String)] -> Either P.ParseError [(k, Module)]
265−parseModulesFromFiles toFilePath input =
266− fmap collect . forM input $ \(k, content) -> do
268+parseModulesFromFiles :: forall m k. (MonadError MultipleErrors m, Functor m) =>
269+ (k -> String) -> [(k, String)] -> m [(k, Module)]
270+parseModulesFromFiles toFilePath input = do
271+ modules <- parU input $ \(k, content) -> do
267272 let filename = toFilePath k
268− ts <- lex filename content
269− ms <- runTokenParser filename parseModules ts
273+ ts <- wrapError $ lex filename content
274+ ms <- wrapError $ runTokenParser filename parseModules ts
270275 return (k, ms)
276+ return $ collect modules
271277 where
278+ wrapError :: Either P.ParseError a -> m a
279+ wrapError = either (throwError . errorMessage . ErrorParsingModule) return
272280 collect :: [(k, [v])] -> [(k, v)]
273281 collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ]
274282
@@ -527,10 +535,9 @@ parseBinderNoParens = P.choice (map P.try
527535 , parseObjectBinder
528536 , parseArrayBinder
529537 , parens parseBinder ]) P.<?> "binder"
538+
530539-- |
531540-- Parse a guard
532541--
533542parseGuard :: TokenParser Guard
534543parseGuard = pipe *> C.indented *> parseValue
535−
536−
src/Language/PureScript/Parser/JS.hsnew file+59
@@ -0,0 +1,59 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Foreign
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE FlexibleContexts #-}
16+
17+module Language.PureScript.Parser.JS
18+ ( ForeignJS()
19+ , parseForeignModulesFromFiles
20+ ) where
21+
22+import Control.Applicative ((*>), (<*))
23+import Control.Monad (forM_, when, msum)
24+import Control.Monad.Error.Class (MonadError(..))
25+import Control.Monad.Writer.Class (MonadWriter(..))
26+import Data.Function (on)
27+import Data.List (sortBy, groupBy)
28+import Language.PureScript.Errors
29+import Language.PureScript.Names
30+import Language.PureScript.Parser.Common
31+import Language.PureScript.Parser.Lexer
32+import Prelude hiding (lex)
33+import qualified Data.Map as M
34+import qualified Text.Parsec as PS
35+
36+type ForeignJS = String
37+
38+parseForeignModulesFromFiles :: (Functor m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
39+ => [(FilePath, ForeignJS)]
40+ -> m (M.Map ModuleName (FilePath, ForeignJS))
41+parseForeignModulesFromFiles files = do
42+ foreigns <- parU files $ \(path, file) ->
43+ case findModuleName (lines file) of
44+ Just name -> return (name, (path, file))
45+ Nothing -> throwError (errorMessage $ ErrorParsingFFIModule path)
46+ let grouped = groupBy ((==) `on` fst) $ sortBy (compare `on` fst) foreigns
47+ forM_ grouped $ \grp ->
48+ when (length grp > 1) $ do
49+ let mn = fst (head grp)
50+ paths = map (fst . snd) grp
51+ tell $ errorMessage $ MultipleFFIModules mn paths
52+ return $ M.fromList foreigns
53+
54+findModuleName :: [String] -> Maybe ModuleName
55+findModuleName = msum . map parseComment
56+ where
57+ parseComment :: String -> Maybe ModuleName
58+ parseComment s = either (const Nothing) Just $
59+ lex "" s >>= runTokenParser "" (symbol' "//" *> reserved "module" *> moduleName <* PS.eof)
src/Language/PureScript/Sugar/CaseDeclarations.hs+9−9
@@ -101,7 +101,7 @@ toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs =
101101 isVarBinder (VarBinder _) = True
102102 isVarBinder (PositionedBinder _ _ b) = isVarBinder b
103103 isVarBinder _ = False
104−
104+
105105 fromVarBinder :: Binder -> m Ident
106106 fromVarBinder NullBinder = Ident <$> freshName
107107 fromVarBinder (VarBinder name) = return name
@@ -129,17 +129,17 @@ makeCaseDeclaration :: forall m. (Functor m, Applicative m, MonadSupply m, Monad
129129makeCaseDeclaration ident alternatives = do
130130 let namedArgs = map findName . fst <$> alternatives
131131 argNames = map join $ foldl1 resolveNames namedArgs
132− args <- if allUnique (catMaybes argNames)
133− then mapM argName argNames
132+ args <- if allUnique (catMaybes argNames)
133+ then mapM argName argNames
134134 else replicateM (length argNames) (Ident <$> freshName)
135135 let vars = map (Var . Qualified Nothing) args
136136 binders = [ CaseAlternative bs result | (bs, result) <- alternatives ]
137137 value = foldr (Abs . Left) (Case vars binders) args
138− return $ ValueDeclaration ident Value [] (Right value)
138+ return $ ValueDeclaration ident Public [] (Right value)
139139 where
140140 -- We will construct a table of potential names.
141141 -- VarBinders will become Just (Just _) which is a potential name.
142− -- NullBinder will become Just Nothing, which indicates that we may
142+ -- NullBinder will become Just Nothing, which indicates that we may
143143 -- have to generate a name.
144144 -- Everything else becomes Nothing, which indicates that we definitely
145145 -- have to generate a name.
@@ -162,15 +162,15 @@ makeCaseDeclaration ident alternatives = do
162162
163163 -- Combine two lists of potential names from two case alternatives
164164 -- by zipping correspoding columns.
165− resolveNames :: [Maybe (Maybe Ident)] ->
166− [Maybe (Maybe Ident)] ->
165+ resolveNames :: [Maybe (Maybe Ident)] ->
166+ [Maybe (Maybe Ident)] ->
167167 [Maybe (Maybe Ident)]
168168 resolveNames = zipWith resolveName
169169
170170 -- Resolve a pair of names. VarBinder beats NullBinder, and everything
171171 -- else results in Nothing.
172− resolveName :: Maybe (Maybe Ident) ->
173− Maybe (Maybe Ident) ->
172+ resolveName :: Maybe (Maybe Ident) ->
173+ Maybe (Maybe Ident) ->
174174 Maybe (Maybe Ident)
175175 resolveName (Just (Just a)) (Just (Just b))
176176 | a == b = Just (Just a)
src/Language/PureScript/Sugar/Names.hs+3−3
@@ -226,8 +226,8 @@ renameInModule imports exports (Module coms mn decls exps) =
226226 (,) (pos, bound) <$> (ExternInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn Nothing <*> mapM (updateTypesEverywhere pos) ts)
227227 updateDecl (pos, bound) (TypeDeclaration name ty) =
228228 (,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty)
229− updateDecl (pos, bound) (ExternDeclaration fit name js ty) =
230− (,) (pos, name : bound) <$> (ExternDeclaration fit name js <$> updateTypesEverywhere pos ty)
229+ updateDecl (pos, bound) (ExternDeclaration name ty) =
230+ (,) (pos, name : bound) <$> (ExternDeclaration name <$> updateTypesEverywhere pos ty)
231231 updateDecl s d = return (s, d)
232232
233233 updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> m ((Maybe SourceSpan, [Ident]), Expr)
@@ -337,7 +337,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) pri
337337 addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []
338338 addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []
339339 addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name
340− addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name
340+ addDecl mn env (ExternDeclaration name _) = addValue env mn name
341341 addDecl mn env (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ addDecl mn env d
342342 addDecl _ env _ = return env
343343
src/Language/PureScript/Sugar/TypeClasses.hs+3−3
@@ -59,7 +59,7 @@ desugarModule (Module coms name decls (Just exps)) = do
5959 return $ Module coms name (concat declss) $ Just (exps ++ catMaybes newExpss)
6060 where
6161 classesFirst :: Declaration -> Declaration -> Ordering
62− classesFirst d1 d2
62+ classesFirst d1 d2
6363 | isTypeClassDeclaration d1 && not (isTypeClassDeclaration d2) = LT
6464 | not (isTypeClassDeclaration d1) && isTypeClassDeclaration d2 = GT
6565 | otherwise = EQ
@@ -219,7 +219,7 @@ typeClassDictionaryDeclaration name args implies members =
219219typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Declaration -> Declaration
220220typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
221221 let className = Qualified (Just mn) name
222− in ValueDeclaration ident TypeClassAccessorImport [] $ Right $
222+ in ValueDeclaration ident Private [] $ Right $
223223 TypedValue False (TypeClassDictionaryAccessor className ident) $
224224 moveQuantifiersToFront (quantify (ConstrainedType [(className, map (TypeVar . fst) args)] ty))
225225typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com d) =
@@ -264,7 +264,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
264264 dictTy = foldl TypeApp (TypeConstructor className) tys
265265 constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)
266266 dict = TypeClassDictionaryConstructorApp className props
267− result = ValueDeclaration name TypeInstanceDictionaryValue [] (Right (TypedValue True dict constrainedTy))
267+ result = ValueDeclaration name Private [] (Right (TypedValue True dict constrainedTy))
268268 return result
269269
270270 where
src/Language/PureScript/TypeChecker.hs+2−2
@@ -207,14 +207,14 @@ typeCheckAll mainModuleName moduleName exps = go
207207 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) }
208208 ds <- go rest
209209 return $ d : ds
210− go (d@(ExternDeclaration importTy name _ ty) : rest) = do
210+ go (d@(ExternDeclaration name ty) : rest) = do
211211 rethrow (onErrorMessages (ErrorInForeignImport name)) $ do
212212 env <- getEnv
213213 kind <- kindOf moduleName ty
214214 guardWith (errorMessage (ExpectedType kind)) $ kind == Star
215215 case M.lookup (moduleName, name) (names env) of
216216 Just _ -> throwError . errorMessage $ RedefinedIdent name
217− Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy, Defined) (names env) })
217+ Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) })
218218 ds <- go rest
219219 return $ d : ds
220220 go (d@(FixityDeclaration _ name) : rest) = do
src/Language/PureScript/TypeChecker/Monad.hs+2−2
@@ -86,7 +86,7 @@ getTypeClassDictionaries = M.elems . typeClassDictionaries . checkEnv <$> get
8686--
8787bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type, NameVisibility)] -> m a -> m a
8888bindLocalVariables moduleName bindings =
89− bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> ((moduleName, name), (ty, LocalVariable, visibility)))
89+ bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> ((moduleName, name), (ty, Private, visibility)))
9090
9191-- |
9292-- Temporarily bind a collection of names to local type variables
@@ -98,7 +98,7 @@ bindLocalTypeVariables moduleName bindings =
9898-- |
9999-- Update the visibility of all names to Defined
100100--
101−makeBindingGroupVisible :: (Functor m, MonadState CheckState m) => m ()
101+makeBindingGroupVisible :: (Functor m, MonadState CheckState m) => m ()
102102makeBindingGroupVisible = modifyEnv $ \e -> e { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names e) }
103103
104104-- | Update the visibility of all names to Defined in the scope of the provided action
src/Language/PureScript/TypeChecker/Types.hs+2−2
@@ -127,7 +127,7 @@ typeDictionaryForBindingGroup moduleName vals = do
127127 -- Make a map of names to the unification variables of untyped declarations
128128 untypedDict = zip (map fst untyped) untypedNames
129129 -- Create the dictionary of all name/type pairs, which will be added to the environment during type checking
130− dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable, Undefined))) $ typedDict ++ untypedDict)
130+ dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, Private, Undefined))) $ typedDict ++ untypedDict)
131131 return (untyped, typed, dict, untypedDict)
132132
133133checkTypedBindingGroupElement :: ModuleName -> (Ident, (Expr, Type, Bool)) -> TypeData -> UnifyT Type Check (Ident, (Expr, Type))
@@ -325,7 +325,7 @@ inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
325325 (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)
326326 ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict
327327 ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict
328− let ds' = [(ident, LocalVariable, val') | (ident, (val', _)) <- ds1' ++ ds2']
328+ let ds' = [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2']
329329 bindNames dict $ do
330330 makeBindingGroupVisible
331331 inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j
tests/Main.hs+37−28
@@ -12,7 +12,7 @@
1212--
1313-----------------------------------------------------------------------------
1414
15−{-# LANGUAGE DataKinds, DoAndIfThenElse #-}
15+{-# LANGUAGE DataKinds, DoAndIfThenElse, TupleSections #-}
1616
1717module Main (main) where
1818
@@ -20,15 +20,22 @@ import qualified Language.PureScript as P
2020
2121import Data.List (isSuffixOf)
2222import Data.Traversable (traverse)
23+
24+import qualified Data.Map as M
25+
2326import Control.Monad
27+import Control.Monad.IO.Class (liftIO)
2428import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
2529import Control.Monad.Reader (runReaderT)
2630import Control.Monad.Writer (runWriterT)
31+import Control.Monad.Trans.Except (runExceptT)
2732import Control.Applicative
33+
2834import System.Exit
2935import System.Process
3036import System.FilePath ((</>))
3137import System.Directory (getCurrentDirectory, getTemporaryDirectory, getDirectoryContents, findExecutable)
38+
3239import Text.Parsec (ParseError)
3340
3441readInput :: [FilePath] -> IO [(FilePath, String)]
@@ -36,36 +43,33 @@ readInput inputFiles = forM inputFiles $ \inputFile -> do
3643 text <- readFile inputFile
3744 return (inputFile, text)
3845
39−loadPrelude :: [(FilePath, String)] -> Either P.MultipleErrors (String, String, P.Environment)
40−loadPrelude ms =
41− case P.parseModulesFromFiles id ms of
42− Left parseError -> Left . P.errorMessage . P.ErrorParsingPrelude $ parseError
43− Right ms -> fmap fst . runWriterT $ runReaderT (P.compile (map snd ms) []) (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] })
44−
45−compile :: P.Options P.Compile -> [FilePath] -> IO (Either P.MultipleErrors (String, String, P.Environment))
46−compile opts inputFiles = do
47− modules <- P.parseModulesFromFiles id <$> readInput inputFiles
48− case modules of
49− Left parseError ->
50− return . Left . P.errorMessage . P.ErrorParsingPrelude $ parseError
51− Right ms -> return $ fmap fst . runWriterT $ runReaderT (P.compile (map snd ms) []) opts
52−
53−assert :: FilePath -> P.Options P.Compile -> FilePath -> (Either P.MultipleErrors (String, String, P.Environment) -> IO (Maybe String)) -> IO ()
54−assert preludeExterns opts inputFile f = do
55− e <- compile opts [preludeExterns, inputFile]
46+loadPrelude :: [(FilePath, String)] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> Either P.MultipleErrors (String, String, P.Environment)
47+loadPrelude fs foreigns = do
48+ ms <- P.parseModulesFromFiles id fs
49+ fmap fst . runWriterT $ runReaderT (P.compileJS (map snd ms) foreigns []) (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] })
50+
51+compile :: P.Options P.Compile -> [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO (Either P.MultipleErrors (String, String, P.Environment))
52+compile opts inputFiles foreigns = runExceptT . fmap fst . runWriterT . flip runReaderT opts $ do
53+ fs <- liftIO $ readInput inputFiles
54+ ms <- P.parseModulesFromFiles id fs
55+ P.compileJS (map snd ms) foreigns []
56+
57+assert :: FilePath -> P.Options P.Compile -> FilePath -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> (Either P.MultipleErrors (String, String, P.Environment) -> IO (Maybe String)) -> IO ()
58+assert preludeExterns opts inputFile foreigns f = do
59+ e <- compile opts [preludeExterns, inputFile] foreigns
5660 maybeErr <- f e
5761 case maybeErr of
5862 Just err -> putStrLn err >> exitFailure
5963 Nothing -> return ()
6064
61−assertCompiles :: String -> FilePath -> FilePath -> IO ()
62−assertCompiles preludeJs preludeExterns inputFile = do
65+assertCompiles :: String -> FilePath -> FilePath -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO ()
66+assertCompiles preludeJs preludeExterns inputFile foreigns = do
6367 putStrLn $ "Assert " ++ inputFile ++ " compiles successfully"
6468 let options = P.defaultCompileOptions
6569 { P.optionsMain = Just "Main"
6670 , P.optionsAdditional = P.CompileOptions "Tests" ["Main"] ["Main"]
6771 }
68− assert preludeExterns options inputFile $ either (return . Just . P.prettyPrintMultipleErrors False) $ \(js, _, _) -> do
72+ assert preludeExterns options inputFile foreigns $ either (return . Just . P.prettyPrintMultipleErrors False) $ \(js, _, _) -> do
6973 process <- findNodeProcess
7074 result <- traverse (\node -> readProcessWithExitCode node [] (preludeJs ++ js)) process
7175 case result of
@@ -73,10 +77,10 @@ assertCompiles preludeJs preludeExterns inputFile = do
7377 Just (ExitFailure _, _, err) -> return $ Just err
7478 Nothing -> return $ Just "Couldn't find node.js executable"
7579
76−assertDoesNotCompile :: FilePath -> FilePath -> IO ()
77−assertDoesNotCompile preludeExterns inputFile = do
80+assertDoesNotCompile :: FilePath -> FilePath -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO ()
81+assertDoesNotCompile preludeExterns inputFile foreigns = do
7882 putStrLn $ "Assert " ++ inputFile ++ " does not compile"
79− assert preludeExterns (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }) inputFile $ \e ->
83+ assert preludeExterns (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }) inputFile foreigns $ \e ->
8084 case e of
8185 Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> return Nothing
8286 Right _ -> return $ Just "Should not have compiled"
@@ -89,9 +93,14 @@ findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names
8993main :: IO ()
9094main = do
9195 cwd <- getCurrentDirectory
92− prelude <- readInput [cwd </> "tests" </> "prelude.purs"]
96+ let preludeDir = cwd </> "tests" </> "prelude"
97+ jsDir = preludeDir </> "js"
98+ prelude <- readInput [preludeDir </> "Prelude.purs"]
99+ jsFiles <- map (jsDir </>) . filter (".js" `isSuffixOf`) <$> getDirectoryContents jsDir
100+ foreignFiles <- forM jsFiles (\f -> (f,) <$> readFile f)
101+ Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles
93102 putStrLn "Compiling Prelude"
94− case loadPrelude prelude of
103+ case loadPrelude prelude foreigns of
95104 Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure
96105 Right (preludeJs, exts, _) -> do
97106 tmp <- getTemporaryDirectory
@@ -101,9 +110,9 @@ main = do
101110 let passing = cwd </> "examples" </> "passing"
102111 passingTestCases <- getDirectoryContents passing
103112 forM_ passingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $
104− assertCompiles preludeJs preludeExterns (passing </> inputFile)
113+ assertCompiles preludeJs preludeExterns (passing </> inputFile) foreigns
105114 let failing = cwd </> "examples" </> "failing"
106115 failingTestCases <- getDirectoryContents failing
107116 forM_ failingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $
108− assertDoesNotCompile preludeExterns (failing </> inputFile)
117+ assertDoesNotCompile preludeExterns (failing </> inputFile) foreigns
109118 exitSuccess
tests/prelude.pursdeleted−1068
@@ -1,1068 +0,0 @@
1−-- | This snapshot is provided for the purposes of running the test suite.
2−-- | It is not necessarily kept up to date with the official PureScript Prelude,
3−-- | and should not be used in user code.
4−-- | The official Prelude can be found at https://github.com/purescript/purescript-prelude
5−
6−module Prelude
7− ( Unit(..), unit
8− , ($), (#)
9− , flip
10− , const
11− , asTypeOf
12− , otherwise
13− , (:), cons
14− , Semigroupoid, (<<<), (>>>)
15− , Category, id
16− , Functor, (<$>), (<#>), void
17− , Apply, (<*>)
18− , Applicative, pure, liftA1
19− , Bind, (>>=)
20− , Monad, return, liftM1, ap
21− , Semigroup, (<>), (++)
22− , Semiring, (+), zero, (*), one
23− , ModuloSemiring, (/), mod
24− , Ring, (-), negate
25− , Num
26− , DivisionRing
27− , Eq, (==), (/=)
28− , Ordering(..), Ord, compare, (<), (>), (<=), (>=)
29− , Bounded, top, bottom
30− , Lattice, sup, inf, (||), (&&)
31− , BoundedLattice
32− , ComplementedLattice, not
33− , DistributiveLattice
34− , BooleanAlgebra
35− , Show, show
36− ) where
37−
38− newtype Unit = Unit {}
39−
40− unit :: Unit
41− unit = Unit {}
42−
43− infixr 0 $
44− infixl 0 #
45−
46− ($) :: forall a b. (a -> b) -> a -> b
47− ($) f x = f x
48−
49− (#) :: forall a b. a -> (a -> b) -> b
50− (#) x f = f x
51−
52− flip :: forall a b c. (a -> b -> c) -> b -> a -> c
53− flip f b a = f a b
54−
55− const :: forall a b. a -> b -> a
56− const a _ = a
57−
58− asTypeOf :: forall a. a -> a -> a
59− asTypeOf x _ = x
60−
61− otherwise :: Boolean
62− otherwise = true
63−
64− foreign import cons
65− """
66− function cons(e) {
67− return function(l) {
68− return [e].concat(l);
69− };
70− }
71− """ :: forall a. a -> Array a -> Array a
72−
73− infixr 6 :
74−
75− (:) :: forall a. a -> Array a -> Array a
76− (:) = cons
77−
78− infixr 9 >>>
79− infixr 9 <<<
80−
81− class Semigroupoid a where
82− (<<<) :: forall b c d. a c d -> a b c -> a b d
83−
84− instance semigroupoidArr :: Semigroupoid (->) where
85− (<<<) f g x = f (g x)
86−
87− (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d
88− (>>>) f g = g <<< f
89−
90− class (Semigroupoid a) <= Category a where
91− id :: forall t. a t t
92−
93− instance categoryArr :: Category (->) where
94− id x = x
95−
96− infixl 4 <$>
97− infixl 1 <#>
98−
99− class Functor f where
100− (<$>) :: forall a b. (a -> b) -> f a -> f b
101−
102− instance functorArr :: Functor ((->) r) where
103− (<$>) = (<<<)
104−
105− (<#>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b
106− (<#>) fa f = f <$> fa
107−
108− void :: forall f a. (Functor f) => f a -> f Unit
109− void fa = const unit <$> fa
110−
111− infixl 4 <*>
112−
113− class (Functor f) <= Apply f where
114− (<*>) :: forall a b. f (a -> b) -> f a -> f b
115−
116− instance applyArr :: Apply ((->) r) where
117− (<*>) f g x = f x (g x)
118−
119− class (Apply f) <= Applicative f where
120− pure :: forall a. a -> f a
121−
122− instance applicativeArr :: Applicative ((->) r) where
123− pure = const
124−
125− return :: forall m a. (Applicative m) => a -> m a
126− return = pure
127−
128− liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
129− liftA1 f a = pure f <*> a
130−
131− infixl 1 >>=
132−
133− class (Apply m) <= Bind m where
134− (>>=) :: forall a b. m a -> (a -> m b) -> m b
135−
136− instance bindArr :: Bind ((->) r) where
137− (>>=) m f x = f (m x) x
138−
139− class (Applicative m, Bind m) <= Monad m
140−
141− instance monadArr :: Monad ((->) r)
142−
143− liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
144− liftM1 f a = do
145− a' <- a
146− return (f a')
147−
148− ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b
149− ap f a = do
150− f' <- f
151− a' <- a
152− return (f' a')
153−
154− infixr 5 <>
155− infixr 5 ++
156−
157− class Semigroup a where
158− (<>) :: a -> a -> a
159−
160− (++) :: forall s. (Semigroup s) => s -> s -> s
161− (++) = (<>)
162−
163− instance semigroupString :: Semigroup String where
164− (<>) = concatString
165−
166− instance semigroupUnit :: Semigroup Unit where
167− (<>) _ _ = unit
168−
169− instance semigroupArr :: (Semigroup s') => Semigroup (s -> s') where
170− (<>) f g = \x -> f x <> g x
171−
172− instance semigroupOrdering :: Semigroup Ordering where
173− (<>) LT _ = LT
174− (<>) GT _ = GT
175− (<>) EQ y = y
176−
177− foreign import concatString
178− """
179− function concatString(s1) {
180− return function(s2) {
181− return s1 + s2;
182− };
183− }
184− """ :: String -> String -> String
185−
186− infixl 6 +
187− infixl 7 *
188−
189− class Semiring a where
190− (+) :: a -> a -> a
191− zero :: a
192− (*) :: a -> a -> a
193− one :: a
194−
195− instance semiringNumber :: Semiring Number where
196− (+) = numAdd
197− zero = 0.0
198− (*) = numMul
199− one = 1.0
200−
201− instance semiringUnit :: Semiring Unit where
202− (+) _ _ = unit
203− zero = unit
204− (*) _ _ = unit
205− one = unit
206−
207− infixl 6 -
208−
209− class (Semiring a) <= Ring a where
210− (-) :: a -> a -> a
211−
212− instance ringNumber :: Ring Number where
213− (-) = numSub
214−
215− instance ringUnit :: Ring Unit where
216− (-) _ _ = unit
217−
218− negate :: forall a. (Ring a) => a -> a
219− negate a = zero - a
220−
221− infixl 7 /
222−
223− class (Semiring a) <= ModuloSemiring a where
224− (/) :: a -> a -> a
225− mod :: a -> a -> a
226−
227− instance moduloSemiringNumber :: ModuloSemiring Number where
228− (/) = numDiv
229− mod _ _ = 0.0
230−
231− instance moduloSemiringUnit :: ModuloSemiring Unit where
232− (/) _ _ = unit
233− mod _ _ = unit
234−
235− class (Ring a, ModuloSemiring a) <= DivisionRing a
236−
237− instance divisionRingNumber :: DivisionRing Number
238−
239− instance divisionRingUnit :: DivisionRing Unit
240−
241− class (DivisionRing a) <= Num a
242−
243− instance numNumber :: Num Number
244−
245− instance numUnit :: Num Unit
246−
247− foreign import numAdd
248− """
249− function numAdd(n1) {
250− return function(n2) {
251− return n1 + n2;
252− };
253− }
254− """ :: Number -> Number -> Number
255−
256− foreign import numMul
257− """
258− function numMul(n1) {
259− return function(n2) {
260− return n1 * n2;
261− };
262− }
263− """ :: Number -> Number -> Number
264−
265− foreign import numDiv
266− """
267− function numDiv(n1) {
268− return function(n2) {
269− return n1 / n2;
270− };
271− }
272− """ :: Number -> Number -> Number
273−
274− foreign import numSub
275− """
276− function numSub(n1) {
277− return function(n2) {
278− return n1 - n2;
279− };
280− }
281− """ :: Number -> Number -> Number
282−
283− infix 4 ==
284− infix 4 /=
285−
286− class Eq a where
287− (==) :: a -> a -> Boolean
288− (/=) :: a -> a -> Boolean
289−
290− instance eqBoolean :: Eq Boolean where
291− (==) = refEq
292− (/=) = refIneq
293−
294− instance eqNumber :: Eq Number where
295− (==) = refEq
296− (/=) = refIneq
297−
298− instance eqString :: Eq String where
299− (==) = refEq
300− (/=) = refIneq
301−
302− instance eqUnit :: Eq Unit where
303− (==) _ _ = true
304− (/=) _ _ = false
305−
306− instance eqArray :: (Eq a) => Eq (Array a) where
307− (==) = eqArrayImpl (==)
308− (/=) xs ys = not (xs == ys)
309−
310− instance eqOrdering :: Eq Ordering where
311− (==) LT LT = true
312− (==) GT GT = true
313− (==) EQ EQ = true
314− (==) _ _ = false
315− (/=) x y = not (x == y)
316−
317− foreign import refEq
318− """
319− function refEq(r1) {
320− return function(r2) {
321− return r1 === r2;
322− };
323− }
324− """ :: forall a. a -> a -> Boolean
325−
326− foreign import refIneq
327− """
328− function refIneq(r1) {
329− return function(r2) {
330− return r1 !== r2;
331− };
332− }
333− """ :: forall a. a -> a -> Boolean
334−
335− foreign import eqArrayImpl
336− """
337− function eqArrayImpl(f) {
338− return function(xs) {
339− return function(ys) {
340− if (xs.length !== ys.length) return false;
341− for (var i = 0; i < xs.length; i++) {
342− if (!f(xs[i])(ys[i])) return false;
343− }
344− return true;
345− };
346− };
347− }
348− """ :: forall a. (a -> a -> Boolean) -> Array a -> Array a -> Boolean
349−
350− data Ordering = LT | GT | EQ
351−
352− class (Eq a) <= Ord a where
353− compare :: a -> a -> Ordering
354−
355− instance ordBoolean :: Ord Boolean where
356− compare false false = EQ
357− compare false true = LT
358− compare true true = EQ
359− compare true false = GT
360−
361− instance ordNumber :: Ord Number where
362− compare = unsafeCompare
363−
364− instance ordString :: Ord String where
365− compare = unsafeCompare
366−
367− instance ordUnit :: Ord Unit where
368− compare _ _ = EQ
369−
370− instance ordArray :: (Ord a) => Ord (Array a) where
371− compare xs ys = compare 0.0 $ ordArrayImpl (\x y -> case compare x y of
372− EQ -> 0.0
373− LT -> -1.0
374− GT -> 1.0) xs ys
375−
376− foreign import ordArrayImpl """
377− function ordArrayImpl(f) {
378− return function (ys) {
379− return function (ys) {
380− var i = 0;
381− while (i < xs.length && i < ys.length) {
382− var x = xs[i];
383− var y = ys[i];
384− var o = f(x)(y);
385− if (o !== 0) {
386− return o;
387− }
388− }
389− if (xs.length == ys.length) {
390− return 0;
391− } else if (xs.length > ys.length) {
392− return 1;
393− } else {
394− return -1;
395− }
396− };
397− };
398− }
399− """ :: forall a. (a -> a -> Number) -> Array a -> Array a -> Number
400−
401− instance ordOrdering :: Ord Ordering where
402− compare LT LT = EQ
403− compare EQ EQ = EQ
404− compare GT GT = EQ
405− compare LT _ = LT
406− compare EQ LT = GT
407− compare EQ GT = LT
408− compare GT _ = GT
409−
410− infixl 4 <
411− infixl 4 >
412− infixl 4 <=
413− infixl 4 >=
414−
415− (<) :: forall a. (Ord a) => a -> a -> Boolean
416− (<) a1 a2 = case a1 `compare` a2 of
417− LT -> true
418− _ -> false
419−
420− (>) :: forall a. (Ord a) => a -> a -> Boolean
421− (>) a1 a2 = case a1 `compare` a2 of
422− GT -> true
423− _ -> false
424−
425− (<=) :: forall a. (Ord a) => a -> a -> Boolean
426− (<=) a1 a2 = case a1 `compare` a2 of
427− GT -> false
428− _ -> true
429−
430− (>=) :: forall a. (Ord a) => a -> a -> Boolean
431− (>=) a1 a2 = case a1 `compare` a2 of
432− LT -> false
433− _ -> true
434−
435− unsafeCompare :: forall a. a -> a -> Ordering
436− unsafeCompare = unsafeCompareImpl LT EQ GT
437−
438− foreign import unsafeCompareImpl
439− """
440− function unsafeCompareImpl(lt) {
441− return function(eq) {
442− return function(gt) {
443− return function(x) {
444− return function(y) {
445− return x < y ? lt : x > y ? gt : eq;
446− };
447− };
448− };
449− };
450− }
451− """ :: forall a. Ordering -> Ordering -> Ordering -> a -> a -> Ordering
452−
453− class (Ord a) <= Bounded a where
454− top :: a
455− bottom :: a
456−
457− instance boundedBoolean :: Bounded Boolean where
458− top = true
459− bottom = false
460−
461− instance boundedUnit :: Bounded Unit where
462− top = unit
463− bottom = unit
464−
465− instance boundedOrdering :: Bounded Ordering where
466− top = GT
467− bottom = LT
468−
469− class (Ord a) <= Lattice a where
470− sup :: a -> a -> a
471− inf :: a -> a -> a
472−
473− instance latticeBoolean :: Lattice Boolean where
474− sup = boolOr
475− inf = boolAnd
476−
477− instance latticeUnit :: Lattice Unit where
478− sup _ _ = unit
479− inf _ _ = unit
480−
481− infixr 2 ||
482− infixr 3 &&
483−
484− (||) :: forall a. (Lattice a) => a -> a -> a
485− (||) = sup
486−
487− (&&) :: forall a. (Lattice a) => a -> a -> a
488− (&&) = inf
489−
490− class (Bounded a, Lattice a) <= BoundedLattice a
491−
492− instance boundedLatticeBoolean :: BoundedLattice Boolean
493−
494− instance boundedLatticeUnit :: BoundedLattice Unit
495−
496− class (BoundedLattice a) <= ComplementedLattice a where
497− not :: a -> a
498−
499− instance complementedLatticeBoolean :: ComplementedLattice Boolean where
500− not = boolNot
501−
502− instance complementedLatticeUnit :: ComplementedLattice Unit where
503− not _ = unit
504−
505− class (Lattice a) <= DistributiveLattice a
506−
507− instance distributiveLatticeBoolean :: DistributiveLattice Boolean
508−
509− instance distributiveLatticeUnit :: DistributiveLattice Unit
510−
511− class (ComplementedLattice a, DistributiveLattice a) <= BooleanAlgebra a
512−
513− instance booleanAlgebraBoolean :: BooleanAlgebra Boolean
514−
515− instance booleanAlgebraUnit :: BooleanAlgebra Unit
516−
517− foreign import boolOr
518− """
519− function boolOr(b1) {
520− return function(b2) {
521− return b1 || b2;
522− };
523− }
524− """ :: Boolean -> Boolean -> Boolean
525−
526− foreign import boolAnd
527− """
528− function boolAnd(b1) {
529− return function(b2) {
530− return b1 && b2;
531− };
532− }
533− """ :: Boolean -> Boolean -> Boolean
534−
535− foreign import boolNot
536− """
537− function boolNot(b) {
538− return !b;
539− }
540− """ :: Boolean -> Boolean
541−
542− class Show a where
543− show :: a -> String
544−
545− instance showBoolean :: Show Boolean where
546− show true = "true"
547− show false = "false"
548−
549− instance showNumber :: Show Number where
550− show = showNumberImpl
551−
552− instance showString :: Show String where
553− show = showStringImpl
554−
555− instance showUnit :: Show Unit where
556− show _ = "unit"
557−
558− instance showArray :: (Show a) => Show (Array a) where
559− show = showArrayImpl show
560−
561− instance showOrdering :: Show Ordering where
562− show LT = "LT"
563− show GT = "GT"
564− show EQ = "EQ"
565−
566− foreign import showNumberImpl
567− """
568− function showNumberImpl(n) {
569− return n.toString();
570− }
571− """ :: Number -> String
572−
573− foreign import showStringImpl
574− """
575− function showStringImpl(s) {
576− return JSON.stringify(s);
577− }
578− """ :: String -> String
579−
580− foreign import showArrayImpl
581− """
582− function showArrayImpl(f) {
583− return function(xs) {
584− var ss = [];
585− for (var i = 0, l = xs.length; i < l; i++) {
586− ss[i] = f(xs[i]);
587− }
588− return '[' + ss.join(',') + ']';
589− };
590− }
591− """ :: forall a. (a -> String) -> Array a -> String
592−
593−module Data.Function where
594−
595− on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c
596− on f g x y = g x `f` g y
597−
598− foreign import data Fn0 :: * -> *
599−
600− foreign import data Fn1 :: * -> * -> *
601−
602− foreign import data Fn2 :: * -> * -> * -> *
603−
604− foreign import data Fn3 :: * -> * -> * -> * -> *
605−
606− foreign import data Fn4 :: * -> * -> * -> * -> * -> *
607−
608− foreign import data Fn5 :: * -> * -> * -> * -> * -> * -> *
609−
610− foreign import data Fn6 :: * -> * -> * -> * -> * -> * -> * -> *
611−
612− foreign import data Fn7 :: * -> * -> * -> * -> * -> * -> * -> * -> *
613−
614− foreign import data Fn8 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> *
615−
616− foreign import data Fn9 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *
617−
618− foreign import data Fn10 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *
619−
620− foreign import mkFn0
621− """
622− function mkFn0(fn) {
623− return function() {
624− return fn({});
625− };
626− }
627− """ :: forall a. (Unit -> a) -> Fn0 a
628−
629− foreign import mkFn1
630− """
631− function mkFn1(fn) {
632− return function(a) {
633− return fn(a);
634− };
635− }
636− """ :: forall a b. (a -> b) -> Fn1 a b
637−
638− foreign import mkFn2
639− """
640− function mkFn2(fn) {
641− return function(a, b) {
642− return fn(a)(b);
643− };
644− }
645− """ :: forall a b c. (a -> b -> c) -> Fn2 a b c
646−
647− foreign import mkFn3
648− """
649− function mkFn3(fn) {
650− return function(a, b, c) {
651− return fn(a)(b)(c);
652− };
653− }
654− """ :: forall a b c d. (a -> b -> c -> d) -> Fn3 a b c d
655−
656− foreign import mkFn4
657− """
658− function mkFn4(fn) {
659− return function(a, b, c, d) {
660− return fn(a)(b)(c)(d);
661− };
662− }
663− """ :: forall a b c d e. (a -> b -> c -> d -> e) -> Fn4 a b c d e
664−
665− foreign import mkFn5
666− """
667− function mkFn5(fn) {
668− return function(a, b, c, d, e) {
669− return fn(a)(b)(c)(d)(e);
670− };
671− }
672− """ :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Fn5 a b c d e f
673−
674− foreign import mkFn6
675− """
676− function mkFn6(fn) {
677− return function(a, b, c, d, e, f) {
678− return fn(a)(b)(c)(d)(e)(f);
679− };
680− }
681− """ :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> Fn6 a b c d e f g
682−
683− foreign import mkFn7
684− """
685− function mkFn7(fn) {
686− return function(a, b, c, d, e, f, g) {
687− return fn(a)(b)(c)(d)(e)(f)(g);
688− };
689− }
690− """ :: 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
691−
692− foreign import mkFn8
693− """
694− function mkFn8(fn) {
695− return function(a, b, c, d, e, f, g, h) {
696− return fn(a)(b)(c)(d)(e)(f)(g)(h);
697− };
698− }
699− """ :: 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
700−
701− foreign import mkFn9
702− """
703− function mkFn9(fn) {
704− return function(a, b, c, d, e, f, g, h, i) {
705− return fn(a)(b)(c)(d)(e)(f)(g)(h)(i);
706− };
707− }
708− """ :: 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
709−
710− foreign import mkFn10
711− """
712− function mkFn10(fn) {
713− return function(a, b, c, d, e, f, g, h, i, j) {
714− return fn(a)(b)(c)(d)(e)(f)(g)(h)(i)(j);
715− };
716− }
717− """ :: 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
718−
719− foreign import runFn0
720− """
721− function runFn0(fn) {
722− return fn();
723− }
724− """ :: forall a. Fn0 a -> a
725−
726− foreign import runFn1
727− """
728− function runFn1(fn) {
729− return function(a) {
730− return fn(a);
731− };
732− }
733− """ :: forall a b. Fn1 a b -> a -> b
734−
735− foreign import runFn2
736− """
737− function runFn2(fn) {
738− return function(a) {
739− return function(b) {
740− return fn(a, b);
741− };
742− };
743− }
744− """ :: forall a b c. Fn2 a b c -> a -> b -> c
745−
746− foreign import runFn3
747− """
748− function runFn3(fn) {
749− return function(a) {
750− return function(b) {
751− return function(c) {
752− return fn(a, b, c);
753− };
754− };
755− };
756− }
757− """ :: forall a b c d. Fn3 a b c d -> a -> b -> c -> d
758−
759− foreign import runFn4
760− """
761− function runFn4(fn) {
762− return function(a) {
763− return function(b) {
764− return function(c) {
765− return function(d) {
766− return fn(a, b, c, d);
767− };
768− };
769− };
770− };
771− }
772− """ :: forall a b c d e. Fn4 a b c d e -> a -> b -> c -> d -> e
773−
774− foreign import runFn5
775− """
776− function runFn5(fn) {
777− return function(a) {
778− return function(b) {
779− return function(c) {
780− return function(d) {
781− return function(e) {
782− return fn(a, b, c, d, e);
783− };
784− };
785− };
786− };
787− };
788− }
789− """ :: forall a b c d e f. Fn5 a b c d e f -> a -> b -> c -> d -> e -> f
790−
791− foreign import runFn6
792− """
793− function runFn6(fn) {
794− return function(a) {
795− return function(b) {
796− return function(c) {
797− return function(d) {
798− return function(e) {
799− return function(f) {
800− return fn(a, b, c, d, e, f);
801− };
802− };
803− };
804− };
805− };
806− };
807− }
808− """ :: forall a b c d e f g. Fn6 a b c d e f g -> a -> b -> c -> d -> e -> f -> g
809−
810− foreign import runFn7
811− """
812− function runFn7(fn) {
813− return function(a) {
814− return function(b) {
815− return function(c) {
816− return function(d) {
817− return function(e) {
818− return function(f) {
819− return function(g) {
820− return fn(a, b, c, d, e, f, g);
821− };
822− };
823− };
824− };
825− };
826− };
827− };
828− }
829− """ :: 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
830−
831− foreign import runFn8
832− """
833− function runFn8(fn) {
834− return function(a) {
835− return function(b) {
836− return function(c) {
837− return function(d) {
838− return function(e) {
839− return function(f) {
840− return function(g) {
841− return function(h) {
842− return fn(a, b, c, d, e, f, g, h);
843− };
844− };
845− };
846− };
847− };
848− };
849− };
850− };
851− }
852− """ :: 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
853−
854− foreign import runFn9
855− """
856− function runFn9(fn) {
857− return function(a) {
858− return function(b) {
859− return function(c) {
860− return function(d) {
861− return function(e) {
862− return function(f) {
863− return function(g) {
864− return function(h) {
865− return function(i) {
866− return fn(a, b, c, d, e, f, g, h, i);
867− };
868− };
869− };
870− };
871− };
872− };
873− };
874− };
875− };
876− }
877− """ :: 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
878−
879− foreign import runFn10
880− """
881− function runFn10(fn) {
882− return function(a) {
883− return function(b) {
884− return function(c) {
885− return function(d) {
886− return function(e) {
887− return function(f) {
888− return function(g) {
889− return function(h) {
890− return function(i) {
891− return function(j) {
892− return fn(a, b, c, d, e, f, g, h, i, j);
893− };
894− };
895− };
896− };
897− };
898− };
899− };
900− };
901− };
902− };
903− }
904− """ :: 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
905−
906−module Prelude.Unsafe where
907−
908− foreign import unsafeIndex
909− """
910− function unsafeIndex(xs) {
911− return function(n) {
912− return xs[n];
913− };
914− }
915− """ :: forall a. Array a -> Number -> a
916−
917−module Control.Monad.Eff
918− ( Eff()
919− , Pure()
920− , runPure
921− , untilE, whileE
922− ) where
923−
924− foreign import data Eff :: # ! -> * -> *
925−
926− foreign import returnE
927− """
928− function returnE(a) {
929− return function() {
930− return a;
931− };
932− }
933− """ :: forall e a. a -> Eff e a
934−
935− foreign import bindE
936− """
937− function bindE(a) {
938− return function(f) {
939− return function() {
940− return f(a())();
941− };
942− };
943− }
944− """ :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b
945−
946− type Pure a = forall e. Eff e a
947−
948− foreign import runPure
949− """
950− function runPure(f) {
951− return f();
952− }
953− """ :: forall a. Pure a -> a
954−
955− instance functorEff :: Functor (Eff e) where
956− (<$>) = liftA1
957−
958− instance applyEff :: Apply (Eff e) where
959− (<*>) = ap
960−
961− instance applicativeEff :: Applicative (Eff e) where
962− pure = returnE
963−
964− instance bindEff :: Bind (Eff e) where
965− (>>=) = bindE
966−
967− instance monadEff :: Monad (Eff e)
968−
969− foreign import untilE
970− """
971− function untilE(f) {
972− return function() {
973− while (!f());
974− return {};
975− };
976− }
977− """ :: forall e. Eff e Boolean -> Eff e Unit
978−
979− foreign import whileE
980− """
981− function whileE(f) {
982− return function(a) {
983− return function() {
984− while (f()) {
985− a();
986− }
987− return {};
988− };
989− };
990− }
991− """ :: forall e a. Eff e Boolean -> Eff e a -> Eff e Unit
992−
993−module Debug.Trace where
994−
995− import Control.Monad.Eff
996−
997− foreign import data Trace :: !
998−
999− foreign import trace
1000− """
1001− function trace(s) {
1002− return function() {
1003− console.log(s);
1004− return {};
1005− };
1006− }
1007− """ :: forall r. String -> Eff (trace :: Trace | r) Unit
1008−
1009− print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) Unit
1010− print o = trace (show o)
1011−
1012−module Control.Monad.ST where
1013−
1014− import Control.Monad.Eff
1015−
1016− foreign import data ST :: * -> !
1017−
1018− foreign import data STRef :: * -> * -> *
1019−
1020− foreign import newSTRef
1021− """
1022− function newSTRef(val) {
1023− return function() {
1024− return { value: val };
1025− };
1026− }
1027− """ :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)
1028−
1029− foreign import readSTRef
1030− """
1031− function readSTRef(ref) {
1032− return function() {
1033− return ref.value;
1034− };
1035− }
1036− """ :: forall a h r. STRef h a -> Eff (st :: ST h | r) a
1037−
1038− foreign import modifySTRef
1039− """
1040− function modifySTRef(ref) {
1041− return function(f) {
1042− return function() {
1043− return ref.value = f(ref.value);
1044− };
1045− };
1046− }
1047− """ :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a
1048−
1049− foreign import writeSTRef
1050− """
1051− function writeSTRef(ref) {
1052− return function(a) {
1053− return function() {
1054− return ref.value = a;
1055− };
1056− };
1057− }
1058− """ :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a
1059−
1060− foreign import runST
1061− """
1062− function runST(f) {
1063− return f;
1064− }
1065− """ :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a
1066−
1067− pureST :: forall a. (forall h r. Eff (st :: ST h | r) a) -> a
1068− pureST st = runPure (runST st)
tests/prelude/Prelude.pursnew file+628
@@ -0,0 +1,628 @@
1+-- | This snapshot is provided for the purposes of running the test suite.
2+-- | It is not necessarily kept up to date with the official PureScript Prelude,
3+-- | and should not be used in user code.
4+-- | The official Prelude can be found at https://github.com/purescript/purescript-prelude
5+
6+module Prelude
7+ ( Unit(..), unit
8+ , ($), (#)
9+ , length
10+ , flip
11+ , const
12+ , asTypeOf
13+ , otherwise
14+ , (:), cons, concat
15+ , Semigroupoid, (<<<), (>>>)
16+ , Category, id
17+ , Functor, (<$>), (<#>), void
18+ , Apply, (<*>)
19+ , Applicative, pure, liftA1
20+ , Bind, (>>=)
21+ , Monad, return, liftM1, ap
22+ , Semigroup, (<>), (++)
23+ , Semiring, (+), zero, (*), one
24+ , ModuloSemiring, (/), mod, jsMod, (%)
25+ , Ring, (-), negate
26+ , Num
27+ , DivisionRing
28+ , Eq, (==), (/=)
29+ , Ordering(..), Ord, compare, (<), (>), (<=), (>=)
30+ , Bounded, top, bottom
31+ , Lattice, sup, inf, (||), (&&)
32+ , BoundedLattice
33+ , ComplementedLattice, not
34+ , DistributiveLattice
35+ , BooleanAlgebra
36+ , Show, show
37+ ) where
38+
39+ newtype Unit = Unit {}
40+
41+ unit :: Unit
42+ unit = Unit {}
43+
44+ foreign import length :: forall a. Array a -> Number
45+
46+ infixr 0 $
47+ infixl 0 #
48+
49+ ($) :: forall a b. (a -> b) -> a -> b
50+ ($) f x = f x
51+
52+ (#) :: forall a b. a -> (a -> b) -> b
53+ (#) x f = f x
54+
55+ flip :: forall a b c. (a -> b -> c) -> b -> a -> c
56+ flip f b a = f a b
57+
58+ const :: forall a b. a -> b -> a
59+ const a _ = a
60+
61+ asTypeOf :: forall a. a -> a -> a
62+ asTypeOf x _ = x
63+
64+ otherwise :: Boolean
65+ otherwise = true
66+
67+ foreign import cons :: forall a. a -> Array a -> Array a
68+
69+ infixr 6 :
70+
71+ (:) :: forall a. a -> Array a -> Array a
72+ (:) = cons
73+
74+ foreign import concat :: forall a. Array a -> Array a -> Array a
75+
76+ infixr 9 >>>
77+ infixr 9 <<<
78+
79+ class Semigroupoid a where
80+ (<<<) :: forall b c d. a c d -> a b c -> a b d
81+
82+ instance semigroupoidArr :: Semigroupoid (->) where
83+ (<<<) f g x = f (g x)
84+
85+ (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d
86+ (>>>) f g = g <<< f
87+
88+ class (Semigroupoid a) <= Category a where
89+ id :: forall t. a t t
90+
91+ instance categoryArr :: Category (->) where
92+ id x = x
93+
94+ infixl 4 <$>
95+ infixl 1 <#>
96+
97+ class Functor f where
98+ (<$>) :: forall a b. (a -> b) -> f a -> f b
99+
100+ instance functorArr :: Functor ((->) r) where
101+ (<$>) = (<<<)
102+
103+ (<#>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b
104+ (<#>) fa f = f <$> fa
105+
106+ void :: forall f a. (Functor f) => f a -> f Unit
107+ void fa = const unit <$> fa
108+
109+ infixl 4 <*>
110+
111+ class (Functor f) <= Apply f where
112+ (<*>) :: forall a b. f (a -> b) -> f a -> f b
113+
114+ instance applyArr :: Apply ((->) r) where
115+ (<*>) f g x = f x (g x)
116+
117+ class (Apply f) <= Applicative f where
118+ pure :: forall a. a -> f a
119+
120+ instance applicativeArr :: Applicative ((->) r) where
121+ pure = const
122+
123+ return :: forall m a. (Applicative m) => a -> m a
124+ return = pure
125+
126+ liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
127+ liftA1 f a = pure f <*> a
128+
129+ infixl 1 >>=
130+
131+ class (Apply m) <= Bind m where
132+ (>>=) :: forall a b. m a -> (a -> m b) -> m b
133+
134+ instance bindArr :: Bind ((->) r) where
135+ (>>=) m f x = f (m x) x
136+
137+ class (Applicative m, Bind m) <= Monad m
138+
139+ instance monadArr :: Monad ((->) r)
140+
141+ liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
142+ liftM1 f a = do
143+ a' <- a
144+ return (f a')
145+
146+ ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b
147+ ap f a = do
148+ f' <- f
149+ a' <- a
150+ return (f' a')
151+
152+ infixr 5 <>
153+ infixr 5 ++
154+
155+ class Semigroup a where
156+ (<>) :: a -> a -> a
157+
158+ (++) :: forall s. (Semigroup s) => s -> s -> s
159+ (++) = (<>)
160+
161+ instance semigroupString :: Semigroup String where
162+ (<>) = concatString
163+
164+ instance semigroupUnit :: Semigroup Unit where
165+ (<>) _ _ = unit
166+
167+ instance semigroupArr :: (Semigroup s') => Semigroup (s -> s') where
168+ (<>) f g = \x -> f x <> g x
169+
170+ instance semigroupOrdering :: Semigroup Ordering where
171+ (<>) LT _ = LT
172+ (<>) GT _ = GT
173+ (<>) EQ y = y
174+
175+ foreign import concatString :: String -> String -> String
176+
177+ infixl 6 +
178+ infixl 7 *
179+
180+ class Semiring a where
181+ (+) :: a -> a -> a
182+ zero :: a
183+ (*) :: a -> a -> a
184+ one :: a
185+
186+ instance semiringNumber :: Semiring Number where
187+ (+) = numAdd
188+ zero = 0.0
189+ (*) = numMul
190+ one = 1.0
191+
192+ instance semiringUnit :: Semiring Unit where
193+ (+) _ _ = unit
194+ zero = unit
195+ (*) _ _ = unit
196+ one = unit
197+
198+ infixl 6 -
199+
200+ class (Semiring a) <= Ring a where
201+ (-) :: a -> a -> a
202+
203+ instance ringNumber :: Ring Number where
204+ (-) = numSub
205+
206+ instance ringUnit :: Ring Unit where
207+ (-) _ _ = unit
208+
209+ negate :: forall a. (Ring a) => a -> a
210+ negate a = zero - a
211+
212+ infixl 7 /
213+
214+ class (Semiring a) <= ModuloSemiring a where
215+ (/) :: a -> a -> a
216+ mod :: a -> a -> a
217+
218+ instance moduloSemiringNumber :: ModuloSemiring Number where
219+ (/) = numDiv
220+ mod _ _ = 0.0
221+
222+ instance moduloSemiringUnit :: ModuloSemiring Unit where
223+ (/) _ _ = unit
224+ mod _ _ = unit
225+
226+ foreign import jsMod :: Number -> Number -> Number
227+
228+ infixl 7 %
229+
230+ (%) = jsMod
231+
232+ class (Ring a, ModuloSemiring a) <= DivisionRing a
233+
234+ instance divisionRingNumber :: DivisionRing Number
235+
236+ instance divisionRingUnit :: DivisionRing Unit
237+
238+ class (DivisionRing a) <= Num a
239+
240+ instance numNumber :: Num Number
241+
242+ instance numUnit :: Num Unit
243+
244+ foreign import numAdd :: Number -> Number -> Number
245+
246+ foreign import numMul :: Number -> Number -> Number
247+
248+ foreign import numDiv :: Number -> Number -> Number
249+
250+ foreign import numSub :: Number -> Number -> Number
251+
252+ infix 4 ==
253+ infix 4 /=
254+
255+ class Eq a where
256+ (==) :: a -> a -> Boolean
257+ (/=) :: a -> a -> Boolean
258+
259+ instance eqBoolean :: Eq Boolean where
260+ (==) = refEq
261+ (/=) = refIneq
262+
263+ instance eqNumber :: Eq Number where
264+ (==) = refEq
265+ (/=) = refIneq
266+
267+ instance eqInt :: Eq Int where
268+ (==) = refEq
269+ (/=) = refIneq
270+
271+ instance eqChar :: Eq Char where
272+ (==) = refEq
273+ (/=) = refIneq
274+
275+ instance eqString :: Eq String where
276+ (==) = refEq
277+ (/=) = refIneq
278+
279+ instance eqUnit :: Eq Unit where
280+ (==) _ _ = true
281+ (/=) _ _ = false
282+
283+ instance eqArray :: (Eq a) => Eq (Array a) where
284+ (==) = eqArrayImpl (==)
285+ (/=) xs ys = not (xs == ys)
286+
287+ instance eqOrdering :: Eq Ordering where
288+ (==) LT LT = true
289+ (==) GT GT = true
290+ (==) EQ EQ = true
291+ (==) _ _ = false
292+ (/=) x y = not (x == y)
293+
294+ foreign import refEq :: forall a. a -> a -> Boolean
295+
296+ foreign import refIneq :: forall a. a -> a -> Boolean
297+
298+ foreign import eqArrayImpl :: forall a. (a -> a -> Boolean) -> Array a -> Array a -> Boolean
299+
300+ data Ordering = LT | GT | EQ
301+
302+ class (Eq a) <= Ord a where
303+ compare :: a -> a -> Ordering
304+
305+ instance ordBoolean :: Ord Boolean where
306+ compare false false = EQ
307+ compare false true = LT
308+ compare true true = EQ
309+ compare true false = GT
310+
311+ instance ordNumber :: Ord Number where
312+ compare = unsafeCompare
313+
314+ instance ordString :: Ord String where
315+ compare = unsafeCompare
316+
317+ instance ordUnit :: Ord Unit where
318+ compare _ _ = EQ
319+
320+ instance ordArray :: (Ord a) => Ord (Array a) where
321+ compare xs ys = compare 0.0 $ ordArrayImpl (\x y -> case compare x y of
322+ EQ -> 0.0
323+ LT -> -1.0
324+ GT -> 1.0) xs ys
325+
326+ foreign import ordArrayImpl :: forall a. (a -> a -> Number) -> Array a -> Array a -> Number
327+
328+ instance ordOrdering :: Ord Ordering where
329+ compare LT LT = EQ
330+ compare EQ EQ = EQ
331+ compare GT GT = EQ
332+ compare LT _ = LT
333+ compare EQ LT = GT
334+ compare EQ GT = LT
335+ compare GT _ = GT
336+
337+ infixl 4 <
338+ infixl 4 >
339+ infixl 4 <=
340+ infixl 4 >=
341+
342+ (<) :: forall a. (Ord a) => a -> a -> Boolean
343+ (<) a1 a2 = case a1 `compare` a2 of
344+ LT -> true
345+ _ -> false
346+
347+ (>) :: forall a. (Ord a) => a -> a -> Boolean
348+ (>) a1 a2 = case a1 `compare` a2 of
349+ GT -> true
350+ _ -> false
351+
352+ (<=) :: forall a. (Ord a) => a -> a -> Boolean
353+ (<=) a1 a2 = case a1 `compare` a2 of
354+ GT -> false
355+ _ -> true
356+
357+ (>=) :: forall a. (Ord a) => a -> a -> Boolean
358+ (>=) a1 a2 = case a1 `compare` a2 of
359+ LT -> false
360+ _ -> true
361+
362+ unsafeCompare :: forall a. a -> a -> Ordering
363+ unsafeCompare = unsafeCompareImpl LT EQ GT
364+
365+ foreign import unsafeCompareImpl :: forall a. Ordering -> Ordering -> Ordering -> a -> a -> Ordering
366+
367+ class (Ord a) <= Bounded a where
368+ top :: a
369+ bottom :: a
370+
371+ instance boundedBoolean :: Bounded Boolean where
372+ top = true
373+ bottom = false
374+
375+ instance boundedUnit :: Bounded Unit where
376+ top = unit
377+ bottom = unit
378+
379+ instance boundedOrdering :: Bounded Ordering where
380+ top = GT
381+ bottom = LT
382+
383+ class (Ord a) <= Lattice a where
384+ sup :: a -> a -> a
385+ inf :: a -> a -> a
386+
387+ instance latticeBoolean :: Lattice Boolean where
388+ sup = boolOr
389+ inf = boolAnd
390+
391+ instance latticeUnit :: Lattice Unit where
392+ sup _ _ = unit
393+ inf _ _ = unit
394+
395+ infixr 2 ||
396+ infixr 3 &&
397+
398+ (||) :: forall a. (Lattice a) => a -> a -> a
399+ (||) = sup
400+
401+ (&&) :: forall a. (Lattice a) => a -> a -> a
402+ (&&) = inf
403+
404+ class (Bounded a, Lattice a) <= BoundedLattice a
405+
406+ instance boundedLatticeBoolean :: BoundedLattice Boolean
407+
408+ instance boundedLatticeUnit :: BoundedLattice Unit
409+
410+ class (BoundedLattice a) <= ComplementedLattice a where
411+ not :: a -> a
412+
413+ instance complementedLatticeBoolean :: ComplementedLattice Boolean where
414+ not = boolNot
415+
416+ instance complementedLatticeUnit :: ComplementedLattice Unit where
417+ not _ = unit
418+
419+ class (Lattice a) <= DistributiveLattice a
420+
421+ instance distributiveLatticeBoolean :: DistributiveLattice Boolean
422+
423+ instance distributiveLatticeUnit :: DistributiveLattice Unit
424+
425+ class (ComplementedLattice a, DistributiveLattice a) <= BooleanAlgebra a
426+
427+ instance booleanAlgebraBoolean :: BooleanAlgebra Boolean
428+
429+ instance booleanAlgebraUnit :: BooleanAlgebra Unit
430+
431+ foreign import boolOr :: Boolean -> Boolean -> Boolean
432+
433+ foreign import boolAnd :: Boolean -> Boolean -> Boolean
434+
435+ foreign import boolNot :: Boolean -> Boolean
436+
437+ class Show a where
438+ show :: a -> String
439+
440+ instance showBoolean :: Show Boolean where
441+ show true = "true"
442+ show false = "false"
443+
444+ instance showNumber :: Show Number where
445+ show = showNumberImpl
446+
447+ instance showString :: Show String where
448+ show = showStringImpl
449+
450+ instance showUnit :: Show Unit where
451+ show _ = "unit"
452+
453+ instance showArray :: (Show a) => Show (Array a) where
454+ show = showArrayImpl show
455+
456+ instance showOrdering :: Show Ordering where
457+ show LT = "LT"
458+ show GT = "GT"
459+ show EQ = "EQ"
460+
461+ foreign import showNumberImpl :: Number -> String
462+
463+ foreign import showStringImpl :: String -> String
464+
465+ foreign import showArrayImpl :: forall a. (a -> String) -> Array a -> String
466+
467+module Data.Function where
468+
469+ import Prelude
470+
471+ on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c
472+ on f g x y = g x `f` g y
473+
474+ foreign import data Fn0 :: * -> *
475+
476+ foreign import data Fn1 :: * -> * -> *
477+
478+ foreign import data Fn2 :: * -> * -> * -> *
479+
480+ foreign import data Fn3 :: * -> * -> * -> * -> *
481+
482+ foreign import data Fn4 :: * -> * -> * -> * -> * -> *
483+
484+ foreign import data Fn5 :: * -> * -> * -> * -> * -> * -> *
485+
486+ foreign import data Fn6 :: * -> * -> * -> * -> * -> * -> * -> *
487+
488+ foreign import data Fn7 :: * -> * -> * -> * -> * -> * -> * -> * -> *
489+
490+ foreign import data Fn8 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> *
491+
492+ foreign import data Fn9 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *
493+
494+ foreign import data Fn10 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *
495+
496+ foreign import mkFn0 :: forall a. (Unit -> a) -> Fn0 a
497+
498+ foreign import mkFn1 :: forall a b. (a -> b) -> Fn1 a b
499+
500+ foreign import mkFn2 :: forall a b c. (a -> b -> c) -> Fn2 a b c
501+
502+ foreign import mkFn3 :: forall a b c d. (a -> b -> c -> d) -> Fn3 a b c d
503+
504+ foreign import mkFn4 :: forall a b c d e. (a -> b -> c -> d -> e) -> Fn4 a b c d e
505+
506+ foreign import mkFn5 :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Fn5 a b c d e f
507+
508+ 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
509+
510+ 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
511+
512+ 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
513+
514+ 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
515+
516+ 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
517+
518+ foreign import runFn0 :: forall a. Fn0 a -> a
519+
520+ foreign import runFn1 :: forall a b. Fn1 a b -> a -> b
521+
522+ foreign import runFn2 :: forall a b c. Fn2 a b c -> a -> b -> c
523+
524+ foreign import runFn3 :: forall a b c d. Fn3 a b c d -> a -> b -> c -> d
525+
526+ foreign import runFn4 :: forall a b c d e. Fn4 a b c d e -> a -> b -> c -> d -> e
527+
528+ foreign import runFn5 :: forall a b c d e f. Fn5 a b c d e f -> a -> b -> c -> d -> e -> f
529+
530+ 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
531+
532+ 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
533+
534+ 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
535+
536+ 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
537+
538+ 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
539+
540+module Assert where
541+
542+ import Prelude
543+ import Control.Monad.Eff
544+
545+ foreign import data Assert :: !
546+
547+ foreign import error :: forall a. String -> a
548+
549+ foreign import assertPartial :: forall e a. (Unit -> a) -> Eff (assert :: Assert | e) Unit
550+
551+ assert :: forall e. Boolean -> Eff (assert :: Assert | e) Unit
552+ assert true = return unit
553+ assert false = error "Assertion failed!"
554+
555+module Prelude.Unsafe where
556+
557+ foreign import unsafeIndex :: forall a. Array a -> Number -> a
558+
559+module Control.Monad.Eff
560+ ( Eff()
561+ , Pure()
562+ , runPure
563+ , untilE, whileE
564+ ) where
565+
566+ import Prelude
567+
568+ foreign import data Eff :: # ! -> * -> *
569+
570+ foreign import returnE :: forall e a. a -> Eff e a
571+
572+ foreign import bindE :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b
573+
574+ type Pure a = forall e. Eff e a
575+
576+ foreign import runPure :: forall a. Pure a -> a
577+
578+ instance functorEff :: Functor (Eff e) where
579+ (<$>) = liftA1
580+
581+ instance applyEff :: Apply (Eff e) where
582+ (<*>) = ap
583+
584+ instance applicativeEff :: Applicative (Eff e) where
585+ pure = returnE
586+
587+ instance bindEff :: Bind (Eff e) where
588+ (>>=) = bindE
589+
590+ instance monadEff :: Monad (Eff e)
591+
592+ foreign import untilE :: forall e. Eff e Boolean -> Eff e Unit
593+
594+ foreign import whileE :: forall e a. Eff e Boolean -> Eff e a -> Eff e Unit
595+
596+module Debug.Trace where
597+
598+ import Prelude
599+ import Control.Monad.Eff
600+
601+ foreign import data Trace :: !
602+
603+ foreign import trace :: forall r. String -> Eff (trace :: Trace | r) Unit
604+
605+ print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) Unit
606+ print o = trace (show o)
607+
608+module Control.Monad.ST where
609+
610+ import Prelude
611+ import Control.Monad.Eff
612+
613+ foreign import data ST :: * -> !
614+
615+ foreign import data STRef :: * -> * -> *
616+
617+ foreign import newSTRef :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)
618+
619+ foreign import readSTRef :: forall a h r. STRef h a -> Eff (st :: ST h | r) a
620+
621+ foreign import modifySTRef :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a
622+
623+ foreign import writeSTRef :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a
624+
625+ foreign import runST :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a
626+
627+ pureST :: forall a. (forall h r. Eff (st :: ST h | r) a) -> a
628+ pureST st = runPure (runST st)
tests/prelude/js/Assert.jsnew file+19
@@ -0,0 +1,19 @@
1+/* global exports */
2+"use strict";
3+
4+// module Assert
5+
6+exports.error = function(msg) {
7+ throw msg;
8+};
9+
10+exports.assertPartial = function(f) {
11+ return function() {
12+ try {
13+ return f();
14+ } catch (e) {
15+ if (e instanceof Error) return;
16+ throw new Error('Pattern match failure is not Error');
17+ }
18+ };
19+};
tests/prelude/js/Control.Monad.Eff.jsnew file+40
@@ -0,0 +1,40 @@
1+/* global exports */
2+"use strict";
3+
4+// module Control.Monad.Eff
5+
6+exports.returnE = function (a) {
7+ return function () {
8+ return a;
9+ };
10+};
11+
12+exports.bindE = function (a) {
13+ return function (f) {
14+ return function () {
15+ return f(a())();
16+ };
17+ };
18+};
19+
20+exports.runPure = function (f) {
21+ return f();
22+};
23+
24+exports.untilE = function (f) {
25+ return function () {
26+ while (!f());
27+ return {};
28+ };
29+};
30+
31+exports.whileE = function (f) {
32+ return function (a) {
33+ return function () {
34+ while (f()) {
35+ a();
36+ }
37+ return {};
38+ };
39+ };
40+};
tests/prelude/js/Control.Monad.ST.jsnew file+38
@@ -0,0 +1,38 @@
1+/* global exports */
2+"use strict";
3+
4+// module Control.Monad.ST
5+
6+exports.newSTRef = function (val) {
7+ return function () {
8+ return { value: val };
9+ };
10+};
11+
12+exports.readSTRef = function (ref) {
13+ return function () {
14+ return ref.value;
15+ };
16+};
17+
18+exports.modifySTRef = function (ref) {
19+ return function (f) {
20+ return function () {
21+ /* jshint boss: true */
22+ return ref.value = f(ref.value);
23+ };
24+ };
25+};
26+
27+exports.writeSTRef = function (ref) {
28+ return function (a) {
29+ return function () {
30+ /* jshint boss: true */
31+ return ref.value = a;
32+ };
33+ };
34+};
35+
36+exports.runST = function (f) {
37+ return f;
38+};
tests/prelude/js/Data.Function.jsnew file+233
@@ -0,0 +1,233 @@
1+/* global exports */
2+"use strict";
3+
4+// module Data.Function
5+
6+exports.mkFn0 = function (fn) {
7+ return function () {
8+ return fn({});
9+ };
10+};
11+
12+exports.mkFn1 = function (fn) {
13+ return function (a) {
14+ return fn(a);
15+ };
16+};
17+
18+exports.mkFn2 = function (fn) {
19+ /* jshint maxparams: 2 */
20+ return function (a, b) {
21+ return fn(a)(b);
22+ };
23+};
24+
25+exports.mkFn3 = function (fn) {
26+ /* jshint maxparams: 3 */
27+ return function (a, b, c) {
28+ return fn(a)(b)(c);
29+ };
30+};
31+
32+exports.mkFn4 = function (fn) {
33+ /* jshint maxparams: 4 */
34+ return function (a, b, c, d) {
35+ return fn(a)(b)(c)(d);
36+ };
37+};
38+
39+exports.mkFn5 = function (fn) {
40+ /* jshint maxparams: 5 */
41+ return function (a, b, c, d, e) {
42+ return fn(a)(b)(c)(d)(e);
43+ };
44+};
45+
46+exports.mkFn6 = function (fn) {
47+ /* jshint maxparams: 6 */
48+ return function (a, b, c, d, e, f) {
49+ return fn(a)(b)(c)(d)(e)(f);
50+ };
51+};
52+
53+exports.mkFn7 = function (fn) {
54+ /* jshint maxparams: 7 */
55+ return function (a, b, c, d, e, f, g) {
56+ return fn(a)(b)(c)(d)(e)(f)(g);
57+ };
58+};
59+
60+exports.mkFn8 = function (fn) {
61+ /* jshint maxparams: 8 */
62+ return function (a, b, c, d, e, f, g, h) {
63+ return fn(a)(b)(c)(d)(e)(f)(g)(h);
64+ };
65+};
66+
67+exports.mkFn9 = function (fn) {
68+ /* jshint maxparams: 9 */
69+ return function (a, b, c, d, e, f, g, h, i) {
70+ return fn(a)(b)(c)(d)(e)(f)(g)(h)(i);
71+ };
72+};
73+
74+exports.mkFn10 = function (fn) {
75+ /* jshint maxparams: 10 */
76+ return function (a, b, c, d, e, f, g, h, i, j) {
77+ return fn(a)(b)(c)(d)(e)(f)(g)(h)(i)(j);
78+ };
79+};
80+
81+exports.runFn0 = function (fn) {
82+ return fn();
83+};
84+
85+exports.runFn1 = function (fn) {
86+ return function (a) {
87+ return fn(a);
88+ };
89+};
90+
91+exports.runFn2 = function (fn) {
92+ return function (a) {
93+ return function (b) {
94+ return fn(a, b);
95+ };
96+ };
97+};
98+
99+exports.runFn3 = function (fn) {
100+ return function (a) {
101+ return function (b) {
102+ return function (c) {
103+ return fn(a, b, c);
104+ };
105+ };
106+ };
107+};
108+
109+exports.runFn4 = function (fn) {
110+ return function (a) {
111+ return function (b) {
112+ return function (c) {
113+ return function (d) {
114+ return fn(a, b, c, d);
115+ };
116+ };
117+ };
118+ };
119+};
120+
121+exports.runFn5 = function (fn) {
122+ return function (a) {
123+ return function (b) {
124+ return function (c) {
125+ return function (d) {
126+ return function (e) {
127+ return fn(a, b, c, d, e);
128+ };
129+ };
130+ };
131+ };
132+ };
133+};
134+
135+exports.runFn6 = function (fn) {
136+ return function (a) {
137+ return function (b) {
138+ return function (c) {
139+ return function (d) {
140+ return function (e) {
141+ return function (f) {
142+ return fn(a, b, c, d, e, f);
143+ };
144+ };
145+ };
146+ };
147+ };
148+ };
149+};
150+
151+exports.runFn7 = function (fn) {
152+ return function (a) {
153+ return function (b) {
154+ return function (c) {
155+ return function (d) {
156+ return function (e) {
157+ return function (f) {
158+ return function (g) {
159+ return fn(a, b, c, d, e, f, g);
160+ };
161+ };
162+ };
163+ };
164+ };
165+ };
166+ };
167+};
168+
169+exports.runFn8 = function (fn) {
170+ return function (a) {
171+ return function (b) {
172+ return function (c) {
173+ return function (d) {
174+ return function (e) {
175+ return function (f) {
176+ return function (g) {
177+ return function (h) {
178+ return fn(a, b, c, d, e, f, g, h);
179+ };
180+ };
181+ };
182+ };
183+ };
184+ };
185+ };
186+ };
187+};
188+
189+exports.runFn9 = function (fn) {
190+ return function (a) {
191+ return function (b) {
192+ return function (c) {
193+ return function (d) {
194+ return function (e) {
195+ return function (f) {
196+ return function (g) {
197+ return function (h) {
198+ return function (i) {
199+ return fn(a, b, c, d, e, f, g, h, i);
200+ };
201+ };
202+ };
203+ };
204+ };
205+ };
206+ };
207+ };
208+ };
209+};
210+
211+exports.runFn10 = function (fn) {
212+ return function (a) {
213+ return function (b) {
214+ return function (c) {
215+ return function (d) {
216+ return function (e) {
217+ return function (f) {
218+ return function (g) {
219+ return function (h) {
220+ return function (i) {
221+ return function (j) {
222+ return fn(a, b, c, d, e, f, g, h, i, j);
223+ };
224+ };
225+ };
226+ };
227+ };
228+ };
229+ };
230+ };
231+ };
232+ };
233+};
tests/prelude/js/Debug.Trace.jsnew file+11
@@ -0,0 +1,11 @@
1+/* global exports */
2+"use strict";
3+
4+// module Debug.Trace
5+
6+exports.trace = function(s) {
7+ return function() {
8+ console.log(s);
9+ return {};
10+ };
11+};
tests/prelude/js/Prelude.Unsafe.jsnew file+10
@@ -0,0 +1,10 @@
1+/* global exports */
2+"use strict";
3+
4+// module Prelude.Unsafe
5+
6+exports.unsafeIndex = function(xs) {
7+ return function(n) {
8+ return xs[n];
9+ };
10+};
tests/prelude/js/Prelude.jsnew file+150
@@ -0,0 +1,150 @@
1+/* global exports */
2+"use strict";
3+
4+// module Prelude
5+
6+exports.cons = function(e) {
7+ return function(l) {
8+ return [e].concat(l);
9+ };
10+};
11+
12+exports.concat = function(l1) {
13+ return function(l2) {
14+ return l1.concat(l2);
15+ };
16+};
17+
18+exports.length = function(a) {
19+ return a.length;
20+};
21+
22+exports.concatString = function(s1) {
23+ return function(s2) {
24+ return s1 + s2;
25+ };
26+};
27+
28+exports.numAdd = function (n1) {
29+ return function (n2) {
30+ return n1 + n2;
31+ };
32+};
33+
34+exports.numMul = function (n1) {
35+ return function (n2) {
36+ return n1 * n2;
37+ };
38+};
39+
40+exports.numDiv = function (n1) {
41+ return function (n2) {
42+ return n1 / n2;
43+ };
44+};
45+
46+exports.numSub = function (n1) {
47+ return function (n2) {
48+ return n1 - n2;
49+ };
50+};
51+
52+exports.jsMod = function(x) {
53+ return function (y) {
54+ return x % y;
55+ };
56+};
57+
58+exports.refEq = function(r1) {
59+ return function(r2) {
60+ return r1 === r2;
61+ };
62+};
63+
64+exports.refIneq = function(r1) {
65+ return function(r2) {
66+ return r1 !== r2;
67+ };
68+};
69+
70+exports.eqArrayImpl = function(f) {
71+ return function(xs) {
72+ return function(ys) {
73+ if (xs.length !== ys.length) return false;
74+ for (var i = 0; i < xs.length; i++) {
75+ if (!f(xs[i])(ys[i])) return false;
76+ }
77+ return true;
78+ };
79+ };
80+};
81+
82+exports.ordArrayImpl = function(f) {
83+ return function (ys) {
84+ return function (ys) {
85+ var i = 0;
86+ while (i < xs.length && i < ys.length) {
87+ var x = xs[i];
88+ var y = ys[i];
89+ var o = f(x)(y);
90+ if (o !== 0) {
91+ return o;
92+ }
93+ }
94+ if (xs.length == ys.length) {
95+ return 0;
96+ } else if (xs.length > ys.length) {
97+ return 1;
98+ } else {
99+ return -1;
100+ }
101+ };
102+ };
103+};
104+
105+exports.unsafeCompareImpl = function(lt) {
106+ return function(eq) {
107+ return function(gt) {
108+ return function(x) {
109+ return function(y) {
110+ return x < y ? lt : x > y ? gt : eq;
111+ };
112+ };
113+ };
114+ };
115+};
116+
117+exports.boolOr = function (b1) {
118+ return function (b2) {
119+ return b1 || b2;
120+ };
121+};
122+
123+exports.boolAnd = function (b1) {
124+ return function (b2) {
125+ return b1 && b2;
126+ };
127+};
128+
129+exports.boolNot = function (b) {
130+ return !b;
131+};
132+
133+exports.showNumberImpl = function (n) {
134+ /* jshint bitwise: false */
135+ return n === (n | 0) ? n + ".0" : n.toString();
136+};
137+
138+exports.showStringImpl = function (s) {
139+ return JSON.stringify(s);
140+};
141+
142+exports.showArrayImpl = function (f) {
143+ return function (xs) {
144+ var ss = [];
145+ for (var i = 0, l = xs.length; i < l; i++) {
146+ ss[i] = f(xs[i]);
147+ }
148+ return "[" + ss.join(",") + "]";
149+ };
150+};