summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-08-11 20:42:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-08-11 20:42:00 (GMT)
commite1f3c26bb8330dc4d13df8914cf1427cc952d425 (patch)
tree8d4b87826aa796e86dd259df2bd9064987209a25
parent809181909fa5b629752975240cb6f3315d340519 (diff)
version 0.5.4.10.5.4.1
-rw-r--r--examples/failing/ArrayType.purs11
-rw-r--r--examples/failing/Arrays.purs5
-rw-r--r--examples/failing/Do.purs8
-rw-r--r--examples/failing/KindError.purs3
-rw-r--r--examples/failing/Let.purs3
-rw-r--r--examples/failing/MPTCs.purs7
-rw-r--r--examples/failing/MutRec.purs5
-rw-r--r--examples/failing/MutRec2.purs3
-rw-r--r--examples/failing/NewtypeMultiArgs.purs3
-rw-r--r--examples/failing/NewtypeMultiCtor.purs3
-rw-r--r--examples/failing/NoOverlap.purs11
-rw-r--r--examples/failing/NullaryAbs.purs3
-rw-r--r--examples/failing/Object.purs5
-rw-r--r--examples/failing/OverlappingVars.purs12
-rw-r--r--examples/failing/Rank2Types.purs7
-rw-r--r--examples/failing/Reserved.purs4
-rw-r--r--examples/failing/SkolemEscape.purs5
-rw-r--r--examples/failing/SkolemEscape2.purs9
-rw-r--r--examples/failing/Superclasses1.purs11
-rw-r--r--examples/failing/Superclasses2.purs9
-rw-r--r--examples/failing/Superclasses3.purs5
-rw-r--r--examples/failing/Superclasses4.purs12
-rw-r--r--examples/failing/TypeClassInstances.purs8
-rw-r--r--examples/failing/TypeClasses2.purs8
-rw-r--r--examples/failing/TypeError.purs5
-rw-r--r--examples/failing/TypeSynonyms.purs5
-rw-r--r--examples/failing/TypeSynonyms2.purs9
-rw-r--r--examples/failing/TypeSynonyms3.purs9
-rw-r--r--examples/failing/UnifyInTypeInstanceLookup.purs17
-rw-r--r--examples/failing/UnknownType.purs4
-rw-r--r--examples/failing/UnknownValue.purs25
-rw-r--r--examples/passing/Applicative.purs16
-rw-r--r--examples/passing/ArrayType.purs9
-rw-r--r--examples/passing/Arrays.purs24
-rw-r--r--examples/passing/Auto.purs13
-rw-r--r--examples/passing/AutoPrelude.purs8
-rw-r--r--examples/passing/AutoPrelude2.purs9
-rw-r--r--examples/passing/BindersInFunctions.purs16
-rw-r--r--examples/passing/CheckSynonymBug.purs14
-rw-r--r--examples/passing/CheckTypeClass.purs16
-rw-r--r--examples/passing/Church.purs18
-rw-r--r--examples/passing/Collatz.purs18
-rw-r--r--examples/passing/Comparisons.purs23
-rw-r--r--examples/passing/Conditional.purs9
-rw-r--r--examples/passing/Console.purs13
-rw-r--r--examples/passing/DataAndType.purs7
-rw-r--r--examples/passing/DeepCase.purs14
-rw-r--r--examples/passing/Do.purs67
-rw-r--r--examples/passing/Dollar.purs16
-rw-r--r--examples/passing/Eff.purs19
-rw-r--r--examples/passing/EmptyDataDecls.purs30
-rw-r--r--examples/passing/EmptyTypeClass.purs12
-rw-r--r--examples/passing/EqOrd.purs14
-rw-r--r--examples/passing/ExternData.purs13
-rw-r--r--examples/passing/ExternRaw.purs13
-rw-r--r--examples/passing/FFI.purs11
-rw-r--r--examples/passing/Fib.purs15
-rw-r--r--examples/passing/FinalTagless.purs22
-rw-r--r--examples/passing/ForeignInstance.purs16
-rw-r--r--examples/passing/FunctionScope.purs17
-rw-r--r--examples/passing/Functions.purs15
-rw-r--r--examples/passing/Functions2.purs17
-rw-r--r--examples/passing/Guards.purs14
-rw-r--r--examples/passing/HoistError.purs17
-rw-r--r--examples/passing/ImportHiding.purs18
-rw-r--r--examples/passing/InferRecFunWithConstrainedArgument.purs8
-rw-r--r--examples/passing/JSReserved.purs12
-rw-r--r--examples/passing/Let.purs64
-rw-r--r--examples/passing/LetInInstance.purs12
-rw-r--r--examples/passing/LiberalTypeSynonyms.purs19
-rw-r--r--examples/passing/MPTCs.purs20
-rw-r--r--examples/passing/Match.purs7
-rw-r--r--examples/passing/Monad.purs32
-rw-r--r--examples/passing/MonadState.purs48
-rw-r--r--examples/passing/MultiArgFunctions.purs26
-rw-r--r--examples/passing/MultipleConstructorArgs.purs21
-rw-r--r--examples/passing/MutRec.purs19
-rw-r--r--examples/passing/NamedPatterns.purs7
-rw-r--r--examples/passing/Nested.purs7
-rw-r--r--examples/passing/NestedTypeSynonyms.purs11
-rw-r--r--examples/passing/Newtype.purs22
-rw-r--r--examples/passing/NewtypeEff.purs28
-rw-r--r--examples/passing/ObjectSynonym.purs13
-rw-r--r--examples/passing/ObjectUpdate.purs18
-rw-r--r--examples/passing/Objects.purs30
-rw-r--r--examples/passing/OneConstructor.purs7
-rw-r--r--examples/passing/Operators.purs80
-rw-r--r--examples/passing/OptimizerBug.purs9
-rw-r--r--examples/passing/PartialFunction.purs17
-rw-r--r--examples/passing/Patterns.purs28
-rw-r--r--examples/passing/Person.purs16
-rw-r--r--examples/passing/Rank2Data.purs29
-rw-r--r--examples/passing/Rank2Object.purs10
-rw-r--r--examples/passing/Rank2TypeSynonym.purs15
-rw-r--r--examples/passing/Rank2Types.purs11
-rw-r--r--examples/passing/Recursion.purs10
-rw-r--r--examples/passing/RuntimeScopeIssue.purs19
-rw-r--r--examples/passing/STArray.purs25
-rw-r--r--examples/passing/Sequence.purs12
-rw-r--r--examples/passing/ShadowedRename.purs19
-rw-r--r--examples/passing/ShadowedTCO.purs16
-rw-r--r--examples/passing/ShadowedTCOLet.purs7
-rw-r--r--examples/passing/SignedNumericLiterals.purs15
-rw-r--r--examples/passing/Superclasses1.purs18
-rw-r--r--examples/passing/Superclasses2.purs23
-rw-r--r--examples/passing/Superclasses3.purs41
-rw-r--r--examples/passing/TCOCase.purs10
-rw-r--r--examples/passing/TailCall.purs15
-rw-r--r--examples/passing/Tick.purs5
-rw-r--r--examples/passing/TopLevelCase.purs18
-rw-r--r--examples/passing/TypeClassMemberOrderChange.purs11
-rw-r--r--examples/passing/TypeClasses.purs69
-rw-r--r--examples/passing/TypeClassesInOrder.purs11
-rw-r--r--examples/passing/TypeClassesWithOverlappingTypeVariables.purs11
-rw-r--r--examples/passing/TypeDecl.purs12
-rw-r--r--examples/passing/TypeSynonymInData.purs9
-rw-r--r--examples/passing/TypeSynonyms.purs25
-rw-r--r--examples/passing/TypedWhere.purs13
-rw-r--r--examples/passing/Unit.purs6
-rw-r--r--examples/passing/UnknownInTypeClassLookup.purs12
-rw-r--r--examples/passing/Where.purs49
-rw-r--r--examples/passing/iota.purs9
-rw-r--r--examples/passing/s.purs5
-rw-r--r--prelude/prelude.purs9
-rw-r--r--psci/Commands.hs8
-rw-r--r--psci/Main.hs35
-rw-r--r--purescript.cabal9
-rw-r--r--src/Language/PureScript.hs2
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs13
-rw-r--r--src/Language/PureScript/Constants.hs3
-rw-r--r--src/Language/PureScript/DeadCodeElimination.hs2
-rw-r--r--src/Language/PureScript/Declarations.hs98
-rw-r--r--src/Language/PureScript/Errors.hs6
-rw-r--r--src/Language/PureScript/ModuleDependencies.hs2
-rw-r--r--src/Language/PureScript/Optimizer/Inliner.hs4
-rw-r--r--src/Language/PureScript/Optimizer/MagicDo.hs2
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs55
-rw-r--r--src/Language/PureScript/Pretty/Values.hs24
-rw-r--r--src/Language/PureScript/Renamer.hs10
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs6
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs6
-rw-r--r--src/Language/PureScript/Sugar/DoNotation.hs8
-rw-r--r--src/Language/PureScript/Sugar/Names.hs97
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs16
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs8
-rw-r--r--src/Language/PureScript/Sugar/TypeDeclarations.hs2
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs81
147 files changed, 2238 insertions, 216 deletions
diff --git a/examples/failing/ArrayType.purs b/examples/failing/ArrayType.purs
new file mode 100644
index 0000000..75d4893
--- /dev/null
+++ b/examples/failing/ArrayType.purs
@@ -0,0 +1,11 @@
+module Main where
+
+import Debug.Trace
+
+bar :: Number -> Number -> Number
+bar n m = n + m
+
+foo = x `bar` y
+ where
+ x = 1
+ y = []
diff --git a/examples/failing/Arrays.purs b/examples/failing/Arrays.purs
new file mode 100644
index 0000000..eb5abba
--- /dev/null
+++ b/examples/failing/Arrays.purs
@@ -0,0 +1,5 @@
+module Main where
+
+ import Prelude
+
+ test = \arr -> arr !! (0 !! 0)
diff --git a/examples/failing/Do.purs b/examples/failing/Do.purs
new file mode 100644
index 0000000..fae1630
--- /dev/null
+++ b/examples/failing/Do.purs
@@ -0,0 +1,8 @@
+module Main where
+
+test1 = do let x = 1
+
+test2 y = do x <- y
+
+test3 = do return 1
+ return 2
diff --git a/examples/failing/KindError.purs b/examples/failing/KindError.purs
new file mode 100644
index 0000000..f550505
--- /dev/null
+++ b/examples/failing/KindError.purs
@@ -0,0 +1,3 @@
+module Main where
+
+ data KindError f a = One f | Two (f a)
diff --git a/examples/failing/Let.purs b/examples/failing/Let.purs
new file mode 100644
index 0000000..06e0748
--- /dev/null
+++ b/examples/failing/Let.purs
@@ -0,0 +1,3 @@
+module Main where
+
+test = let x = x in x
diff --git a/examples/failing/MPTCs.purs b/examples/failing/MPTCs.purs
new file mode 100644
index 0000000..3d1dbe4
--- /dev/null
+++ b/examples/failing/MPTCs.purs
@@ -0,0 +1,7 @@
+module Main where
+
+class Foo a where
+ f :: a -> a
+
+instance fooStringString :: Foo String String where
+ f a = a
diff --git a/examples/failing/MutRec.purs b/examples/failing/MutRec.purs
new file mode 100644
index 0000000..48757eb
--- /dev/null
+++ b/examples/failing/MutRec.purs
@@ -0,0 +1,5 @@
+module MutRec where
+
+x = y
+
+y = x
diff --git a/examples/failing/MutRec2.purs b/examples/failing/MutRec2.purs
new file mode 100644
index 0000000..52dd5b3
--- /dev/null
+++ b/examples/failing/MutRec2.purs
@@ -0,0 +1,3 @@
+module Main where
+
+x = x
diff --git a/examples/failing/NewtypeMultiArgs.purs b/examples/failing/NewtypeMultiArgs.purs
new file mode 100644
index 0000000..1c48962
--- /dev/null
+++ b/examples/failing/NewtypeMultiArgs.purs
@@ -0,0 +1,3 @@
+module Main where
+
+newtype Thing = Thing String Boolean \ No newline at end of file
diff --git a/examples/failing/NewtypeMultiCtor.purs b/examples/failing/NewtypeMultiCtor.purs
new file mode 100644
index 0000000..9f6a341
--- /dev/null
+++ b/examples/failing/NewtypeMultiCtor.purs
@@ -0,0 +1,3 @@
+module Main where
+
+newtype Thing = Thing String | Other \ No newline at end of file
diff --git a/examples/failing/NoOverlap.purs b/examples/failing/NoOverlap.purs
new file mode 100644
index 0000000..23b2897
--- /dev/null
+++ b/examples/failing/NoOverlap.purs
@@ -0,0 +1,11 @@
+module Main where
+
+data Foo = Foo
+
+instance showFoo1 :: Show Foo where
+ show _ = "Foo"
+
+instance showFoo2 :: Show Foo where
+ show _ = "Bar"
+
+test = show Foo
diff --git a/examples/failing/NullaryAbs.purs b/examples/failing/NullaryAbs.purs
new file mode 100644
index 0000000..72ac0fe
--- /dev/null
+++ b/examples/failing/NullaryAbs.purs
@@ -0,0 +1,3 @@
+module Main where
+
+ func = \ -> "no"
diff --git a/examples/failing/Object.purs b/examples/failing/Object.purs
new file mode 100644
index 0000000..7df3309
--- /dev/null
+++ b/examples/failing/Object.purs
@@ -0,0 +1,5 @@
+module Main where
+
+test o = o.foo
+
+test1 = test {}
diff --git a/examples/failing/OverlappingVars.purs b/examples/failing/OverlappingVars.purs
new file mode 100644
index 0000000..a6c83ea
--- /dev/null
+++ b/examples/failing/OverlappingVars.purs
@@ -0,0 +1,12 @@
+module Main where
+
+class OverlappingVars a where
+ f :: a -> a
+
+data Foo a b = Foo a b
+
+instance overlappingVarsFoo :: OverlappingVars (Foo a a) where
+ f a = a
+
+test = f (Foo "" 0)
+
diff --git a/examples/failing/Rank2Types.purs b/examples/failing/Rank2Types.purs
new file mode 100644
index 0000000..11e69f2
--- /dev/null
+++ b/examples/failing/Rank2Types.purs
@@ -0,0 +1,7 @@
+module Main where
+
+ import Prelude
+
+ foreign import test :: (forall a. a -> a) -> Number
+
+ test1 = test (\n -> n + 1)
diff --git a/examples/failing/Reserved.purs b/examples/failing/Reserved.purs
new file mode 100644
index 0000000..2a14304
--- /dev/null
+++ b/examples/failing/Reserved.purs
@@ -0,0 +1,4 @@
+module Main where
+
+(<) :: Number -> Number -> Number
+(<) a b = !(a >= b)
diff --git a/examples/failing/SkolemEscape.purs b/examples/failing/SkolemEscape.purs
new file mode 100644
index 0000000..f7acaa4
--- /dev/null
+++ b/examples/failing/SkolemEscape.purs
@@ -0,0 +1,5 @@
+module Main where
+
+ foreign import foo :: (forall a. a -> a) -> Number
+
+ test = \x -> foo x
diff --git a/examples/failing/SkolemEscape2.purs b/examples/failing/SkolemEscape2.purs
new file mode 100644
index 0000000..48bb9f0
--- /dev/null
+++ b/examples/failing/SkolemEscape2.purs
@@ -0,0 +1,9 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff
+import Control.Monad.ST
+
+test _ = do
+ r <- runST (newSTRef 0)
+ return 0
diff --git a/examples/failing/Superclasses1.purs b/examples/failing/Superclasses1.purs
new file mode 100644
index 0000000..571ef30
--- /dev/null
+++ b/examples/failing/Superclasses1.purs
@@ -0,0 +1,11 @@
+module Main where
+
+class Su a where
+ su :: a -> a
+
+class (Su a) <= Cl a where
+ cl :: a -> a -> a
+
+instance clNumber :: Cl Number where
+ cl n m = n + m
+
diff --git a/examples/failing/Superclasses2.purs b/examples/failing/Superclasses2.purs
new file mode 100644
index 0000000..93e1205
--- /dev/null
+++ b/examples/failing/Superclasses2.purs
@@ -0,0 +1,9 @@
+module CycleInSuperclasses where
+
+class (Foo a) <= Bar a
+
+class (Bar a) <= Foo a
+
+instance barString :: Bar String
+
+instance fooString :: Foo String
diff --git a/examples/failing/Superclasses3.purs b/examples/failing/Superclasses3.purs
new file mode 100644
index 0000000..8332b59
--- /dev/null
+++ b/examples/failing/Superclasses3.purs
@@ -0,0 +1,5 @@
+module UnknownSuperclassTypeVar where
+
+class Foo a
+
+class (Foo b) <= Bar a
diff --git a/examples/failing/Superclasses4.purs b/examples/failing/Superclasses4.purs
new file mode 100644
index 0000000..fba660b
--- /dev/null
+++ b/examples/failing/Superclasses4.purs
@@ -0,0 +1,12 @@
+module OverlappingInstances where
+
+class Foo a
+
+instance foo1 :: Foo Number
+
+instance foo2 :: Foo Number
+
+test :: forall a. (Foo a) => a -> a
+test a = a
+
+test1 = test 0
diff --git a/examples/failing/TypeClassInstances.purs b/examples/failing/TypeClassInstances.purs
new file mode 100644
index 0000000..59bd0ff
--- /dev/null
+++ b/examples/failing/TypeClassInstances.purs
@@ -0,0 +1,8 @@
+module Main where
+
+class A a where
+ a :: a -> String
+ b :: a -> Number
+
+instance aString :: A String where
+ a s = s
diff --git a/examples/failing/TypeClasses2.purs b/examples/failing/TypeClasses2.purs
new file mode 100644
index 0000000..cdaa921
--- /dev/null
+++ b/examples/failing/TypeClasses2.purs
@@ -0,0 +1,8 @@
+module Main where
+
+import Prelude ()
+
+class Show a where
+ show :: a -> String
+
+test = show "testing"
diff --git a/examples/failing/TypeError.purs b/examples/failing/TypeError.purs
new file mode 100644
index 0000000..a4c7fbc
--- /dev/null
+++ b/examples/failing/TypeError.purs
@@ -0,0 +1,5 @@
+module Main where
+
+ import Prelude
+
+ test = 1 ++ "A"
diff --git a/examples/failing/TypeSynonyms.purs b/examples/failing/TypeSynonyms.purs
new file mode 100644
index 0000000..b1016ad
--- /dev/null
+++ b/examples/failing/TypeSynonyms.purs
@@ -0,0 +1,5 @@
+module Main where
+
+type T1 = [T2]
+
+type T2 = T1
diff --git a/examples/failing/TypeSynonyms2.purs b/examples/failing/TypeSynonyms2.purs
new file mode 100644
index 0000000..5f668f8
--- /dev/null
+++ b/examples/failing/TypeSynonyms2.purs
@@ -0,0 +1,9 @@
+module Main where
+
+class Foo a where
+ foo :: a -> String
+
+type Bar = String
+
+instance fooBar :: Foo Bar where
+ foo s = s
diff --git a/examples/failing/TypeSynonyms3.purs b/examples/failing/TypeSynonyms3.purs
new file mode 100644
index 0000000..5f668f8
--- /dev/null
+++ b/examples/failing/TypeSynonyms3.purs
@@ -0,0 +1,9 @@
+module Main where
+
+class Foo a where
+ foo :: a -> String
+
+type Bar = String
+
+instance fooBar :: Foo Bar where
+ foo s = s
diff --git a/examples/failing/UnifyInTypeInstanceLookup.purs b/examples/failing/UnifyInTypeInstanceLookup.purs
new file mode 100644
index 0000000..815312a
--- /dev/null
+++ b/examples/failing/UnifyInTypeInstanceLookup.purs
@@ -0,0 +1,17 @@
+module Main where
+
+data Z = Z
+data S n = S n
+
+data T
+data F
+
+class EQ x y b
+instance eqT :: EQ x x T
+instance eqF :: EQ x y F
+
+foreign import test :: forall a b. (EQ a b T) => a -> b -> a
+
+foreign import anyNat :: forall a. a
+
+test1 = test anyNat (S Z)
diff --git a/examples/failing/UnknownType.purs b/examples/failing/UnknownType.purs
new file mode 100644
index 0000000..b3b0038
--- /dev/null
+++ b/examples/failing/UnknownType.purs
@@ -0,0 +1,4 @@
+module Main where
+
+test :: Number -> Something
+test = {} \ No newline at end of file
diff --git a/examples/failing/UnknownValue.purs b/examples/failing/UnknownValue.purs
new file mode 100644
index 0000000..c1f458c
--- /dev/null
+++ b/examples/failing/UnknownValue.purs
@@ -0,0 +1,25 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff
+import Control.Monad.ST
+import Debug.Trace
+
+test = runSTArray (do
+ a <- newSTArray 2 0
+ pokeSTArray a 0 1
+ pokeSTArray a 1 2
+ return a)
+
+fromTo lo hi = runSTArray (do
+ arr <- newSTArray (hi - lo + 1) 0
+ (let
+ go lo hi _ arr | lo > hi = return arr
+ go lo hi i arr = do
+ pokeSTArray arrr i lo
+ go (lo + 1) hi (i + 1) arr
+ in go lo hi 0 arr))
+
+main = do
+ let t1 = runPure (fromTo 10 20)
+ trace "Done"
diff --git a/examples/passing/Applicative.purs b/examples/passing/Applicative.purs
new file mode 100644
index 0000000..7c77c7e
--- /dev/null
+++ b/examples/passing/Applicative.purs
@@ -0,0 +1,16 @@
+module Main where
+
+import Prelude ()
+
+class Applicative f where
+ pure :: forall a. a -> f a
+ (<*>) :: forall a b. f (a -> b) -> f a -> f b
+
+data Maybe a = Nothing | Just a
+
+instance applicativeMaybe :: Applicative Maybe where
+ pure = Just
+ (<*>) (Just f) (Just a) = Just (f a)
+ (<*>) _ _ = Nothing
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/passing/ArrayType.purs b/examples/passing/ArrayType.purs
new file mode 100644
index 0000000..8faa88a
--- /dev/null
+++ b/examples/passing/ArrayType.purs
@@ -0,0 +1,9 @@
+module Main where
+
+class Pointed p where
+ point :: forall a. a -> p a
+
+instance pointedArray :: Pointed [] where
+ point a = [a]
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/passing/Arrays.purs b/examples/passing/Arrays.purs
new file mode 100644
index 0000000..7a7c53b
--- /dev/null
+++ b/examples/passing/Arrays.purs
@@ -0,0 +1,24 @@
+module Main where
+
+import Prelude.Unsafe (unsafeIndex)
+
+test1 arr = arr `unsafeIndex` 0 + arr `unsafeIndex` 1 + 1
+
+test2 = \arr -> case arr of
+ [x, y] -> x + y
+ [x] -> x
+ [] -> 0
+ (x : y : _) -> x + y
+
+data Tree = One Number | Some [Tree]
+
+test3 = \tree sum -> case tree of
+ One n -> n
+ Some (n1 : n2 : rest) -> test3 n1 sum * 10 + test3 n2 sum * 5 + sum rest
+
+test4 = \arr -> case arr of
+ [] -> 0
+ [_] -> 0
+ x : y : xs -> x * y + test4 xs
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/passing/Auto.purs b/examples/passing/Auto.purs
new file mode 100644
index 0000000..6484551
--- /dev/null
+++ b/examples/passing/Auto.purs
@@ -0,0 +1,13 @@
+module Main where
+
+ data Auto s i o = Auto { state :: s, step :: s -> i -> o }
+
+ type SomeAuto i o = forall r. (forall s. Auto s i o -> r) -> r
+
+ exists :: forall s i o. s -> (s -> i -> o) -> SomeAuto i o
+ exists = \state step f -> f (Auto { state: state, step: step })
+
+ run :: forall i o. SomeAuto i o -> i -> o
+ run = \s i -> s (\a -> case a of Auto a -> a.step a.state i)
+
+ main = Debug.Trace.trace "Done"
diff --git a/examples/passing/AutoPrelude.purs b/examples/passing/AutoPrelude.purs
new file mode 100644
index 0000000..6f3bdad
--- /dev/null
+++ b/examples/passing/AutoPrelude.purs
@@ -0,0 +1,8 @@
+module Main where
+
+import Debug.Trace
+
+f x = x * 10
+g y = y - 10
+
+main = trace $ show $ (f <<< g) 100
diff --git a/examples/passing/AutoPrelude2.purs b/examples/passing/AutoPrelude2.purs
new file mode 100644
index 0000000..0bc90bb
--- /dev/null
+++ b/examples/passing/AutoPrelude2.purs
@@ -0,0 +1,9 @@
+module Main where
+
+import qualified Prelude as P
+import Debug.Trace
+
+f :: forall a. a -> a
+f = P.id
+
+main = P.($) trace ((f P.<<< f) "Done")
diff --git a/examples/passing/BindersInFunctions.purs b/examples/passing/BindersInFunctions.purs
new file mode 100644
index 0000000..3ded5f2
--- /dev/null
+++ b/examples/passing/BindersInFunctions.purs
@@ -0,0 +1,16 @@
+module Main where
+
+import Prelude
+
+tail = \(_:xs) -> xs
+
+foreign import error
+ "function error(msg) {\
+ \ throw msg;\
+ \}" :: forall a. String -> a
+
+main =
+ let ts = tail [1, 2, 3] in
+ if ts == [2, 3]
+ then Debug.Trace.trace "Done"
+ else error "Incorrect result from 'tails'."
diff --git a/examples/passing/CheckSynonymBug.purs b/examples/passing/CheckSynonymBug.purs
new file mode 100644
index 0000000..c449634
--- /dev/null
+++ b/examples/passing/CheckSynonymBug.purs
@@ -0,0 +1,14 @@
+module Main where
+
+ import Prelude
+
+ type Foo a = [a]
+
+ foreign import length
+ "function length(a) {\
+ \ return a.length;\
+ \}" :: forall a. [a] -> Number
+
+ foo _ = length ([] :: Foo Number)
+
+ main = Debug.Trace.trace "Done"
diff --git a/examples/passing/CheckTypeClass.purs b/examples/passing/CheckTypeClass.purs
new file mode 100644
index 0000000..6f172f9
--- /dev/null
+++ b/examples/passing/CheckTypeClass.purs
@@ -0,0 +1,16 @@
+module Main where
+
+ data Bar a = Bar
+ data Baz
+
+ class Foo a where
+ foo :: Bar a -> Baz
+
+ foo_ :: forall a. (Foo a) => a -> Baz
+ foo_ x = foo ((mkBar :: forall a. (Foo a) => a -> Bar a) x)
+
+ mkBar :: forall a. a -> Bar a
+ mkBar _ = Bar
+
+ main = Debug.Trace.trace "Done"
+
diff --git a/examples/passing/Church.purs b/examples/passing/Church.purs
new file mode 100644
index 0000000..f563992
--- /dev/null
+++ b/examples/passing/Church.purs
@@ -0,0 +1,18 @@
+module Main where
+
+ import Prelude ()
+
+ type List a = forall r. r -> (a -> r -> r) -> r
+
+ empty :: forall a. List a
+ empty = \r f -> r
+
+ cons :: forall a. a -> List a -> List a
+ cons = \a l r f -> f a (l r f)
+
+ append :: forall a. List a -> List a -> List a
+ append = \l1 l2 r f -> l2 (l1 r f) f
+
+ test = append (cons 1 empty) (cons 2 empty)
+
+ main = Debug.Trace.trace "Done"
diff --git a/examples/passing/Collatz.purs b/examples/passing/Collatz.purs
new file mode 100644
index 0000000..f61a950
--- /dev/null
+++ b/examples/passing/Collatz.purs
@@ -0,0 +1,18 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff
+import Control.Monad.ST
+
+collatz :: Number -> Number
+collatz n = runPure (runST (do
+ r <- newSTRef n
+ count <- newSTRef 0
+ untilE $ do
+ modifySTRef count $ (+) 1
+ m <- readSTRef r
+ writeSTRef r $ if m % 2 == 0 then m / 2 else 3 * m + 1
+ return $ m == 1
+ readSTRef count))
+
+main = Debug.Trace.print $ collatz 1000
diff --git a/examples/passing/Comparisons.purs b/examples/passing/Comparisons.purs
new file mode 100644
index 0000000..e8eb34c
--- /dev/null
+++ b/examples/passing/Comparisons.purs
@@ -0,0 +1,23 @@
+module Main where
+
+import Control.Monad.Eff
+import Debug.Trace
+
+foreign import data Assert :: !
+
+foreign import assert
+ "function assert(x) {\
+ \ return function () {\
+ \ if (!x) throw new Error('assertion failed');\
+ \ return {};\
+ \ };\
+ \};" :: forall e. Boolean -> Eff (assert :: Assert | e) Unit
+
+main = do
+ assert (1 < 2)
+ assert (2 == 2)
+ assert (3 > 1)
+ assert ("a" < "b")
+ assert ("a" == "a")
+ assert ("z" > "a")
+ trace "Done!"
diff --git a/examples/passing/Conditional.purs b/examples/passing/Conditional.purs
new file mode 100644
index 0000000..759aeb3
--- /dev/null
+++ b/examples/passing/Conditional.purs
@@ -0,0 +1,9 @@
+module Main where
+
+ import Prelude ()
+
+ fns = \f -> if f true then f else \x -> x
+
+ not = \x -> if x then false else true
+
+ main = Debug.Trace.trace "Done"
diff --git a/examples/passing/Console.purs b/examples/passing/Console.purs
new file mode 100644
index 0000000..a0f8a1f
--- /dev/null
+++ b/examples/passing/Console.purs
@@ -0,0 +1,13 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff
+import Debug.Trace
+
+replicateM_ :: forall m a. (Monad m) => Number -> m a -> m {}
+replicateM_ 0 _ = return {}
+replicateM_ n act = do
+ act
+ replicateM_ (n - 1) act
+
+main = replicateM_ 10 (trace "Hello World!")
diff --git a/examples/passing/DataAndType.purs b/examples/passing/DataAndType.purs
new file mode 100644
index 0000000..711082a
--- /dev/null
+++ b/examples/passing/DataAndType.purs
@@ -0,0 +1,7 @@
+module Main where
+
+data A = A B
+
+type B = A
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/passing/DeepCase.purs b/examples/passing/DeepCase.purs
new file mode 100644
index 0000000..ba0275c
--- /dev/null
+++ b/examples/passing/DeepCase.purs
@@ -0,0 +1,14 @@
+module Main where
+
+import Debug.Trace
+import Control.Monad.Eff
+import Control.Monad.ST
+
+f x y =
+ let
+ g = case y of
+ 0 -> x
+ x -> 1 + x * x
+ in g + x + y
+
+main = print $ f 1 10
diff --git a/examples/passing/Do.purs b/examples/passing/Do.purs
new file mode 100644
index 0000000..a995f36
--- /dev/null
+++ b/examples/passing/Do.purs
@@ -0,0 +1,67 @@
+module Main where
+
+import Prelude
+
+data Maybe a = Nothing | Just a
+
+instance functorMaybe :: Functor Maybe where
+ (<$>) f Nothing = Nothing
+ (<$>) f (Just x) = Just (f x)
+
+instance applyMaybe :: Apply Maybe where
+ (<*>) (Just f) (Just x) = Just (f x)
+ (<*>) _ _ = Nothing
+
+instance applicativeMaybe :: Applicative Maybe where
+ pure = Just
+
+instance bindMaybe :: Bind Maybe where
+ (>>=) Nothing _ = Nothing
+ (>>=) (Just a) f = f a
+
+instance monadMaybe :: Prelude.Monad Maybe
+
+test1 = \_ -> do
+ Just "abc"
+
+test2 = \_ -> do
+ (x : _) <- Just [1, 2, 3]
+ (y : _) <- Just [4, 5, 6]
+ Just (x + y)
+
+test3 = \_ -> do
+ Just 1
+ Nothing :: Maybe Number
+ Just 2
+
+test4 mx my = do
+ x <- mx
+ y <- my
+ Just (x + y + 1)
+
+test5 mx my mz = do
+ x <- mx
+ y <- my
+ let sum = x + y
+ z <- mz
+ Just (z + sum + 1)
+
+test6 mx = \_ -> do
+ let
+ f :: forall a. Maybe a -> a
+ f (Just x) = x
+ Just (f mx)
+
+test8 = \_ -> do
+ Just (do
+ Just 1)
+
+test9 = \_ -> (+) <$> Just 1 <*> Just 2
+
+test10 _ = do
+ let
+ f x = g x * 3
+ g x = f x / 2
+ Just (f 10)
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/passing/Dollar.purs b/examples/passing/Dollar.purs
new file mode 100644
index 0000000..c2e7c2b
--- /dev/null
+++ b/examples/passing/Dollar.purs
@@ -0,0 +1,16 @@
+module Main where
+
+import Prelude ()
+
+($) :: forall a b. (a -> b) -> a -> b
+($) f x = f x
+
+infixr 1000 $
+
+id x = x
+
+test1 x = id $ id $ id $ id $ x
+
+test2 x = id id $ id x
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/passing/Eff.purs b/examples/passing/Eff.purs
new file mode 100644
index 0000000..f64bb86
--- /dev/null
+++ b/examples/passing/Eff.purs
@@ -0,0 +1,19 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff
+import Control.Monad.ST
+import Debug.Trace
+
+test1 = do
+ trace "Line 1"
+ trace "Line 2"
+
+test2 = runPure (runST (do
+ ref <- newSTRef 0
+ modifySTRef ref $ \n -> n + 1
+ readSTRef ref))
+
+main = do
+ test1
+ Debug.Trace.print test2
diff --git a/examples/passing/EmptyDataDecls.purs b/examples/passing/EmptyDataDecls.purs
new file mode 100644
index 0000000..f84508d
--- /dev/null
+++ b/examples/passing/EmptyDataDecls.purs
@@ -0,0 +1,30 @@
+module Main where
+
+import Prelude
+
+data Z
+data S n
+
+data ArrayBox n a = ArrayBox [a]
+
+nil :: forall a. ArrayBox Z a
+nil = ArrayBox []
+
+foreign import concat
+ "function concat(l1) {\
+ \ return function (l2) {\
+ \ return l1.concat(l2);\
+ \ };\
+ \}" :: forall a. [a] -> [a] -> [a]
+
+cons' :: forall a n. a -> ArrayBox n a -> ArrayBox (S n) a
+cons' x (ArrayBox xs) = ArrayBox $ concat [x] xs
+
+foreign import error
+ "function error(msg) {\
+ \ throw msg;\
+ \}" :: forall a. String -> a
+
+main = case cons' 1 $ cons' 2 $ cons' 3 nil of
+ ArrayBox [1, 2, 3] -> Debug.Trace.trace "Done"
+ _ -> error "Failed"
diff --git a/examples/passing/EmptyTypeClass.purs b/examples/passing/EmptyTypeClass.purs
new file mode 100644
index 0000000..5827c82
--- /dev/null
+++ b/examples/passing/EmptyTypeClass.purs
@@ -0,0 +1,12 @@
+module Main where
+
+import Prelude
+
+class Partial
+
+head :: forall a. (Partial) => [a] -> a
+head (x:xs) = x
+
+instance allowPartials :: Partial
+
+main = Debug.Trace.trace $ head ["Done"]
diff --git a/examples/passing/EqOrd.purs b/examples/passing/EqOrd.purs
new file mode 100644
index 0000000..c840058
--- /dev/null
+++ b/examples/passing/EqOrd.purs
@@ -0,0 +1,14 @@
+module Main where
+
+data Pair a b = Pair a b
+
+instance ordPair :: (Ord a, Ord b) => Ord (Pair a b) where
+ compare (Pair a1 b1) (Pair a2 b2) = case compare a1 a2 of
+ EQ -> compare b1 b2
+ r -> r
+
+instance eqPair :: (Eq a, Eq b) => Eq (Pair a b) where
+ (==) (Pair a1 b1) (Pair a2 b2) = a1 == a2 && b1 == b2
+ (/=) (Pair a1 b1) (Pair a2 b2) = a1 /= a2 || b1 /= b2
+
+main = Debug.Trace.print $ Pair 1 2 == Pair 1 2
diff --git a/examples/passing/ExternData.purs b/examples/passing/ExternData.purs
new file mode 100644
index 0000000..eb256ed
--- /dev/null
+++ b/examples/passing/ExternData.purs
@@ -0,0 +1,13 @@
+module Main where
+
+ foreign import data IO :: * -> *
+
+ foreign import bind "function bind() {}" :: forall a b. IO a -> (a -> IO b) -> IO b
+
+ foreign import showMessage "function showMessage() {}" :: String -> IO { }
+
+ foreign import prompt "function prompt() {}" :: IO String
+
+ test _ = prompt `bind` \s -> showMessage s
+
+ main = Debug.Trace.trace "Done"
diff --git a/examples/passing/ExternRaw.purs b/examples/passing/ExternRaw.purs
new file mode 100644
index 0000000..23009ef
--- /dev/null
+++ b/examples/passing/ExternRaw.purs
@@ -0,0 +1,13 @@
+module Main where
+
+foreign import first "function first(xs) { return xs[0]; }" :: forall a. [a] -> a
+
+foreign import loop "function loop() { while (true) {} }" :: forall a. a
+
+foreign import concat "function concat(xs) { \
+ \ return function(ys) { \
+ \ return xs.concat(ys); \
+ \ };\
+ \}" :: forall a. [a] -> [a] -> [a]
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/passing/FFI.purs b/examples/passing/FFI.purs
new file mode 100644
index 0000000..0b8370a
--- /dev/null
+++ b/examples/passing/FFI.purs
@@ -0,0 +1,11 @@
+module Main where
+
+foreign import foo
+ "function foo(s) {\
+ \ return s;\
+ \}" :: String -> String
+
+bar :: String -> String
+bar _ = foo "test"
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/passing/Fib.purs b/examples/passing/Fib.purs
new file mode 100644
index 0000000..40f5cd9
--- /dev/null
+++ b/examples/passing/Fib.purs
@@ -0,0 +1,15 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff
+import Control.Monad.ST
+
+main = runST (do
+ n1 <- newSTRef 1
+ n2 <- newSTRef 1
+ whileE ((>) 1000 <$> readSTRef n1) $ do
+ n1' <- readSTRef n1
+ n2' <- readSTRef n2
+ writeSTRef n2 $ n1' + n2'
+ writeSTRef n1 n2'
+ Debug.Trace.print n2')
diff --git a/examples/passing/FinalTagless.purs b/examples/passing/FinalTagless.purs
new file mode 100644
index 0000000..bab7c97
--- /dev/null
+++ b/examples/passing/FinalTagless.purs
@@ -0,0 +1,22 @@
+module Main where
+
+import Prelude
+
+class E e where
+ num :: Number -> e Number
+ add :: e Number -> e Number -> e Number
+
+type Expr a = forall e. (E e) => e a
+
+data Id a = Id a
+
+instance exprId :: E Id where
+ num = Id
+ add (Id n) (Id m) = Id (n + m)
+
+runId (Id a) = a
+
+three :: Expr Number
+three = add (num 1) (num 2)
+
+main = Debug.Trace.print $ runId three
diff --git a/examples/passing/ForeignInstance.purs b/examples/passing/ForeignInstance.purs
new file mode 100644
index 0000000..325ad37
--- /dev/null
+++ b/examples/passing/ForeignInstance.purs
@@ -0,0 +1,16 @@
+module Main where
+
+class Foo a where
+ foo :: a -> String
+
+foreign import instance fooArray :: (Foo a) => Foo [a]
+
+foreign import instance fooNumber :: Foo Number
+
+foreign import instance fooString :: Foo String
+
+test1 _ = foo [1, 2, 3]
+
+test2 _ = foo "Test"
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/passing/FunctionScope.purs b/examples/passing/FunctionScope.purs
new file mode 100644
index 0000000..9552f4f
--- /dev/null
+++ b/examples/passing/FunctionScope.purs
@@ -0,0 +1,17 @@
+module Main where
+
+ import Prelude
+
+ mkValue :: Number -> Number
+ mkValue id = id
+
+ foreign import error
+ "function error(msg) {\
+ \ throw msg;\
+ \}" :: forall a. String -> a
+
+ main = do
+ let value = mkValue 1
+ if value == 1
+ then Debug.Trace.trace "Done"
+ else error "Not done"
diff --git a/examples/passing/Functions.purs b/examples/passing/Functions.purs
new file mode 100644
index 0000000..30c1fa8
--- /dev/null
+++ b/examples/passing/Functions.purs
@@ -0,0 +1,15 @@
+module Main where
+
+ import Prelude
+
+ test1 = \_ -> 0
+
+ test2 = \a b -> a + b + 1
+
+ test3 = \a -> a
+
+ test4 = \(%%) -> 1 %% 2
+
+ test5 = \(+++) (***) -> 1 +++ 2 *** 3
+
+ main = Debug.Trace.trace "Done"
diff --git a/examples/passing/Functions2.purs b/examples/passing/Functions2.purs
new file mode 100644
index 0000000..f759358
--- /dev/null
+++ b/examples/passing/Functions2.purs
@@ -0,0 +1,17 @@
+module Main where
+
+ import Prelude
+
+ test :: forall a b. a -> b -> a
+ test = \const _ -> const
+
+ foreign import error
+ "function error(msg) {\
+ \ throw msg;\
+ \}" :: forall a. String -> a
+
+ main = do
+ let value = test "Done" {}
+ if value == "Done"
+ then Debug.Trace.trace "Done"
+ else error "Not done"
diff --git a/examples/passing/Guards.purs b/examples/passing/Guards.purs
new file mode 100644
index 0000000..a3e4662
--- /dev/null
+++ b/examples/passing/Guards.purs
@@ -0,0 +1,14 @@
+module Main where
+
+ import Prelude
+
+ collatz = \x -> case x of
+ y | y % 2 == 0 -> y / 2
+ y -> y * 3 + 1
+
+ -- Guards have access to current scope
+ collatz2 = \x y -> case x of
+ z | y > 0 -> z / 2
+ z -> z * 3 + 1
+
+ main = Debug.Trace.trace "Done"
diff --git a/examples/passing/HoistError.purs b/examples/passing/HoistError.purs
new file mode 100644
index 0000000..1d9379b
--- /dev/null
+++ b/examples/passing/HoistError.purs
@@ -0,0 +1,17 @@
+module Main where
+
+import Control.Monad.Eff
+import Debug.Trace
+
+foreign import f
+ "function f(x) {\
+ \ return function () {\
+ \ if (x !== 0) throw new Error('x is not 0');\
+ \ }\
+ \}" :: forall e. Number -> Eff e Number
+
+main = do
+ let x = 0
+ f x
+ let x = 1 + 1
+ trace "Done"
diff --git a/examples/passing/ImportHiding.purs b/examples/passing/ImportHiding.purs
new file mode 100644
index 0000000..3167443
--- /dev/null
+++ b/examples/passing/ImportHiding.purs
@@ -0,0 +1,18 @@
+module Main where
+
+import Debug.Trace
+import Prelude hiding (
+ show, -- a value
+ Show, -- a type class
+ Unit(..) -- a constructor
+ )
+
+show = 1
+
+class Show a where
+ noshow :: a -> a
+
+data Unit = X | Y
+
+main = do
+ print show
diff --git a/examples/passing/InferRecFunWithConstrainedArgument.purs b/examples/passing/InferRecFunWithConstrainedArgument.purs
new file mode 100644
index 0000000..8541d79
--- /dev/null
+++ b/examples/passing/InferRecFunWithConstrainedArgument.purs
@@ -0,0 +1,8 @@
+module Main where
+
+import Prelude
+
+test 100 = 100
+test n = test(1 + n)
+
+main = Debug.Trace.print $ test 0
diff --git a/examples/passing/JSReserved.purs b/examples/passing/JSReserved.purs
new file mode 100644
index 0000000..d109d0a
--- /dev/null
+++ b/examples/passing/JSReserved.purs
@@ -0,0 +1,12 @@
+module Main where
+
+ import Prelude
+
+ yield = 0
+ member = 1
+
+ public = \return -> return
+
+ this catch = catch
+
+ main = Debug.Trace.trace "Done"
diff --git a/examples/passing/Let.purs b/examples/passing/Let.purs
new file mode 100644
index 0000000..ef4ecc6
--- /dev/null
+++ b/examples/passing/Let.purs
@@ -0,0 +1,64 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff
+import Control.Monad.ST
+
+test1 x = let
+ y :: Number
+ y = x + 1
+ in y
+
+test2 x y =
+ let x' = x + 1 in
+ let y' = y + 1 in
+ x' + y'
+
+test3 = let f x y z = x + y + z in
+ f 1 2 3
+
+test4 = let f x [y, z] = x y z in
+ f (+) [1, 2]
+
+test5 = let
+ f x | x > 0 = g (x / 2) + 1
+ f x = 0
+ g x = f (x - 1) + 1
+ in f 10
+
+test6 = runPure (runST (do
+ r <- newSTRef 0
+ (let
+ go [] = readSTRef r
+ go (n : ns) = do
+ modifySTRef r ((+) n)
+ go ns
+ in go [1, 2, 3, 4, 5])
+ ))
+
+test7 = let
+ f :: forall a. a -> a
+ f x = x
+ in if f true then f 1 else f 2
+
+test8 :: Number -> Number
+test8 x = let
+ go y | (x - 0.1 < y * y) && (y * y < x + 0.1) = y
+ go y = go $ (y + x / y) / 2
+ in go x
+
+test10 _ =
+ let
+ f x = g x * 3
+ g x = f x / 2
+ in f 10
+
+main = do
+ Debug.Trace.print (test1 1)
+ Debug.Trace.print (test2 1 2)
+ Debug.Trace.print test3
+ Debug.Trace.print test4
+ Debug.Trace.print test5
+ Debug.Trace.print test6
+ Debug.Trace.print test7
+ Debug.Trace.print (test8 100)
diff --git a/examples/passing/LetInInstance.purs b/examples/passing/LetInInstance.purs
new file mode 100644
index 0000000..40790a9
--- /dev/null
+++ b/examples/passing/LetInInstance.purs
@@ -0,0 +1,12 @@
+module Main where
+
+class Foo a where
+ foo :: a -> String
+
+instance fooString :: Foo String where
+ foo = go
+ where
+ go :: String -> String
+ go s = s
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/passing/LiberalTypeSynonyms.purs b/examples/passing/LiberalTypeSynonyms.purs
new file mode 100644
index 0000000..75242a5
--- /dev/null
+++ b/examples/passing/LiberalTypeSynonyms.purs
@@ -0,0 +1,19 @@
+module Main where
+
+type Reader = (->) String
+
+foo :: Reader String
+foo s = s
+
+type AndFoo r = (foo :: String | r)
+
+getFoo :: forall r. Prim.Object (AndFoo r) -> String
+getFoo o = o.foo
+
+type F r = { | r } -> { | r }
+
+f :: (forall r. F r) -> String
+f g = case g { x: "Hello" } of
+ { x = x } -> x
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/passing/MPTCs.purs b/examples/passing/MPTCs.purs
new file mode 100644
index 0000000..276ec79
--- /dev/null
+++ b/examples/passing/MPTCs.purs
@@ -0,0 +1,20 @@
+module Main where
+
+import Prelude
+
+class NullaryTypeClass where
+ greeting :: String
+
+instance nullaryTypeClass :: NullaryTypeClass where
+ greeting = "Hello, World!"
+
+class Coerce a b where
+ coerce :: a -> b
+
+instance coerceRefl :: Coerce a a where
+ coerce a = a
+
+instance coerceShow :: (Prelude.Show a) => Coerce a String where
+ coerce = show
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/passing/Match.purs b/examples/passing/Match.purs
new file mode 100644
index 0000000..9c446cb
--- /dev/null
+++ b/examples/passing/Match.purs
@@ -0,0 +1,7 @@
+module Main where
+
+ data Foo a = Foo
+
+ foo = \f -> case f of Foo -> "foo"
+
+ main = Debug.Trace.trace "Done"
diff --git a/examples/passing/Monad.purs b/examples/passing/Monad.purs
new file mode 100644
index 0000000..d147c53
--- /dev/null
+++ b/examples/passing/Monad.purs
@@ -0,0 +1,32 @@
+module Main where
+
+ import Prelude ()
+
+ type Monad m = { return :: forall a. a -> m a
+ , bind :: forall a b. m a -> (a -> m b) -> m b }
+
+ data Id a = Id a
+
+ id :: Monad Id
+ id = { return : Id
+ , bind : \ma f -> case ma of Id a -> f a }
+
+ data Maybe a = Nothing | Just a
+
+ maybe :: Monad Maybe
+ maybe = { return : Just
+ , bind : \ma f -> case ma of
+ Nothing -> Nothing
+ Just a -> f a
+ }
+
+ test :: forall m. Monad m -> m Number
+ test = \m -> m.bind (m.return 1) (\n1 ->
+ m.bind (m.return "Test") (\n2 ->
+ m.return n1))
+
+ test1 = test id
+
+ test2 = test maybe
+
+ main = Debug.Trace.trace "Done"
diff --git a/examples/passing/MonadState.purs b/examples/passing/MonadState.purs
new file mode 100644
index 0000000..a604c33
--- /dev/null
+++ b/examples/passing/MonadState.purs
@@ -0,0 +1,48 @@
+module Main where
+
+import Prelude
+
+data Tuple a b = Tuple a b
+
+class MonadState s m where
+ get :: m s
+ put :: s -> m {}
+
+data State s a = State (s -> Tuple s a)
+
+runState s (State f) = f s
+
+instance functorState :: Functor (State s) where
+ (<$>) = liftM1
+
+instance applyState :: Apply (State s) where
+ (<*>) = ap
+
+instance applicativeState :: Applicative (State s) where
+ pure a = State $ \s -> Tuple s a
+
+instance bindState :: Bind (State s) where
+ (>>=) f g = State $ \s -> case runState s f of
+ Tuple s1 a -> runState s1 (g a)
+
+instance monadState :: Monad (State s)
+
+instance monadStateState :: MonadState s (State s) where
+ get = State (\s -> Tuple s s)
+ put s = State (\_ -> Tuple s {})
+
+modify :: forall m s. (Prelude.Monad m, MonadState s m) => (s -> s) -> m {}
+modify f = do
+ s <- get
+ put (f s)
+
+test :: Tuple String String
+test = runState "" $ do
+ modify $ (++) "World!"
+ modify $ (++) "Hello, "
+ get
+
+main = do
+ let t1 = test
+ Debug.Trace.trace "Done"
+
diff --git a/examples/passing/MultiArgFunctions.purs b/examples/passing/MultiArgFunctions.purs
new file mode 100644
index 0000000..7e37721
--- /dev/null
+++ b/examples/passing/MultiArgFunctions.purs
@@ -0,0 +1,26 @@
+module Main where
+
+import Data.Function
+import Control.Monad.Eff
+import Debug.Trace
+
+f = mkFn2 $ \a b -> runFn2 g a b + runFn2 g b a
+
+g = mkFn2 $ \a b -> case {} of
+ _ | a <= 0 || b <= 0 -> b
+ _ -> runFn2 f (a - 1) (b - 1)
+
+main = do
+ runFn0 (mkFn0 $ \_ -> trace $ show 0)
+ runFn1 (mkFn1 $ \a -> trace $ show a) 1
+ runFn2 (mkFn2 $ \a b -> trace $ show [a, b]) 1 2
+ runFn3 (mkFn3 $ \a b c -> trace $ show [a, b, c]) 1 2 3
+ runFn4 (mkFn4 $ \a b c d -> trace $ show [a, b, c, d]) 1 2 3 4
+ runFn5 (mkFn5 $ \a b c d e -> trace $ show [a, b, c, d, e]) 1 2 3 4 5
+ runFn6 (mkFn6 $ \a b c d e f -> trace $ show [a, b, c, d, e, f]) 1 2 3 4 5 6
+ runFn7 (mkFn7 $ \a b c d e f g -> trace $ show [a, b, c, d, e, f, g]) 1 2 3 4 5 6 7
+ runFn8 (mkFn8 $ \a b c d e f g h -> trace $ show [a, b, c, d, e, f, g, h]) 1 2 3 4 5 6 7 8
+ runFn9 (mkFn9 $ \a b c d e f g h i -> trace $ show [a, b, c, d, e, f, g, h, i]) 1 2 3 4 5 6 7 8 9
+ runFn10 (mkFn10 $ \a b c d e f g h i j-> trace $ show [a, b, c, d, e, f, g, h, i, j]) 1 2 3 4 5 6 7 8 9 10
+ print $ runFn2 g 15 12
+ trace "Done!"
diff --git a/examples/passing/MultipleConstructorArgs.purs b/examples/passing/MultipleConstructorArgs.purs
new file mode 100644
index 0000000..b5b8b17
--- /dev/null
+++ b/examples/passing/MultipleConstructorArgs.purs
@@ -0,0 +1,21 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff
+
+data P a b = P a b
+
+runP :: forall a b r. (a -> b -> r) -> P a b -> r
+runP f (P a b) = f a b
+
+idP = runP P
+
+testCase = \p -> case p of
+ P (x:xs) (y:ys) -> x + y
+ P _ _ -> 0
+
+test1 = testCase (P [1, 2, 3] [4, 5, 6])
+
+main = do
+ Debug.Trace.trace (runP (\s n -> s ++ show n) (P "Test" 1))
+ Debug.Trace.print test1
diff --git a/examples/passing/MutRec.purs b/examples/passing/MutRec.purs
new file mode 100644
index 0000000..80c8939
--- /dev/null
+++ b/examples/passing/MutRec.purs
@@ -0,0 +1,19 @@
+module Main where
+
+ import Prelude
+
+ f 0 = 0
+ f x = g x + 1
+
+ g x = f (x / 2)
+
+ data Even = Zero | Even Odd
+
+ data Odd = Odd Even
+
+ evenToNumber Zero = 0
+ evenToNumber (Even n) = oddToNumber n + 1
+
+ oddToNumber (Odd n) = evenToNumber n + 1
+
+ main = Debug.Trace.trace "Done"
diff --git a/examples/passing/NamedPatterns.purs b/examples/passing/NamedPatterns.purs
new file mode 100644
index 0000000..34a62d4
--- /dev/null
+++ b/examples/passing/NamedPatterns.purs
@@ -0,0 +1,7 @@
+module Main where
+
+ foo = \x -> case x of
+ y@{ foo = "Foo" } -> y
+ y -> y
+
+ main = Debug.Trace.trace "Done"
diff --git a/examples/passing/Nested.purs b/examples/passing/Nested.purs
new file mode 100644
index 0000000..0c9244c
--- /dev/null
+++ b/examples/passing/Nested.purs
@@ -0,0 +1,7 @@
+module Main where
+
+ data Extend r a = Extend { prev :: r a, next :: a }
+
+ data Matrix r a = Square (r (r a)) | Bigger (Matrix (Extend r) a)
+
+ main = Debug.Trace.trace "Done"
diff --git a/examples/passing/NestedTypeSynonyms.purs b/examples/passing/NestedTypeSynonyms.purs
new file mode 100644
index 0000000..415b2b2
--- /dev/null
+++ b/examples/passing/NestedTypeSynonyms.purs
@@ -0,0 +1,11 @@
+module Main where
+
+ import Prelude
+
+ type X = String
+ type Y = X -> X
+
+ fn :: Y
+ fn a = a
+
+ main = Debug.Trace.print (fn "Done")
diff --git a/examples/passing/Newtype.purs b/examples/passing/Newtype.purs
new file mode 100644
index 0000000..787a556
--- /dev/null
+++ b/examples/passing/Newtype.purs
@@ -0,0 +1,22 @@
+module Main where
+
+import Control.Monad.Eff
+import Debug.Trace
+
+newtype Thing = Thing String
+
+instance showThing :: Show Thing where
+ show (Thing x) = "Thing " ++ show x
+
+newtype Box a = Box a
+
+instance showBox :: (Show a) => Show (Box a) where
+ show (Box x) = "Box " ++ show x
+
+apply f x = f x
+
+main = do
+ print $ Thing "hello"
+ print $ Box 42
+ print $ apply Box 9000
+ trace "Done" \ No newline at end of file
diff --git a/examples/passing/NewtypeEff.purs b/examples/passing/NewtypeEff.purs
new file mode 100644
index 0000000..3d520b8
--- /dev/null
+++ b/examples/passing/NewtypeEff.purs
@@ -0,0 +1,28 @@
+module Main where
+
+import Debug.Trace
+import Control.Monad.Eff
+
+newtype T a = T (Eff (trace :: Trace) a)
+
+runT :: forall a. T a -> Eff (trace :: Trace) a
+runT (T t) = t
+
+instance functorT :: Functor T where
+ (<$>) f (T t) = T (f <$> t)
+
+instance applyT :: Apply T where
+ (<*>) (T f) (T x) = T (f <*> x)
+
+instance applicativeT :: Applicative T where
+ pure t = T (pure t)
+
+instance bindT :: Bind T where
+ (>>=) (T t) f = T (t >>= \x -> runT (f x))
+
+instance monadT :: Monad T
+
+main = runT do
+ T $ trace "Done"
+ T $ trace "Done"
+ T $ trace "Done"
diff --git a/examples/passing/ObjectSynonym.purs b/examples/passing/ObjectSynonym.purs
new file mode 100644
index 0000000..42f1006
--- /dev/null
+++ b/examples/passing/ObjectSynonym.purs
@@ -0,0 +1,13 @@
+module Main where
+
+type Inner = Number
+
+inner :: Inner
+inner = 0
+
+type Outer = { inner :: Inner }
+
+outer :: Outer
+outer = { inner: inner }
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/passing/ObjectUpdate.purs b/examples/passing/ObjectUpdate.purs
new file mode 100644
index 0000000..6cd2a85
--- /dev/null
+++ b/examples/passing/ObjectUpdate.purs
@@ -0,0 +1,18 @@
+module Main where
+
+ update1 = \o -> o { foo = "Foo" }
+
+ update2 :: forall r. { foo :: String | r } -> { foo :: String | r }
+ update2 = \o -> o { foo = "Foo" }
+
+ replace = \o -> case o of
+ { foo = "Foo" } -> o { foo = "Bar" }
+ { foo = "Bar" } -> o { bar = "Baz" }
+ o -> o
+
+ polyUpdate :: forall a r. { foo :: a | r } -> { foo :: String | r }
+ polyUpdate = \o -> o { foo = "Foo" }
+
+ inferPolyUpdate = \o -> o { foo = "Foo" }
+
+ main = Debug.Trace.trace ((update1 {foo: ""}).foo)
diff --git a/examples/passing/Objects.purs b/examples/passing/Objects.purs
new file mode 100644
index 0000000..3f56969
--- /dev/null
+++ b/examples/passing/Objects.purs
@@ -0,0 +1,30 @@
+module Main where
+
+ import Prelude
+
+ test = \x -> x.foo + x.bar + 1
+
+ append = \o -> { foo: o.foo, bar: 1 }
+
+ apTest = append({foo : "Foo", baz: "Baz"})
+
+ f = (\a -> a.b.c) { b: { c: 1, d: "Hello" }, e: "World" }
+
+ g = (\a -> a.f { x: 1, y: "y" }) { f: \o -> o.x + 1 }
+
+ typed :: { foo :: Number }
+ typed = { foo: 0 }
+
+ test2 = \x -> x."!@#"
+
+ test3 = typed."foo"
+
+ test4 = test2 weirdObj
+ where
+ weirdObj :: { "!@#" :: Number }
+ weirdObj = { "!@#": 1 }
+
+ test5 = case { "***": 1 } of
+ { "***" = n } -> n
+
+ main = Debug.Trace.trace "Done"
diff --git a/examples/passing/OneConstructor.purs b/examples/passing/OneConstructor.purs
new file mode 100644
index 0000000..914255a
--- /dev/null
+++ b/examples/passing/OneConstructor.purs
@@ -0,0 +1,7 @@
+module Main where
+
+data One a = One a
+
+one (One a) = a
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/passing/Operators.purs b/examples/passing/Operators.purs
new file mode 100644
index 0000000..ab3bcbc
--- /dev/null
+++ b/examples/passing/Operators.purs
@@ -0,0 +1,80 @@
+module Main where
+
+ import Control.Monad.Eff
+ import Debug.Trace
+
+ (?!) :: forall a. a -> a -> a
+ (?!) x _ = x
+
+ bar :: String -> String -> String
+ bar = \s1 s2 -> s1 ++ s2
+
+ test1 :: forall n. (Num n) => n -> n -> (n -> n -> n) -> n
+ test1 x y z = x * y + z x y
+
+ test2 = (\x -> x.foo false) { foo : \_ -> 1 }
+
+ test3 = (\x y -> x)(1 + 2 * (1 + 2)) (true && (false || false))
+
+ k = \x -> \y -> x
+
+ test4 = 1 `k` 2
+
+ infixl 5 %%
+
+ (%%) :: Number -> Number -> Number
+ (%%) x y = x * y + y
+
+ test5 = 1 %% 2 %% 3
+
+ test6 = ((\x -> x) `k` 2) 3
+
+ (<+>) :: String -> String -> String
+ (<+>) = \s1 s2 -> s1 ++ s2
+
+ test7 = "Hello" <+> "World!"
+
+ (@@) :: forall a b. (a -> b) -> a -> b
+ (@@) = \f x -> f x
+
+ foo :: String -> String
+ foo = \s -> s
+
+ test8 = foo @@ "Hello World"
+
+ test9 = Main.foo @@ "Hello World"
+
+ test10 = "Hello" `Main.bar` "World"
+
+ (...) :: forall a. [a] -> [a] -> [a]
+ (...) = \as -> \bs -> as
+
+ test11 = [1, 2, 3] ... [4, 5, 6]
+
+ test12 (<%>) a b = a <%> b
+
+ test13 = \(<%>) a b -> a <%> b
+
+ test14 :: Number -> Number -> Boolean
+ test14 a b = a < b
+
+ test15 :: Number -> Number -> Boolean
+ test15 a b = const false $ a `test14` b
+
+ main = do
+ let t1 = test1 1 2 (\x y -> x + y)
+ let t2 = test2
+ let t3 = test3
+ let t4 = test4
+ let t5 = test5
+ let t6 = test6
+ let t7 = test7
+ let t8 = test8
+ let t9 = test9
+ let t10 = test10
+ let t11 = test11
+ let t12 = test12 k 1 2
+ let t13 = test13 k 1 2
+ let t14 = test14 1 2
+ let t15 = test15 1 2
+ trace "Done"
diff --git a/examples/passing/OptimizerBug.purs b/examples/passing/OptimizerBug.purs
new file mode 100644
index 0000000..a9abe02
--- /dev/null
+++ b/examples/passing/OptimizerBug.purs
@@ -0,0 +1,9 @@
+module Main where
+
+import Prelude
+
+x a = 1 + y a
+
+y a = x a
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/passing/PartialFunction.purs b/examples/passing/PartialFunction.purs
new file mode 100644
index 0000000..7342427
--- /dev/null
+++ b/examples/passing/PartialFunction.purs
@@ -0,0 +1,17 @@
+module Main where
+
+foreign import testError
+ "function testError(f) {\
+ \ try {\
+ \ return f();\
+ \ } catch (e) {\
+ \ if (e instanceof Error) return 'success';\
+ \ throw new Error('Pattern match failure is not Error');\
+ \ }\
+ \}" :: (Unit -> Number) -> String
+
+fn :: Number -> Number
+fn 0 = 0
+fn 1 = 2
+
+main = Debug.Trace.trace (show $ testError $ \_ -> fn 2)
diff --git a/examples/passing/Patterns.purs b/examples/passing/Patterns.purs
new file mode 100644
index 0000000..c09d13e
--- /dev/null
+++ b/examples/passing/Patterns.purs
@@ -0,0 +1,28 @@
+module Main where
+
+ import Prelude
+
+ test = \x -> case x of
+ { str = "Foo", bool = true } -> true
+ { str = "Bar", bool = b } -> b
+ _ -> false
+
+ f = \o -> case o of
+ { foo = "Foo" } -> o.bar
+ _ -> 0
+
+ g = \o -> case o of
+ { arr = [x : xs], take = "car" } -> x
+ { arr = [_, x : xs], take = "cadr" } -> x
+ _ -> 0
+
+
+ h = \o -> case o of
+ a@[_,_,_] -> a
+ _ -> []
+
+ isDesc :: [Number] -> Boolean
+ isDesc [x, y] | x > y = true
+ isDesc _ = false
+
+ main = Debug.Trace.trace "Done"
diff --git a/examples/passing/Person.purs b/examples/passing/Person.purs
new file mode 100644
index 0000000..daaed44
--- /dev/null
+++ b/examples/passing/Person.purs
@@ -0,0 +1,16 @@
+module Main where
+
+ import Prelude ((++))
+
+ data Person = Person { name :: String, age :: Number }
+
+ foreign import itoa
+ "function itoa(n) {\
+ \ return n.toString();\
+ \}" :: Number -> String
+
+ showPerson :: Person -> String
+ showPerson = \p -> case p of
+ Person o -> o.name ++ ", aged " ++ itoa(o.age)
+
+ main = Debug.Trace.trace "Done"
diff --git a/examples/passing/Rank2Data.purs b/examples/passing/Rank2Data.purs
new file mode 100644
index 0000000..c7ed2e5
--- /dev/null
+++ b/examples/passing/Rank2Data.purs
@@ -0,0 +1,29 @@
+module Main where
+
+ import Prelude
+
+ data Id = Id forall a. a -> a
+
+ runId = \id a -> case id of
+ Id f -> f a
+
+ data Nat = Nat forall r. r -> (r -> r) -> r
+
+ runNat = \nat -> case nat of
+ Nat f -> f 0 (\n -> n + 1)
+
+ zero = Nat (\zero _ -> zero)
+
+ succ = \n -> case n of
+ Nat f -> Nat (\zero succ -> succ (f zero succ))
+
+ add = \n m -> case n of
+ Nat f -> case m of
+ Nat g -> Nat (\zero succ -> g (f zero succ) succ)
+
+ one = succ zero
+ two = succ zero
+ four = add two two
+ fourNumber = runNat four
+
+ main = Debug.Trace.trace "Done"
diff --git a/examples/passing/Rank2Object.purs b/examples/passing/Rank2Object.purs
new file mode 100644
index 0000000..7de3c2f
--- /dev/null
+++ b/examples/passing/Rank2Object.purs
@@ -0,0 +1,10 @@
+module Main where
+
+import Debug.Trace
+
+data Foo = Foo { id :: forall a. a -> a }
+
+foo :: Foo -> Number
+foo (Foo { id = f }) = f 0
+
+main = trace "Done"
diff --git a/examples/passing/Rank2TypeSynonym.purs b/examples/passing/Rank2TypeSynonym.purs
new file mode 100644
index 0000000..22539bb
--- /dev/null
+++ b/examples/passing/Rank2TypeSynonym.purs
@@ -0,0 +1,15 @@
+module Main where
+
+import Control.Monad.Eff
+
+type Foo a = forall f. (Monad f) => f a
+
+foo :: forall a. a -> Foo a
+foo x = pure x
+
+bar :: Foo Number
+bar = foo 3
+
+main = do
+ x <- bar
+ Debug.Trace.print x
diff --git a/examples/passing/Rank2Types.purs b/examples/passing/Rank2Types.purs
new file mode 100644
index 0000000..864abc5
--- /dev/null
+++ b/examples/passing/Rank2Types.purs
@@ -0,0 +1,11 @@
+module Main where
+
+ import Prelude
+
+ test1 :: (forall a. (a -> a)) -> Number
+ test1 = \f -> f 0
+
+ forever :: forall m a b. (forall a b. m a -> (a -> m b) -> m b) -> m a -> m b
+ forever = \bind action -> bind action $ \_ -> forever bind action
+
+ main = Debug.Trace.trace "Done"
diff --git a/examples/passing/Recursion.purs b/examples/passing/Recursion.purs
new file mode 100644
index 0000000..b6d7c1d
--- /dev/null
+++ b/examples/passing/Recursion.purs
@@ -0,0 +1,10 @@
+module Main where
+
+ import Prelude
+
+ fib = \n -> case n of
+ 0 -> 1
+ 1 -> 1
+ n -> fib (n - 1) + fib (n - 2)
+
+ main = Debug.Trace.trace "Done"
diff --git a/examples/passing/RuntimeScopeIssue.purs b/examples/passing/RuntimeScopeIssue.purs
new file mode 100644
index 0000000..780192d
--- /dev/null
+++ b/examples/passing/RuntimeScopeIssue.purs
@@ -0,0 +1,19 @@
+module Main where
+
+import Prelude
+
+class A a where
+ a :: a -> Boolean
+
+class B a where
+ b :: a -> Boolean
+
+instance aNumber :: A Number where
+ a 0 = true
+ a n = b (n - 1)
+
+instance bNumber :: B Number where
+ b 0 = false
+ b n = a (n - 1)
+
+main = Debug.Trace.print $ a 10
diff --git a/examples/passing/STArray.purs b/examples/passing/STArray.purs
new file mode 100644
index 0000000..a2bfdd5
--- /dev/null
+++ b/examples/passing/STArray.purs
@@ -0,0 +1,25 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff
+import Control.Monad.ST
+import Debug.Trace
+
+test = runSTArray (do
+ a <- newSTArray 2 0
+ pokeSTArray a 0 1
+ pokeSTArray a 1 2
+ return a)
+
+fromTo lo hi = runSTArray (do
+ arr <- newSTArray (hi - lo + 1) 0
+ (let
+ go lo hi _ arr | lo > hi = return arr
+ go lo hi i arr = do
+ pokeSTArray arr i lo
+ go (lo + 1) hi (i + 1) arr
+ in go lo hi 0 arr))
+
+main = do
+ let t1 = runPure (fromTo 10 20)
+ trace "Done"
diff --git a/examples/passing/Sequence.purs b/examples/passing/Sequence.purs
new file mode 100644
index 0000000..222829d
--- /dev/null
+++ b/examples/passing/Sequence.purs
@@ -0,0 +1,12 @@
+module Main where
+
+import Control.Monad.Eff
+
+class Sequence t where
+ sequence :: forall m a. (Monad m) => t (m a) -> m (t a)
+
+instance sequenceArray :: Sequence [] where
+ sequence [] = pure []
+ sequence (x:xs) = (:) <$> x <*> sequence xs
+
+main = sequence $ [Debug.Trace.trace "Done"]
diff --git a/examples/passing/ShadowedRename.purs b/examples/passing/ShadowedRename.purs
new file mode 100644
index 0000000..1a58db6
--- /dev/null
+++ b/examples/passing/ShadowedRename.purs
@@ -0,0 +1,19 @@
+module Main where
+
+import Control.Monad.Eff
+import Debug.Trace
+
+foreign import f
+ "function f(x) {\
+ \ return function () {\
+ \ if (x !== 2) throw new Error('x is not 2');\
+ \ }\
+ \}" :: forall e. Number -> Eff e Number
+
+foo foo = let foo_1 = \_ -> foo
+ foo_2 = foo_1 unit + 1
+ in foo_2
+
+main = do
+ f (foo 1)
+ trace "Done"
diff --git a/examples/passing/ShadowedTCO.purs b/examples/passing/ShadowedTCO.purs
new file mode 100644
index 0000000..6cc4ff9
--- /dev/null
+++ b/examples/passing/ShadowedTCO.purs
@@ -0,0 +1,16 @@
+module Main where
+
+runNat f = f 0 (\n -> n + 1)
+
+zero z _ = z
+
+succ f zero succ = succ (f zero succ)
+
+add f g zero succ = g (f zero succ) succ
+
+one = succ zero
+two = succ one
+four = add two two
+fourNumber = runNat four
+
+main = Debug.Trace.trace $ show fourNumber
diff --git a/examples/passing/ShadowedTCOLet.purs b/examples/passing/ShadowedTCOLet.purs
new file mode 100644
index 0000000..5089013
--- /dev/null
+++ b/examples/passing/ShadowedTCOLet.purs
@@ -0,0 +1,7 @@
+module Main where
+
+f x y z =
+ let f 1 2 3 = 1
+ in f x z y
+
+main = Debug.Trace.trace $ show $ f 1 3 2
diff --git a/examples/passing/SignedNumericLiterals.purs b/examples/passing/SignedNumericLiterals.purs
new file mode 100644
index 0000000..24d935e
--- /dev/null
+++ b/examples/passing/SignedNumericLiterals.purs
@@ -0,0 +1,15 @@
+module Main where
+
+ p = 0.5
+ q = 1
+ x = -1
+ y = -0.5
+ z = 0.5
+ w = 1
+
+ f :: Number -> Number
+ f x = -x
+
+ test1 = 2 - 1
+
+ main = Debug.Trace.trace "Done"
diff --git a/examples/passing/Superclasses1.purs b/examples/passing/Superclasses1.purs
new file mode 100644
index 0000000..32846a6
--- /dev/null
+++ b/examples/passing/Superclasses1.purs
@@ -0,0 +1,18 @@
+module Main where
+
+class Su a where
+ su :: a -> a
+
+class (Su a) <= Cl a where
+ cl :: a -> a -> a
+
+instance suNumber :: Su Number where
+ su n = n + 1
+
+instance clNumber :: Cl Number where
+ cl n m = n + m
+
+test :: forall a. (Cl a) => a -> a
+test a = su (cl a a)
+
+main = Debug.Trace.print $ test 10
diff --git a/examples/passing/Superclasses2.purs b/examples/passing/Superclasses2.purs
new file mode 100644
index 0000000..38d2adc
--- /dev/null
+++ b/examples/passing/Superclasses2.purs
@@ -0,0 +1,23 @@
+module Main where
+
+import Prelude.Unsafe (unsafeIndex)
+
+class Su a where
+ su :: a -> a
+
+class (Su [a]) <= Cl a where
+ cl :: a -> a -> a
+
+instance suNumber :: Su Number where
+ su n = n + 1
+
+instance suArray :: (Su a) => Su [a] where
+ su (x : _) = [su x]
+
+instance clNumber :: Cl Number where
+ cl n m = n + m
+
+test :: forall a. (Cl a) => a -> [a]
+test x = su [cl x x]
+
+main = Debug.Trace.print $ test 10 `unsafeIndex` 0
diff --git a/examples/passing/Superclasses3.purs b/examples/passing/Superclasses3.purs
new file mode 100644
index 0000000..bacbd89
--- /dev/null
+++ b/examples/passing/Superclasses3.purs
@@ -0,0 +1,41 @@
+module Main where
+
+import Debug.Trace
+
+import Control.Monad.Eff
+
+class (Monad m) <= MonadWriter w m where
+ tell :: w -> m Unit
+
+testFunctor :: forall m. (Monad m) => m Number -> m Number
+testFunctor n = (+) 1 <$> n
+
+test :: forall w m. (Monad m, MonadWriter w m) => w -> m Unit
+test w = do
+ tell w
+ tell w
+ tell w
+
+data MTrace a = MTrace (Eff (trace :: Trace) a)
+
+runMTrace :: forall a. MTrace a -> Eff (trace :: Trace) a
+runMTrace (MTrace a) = a
+
+instance functorMTrace :: Functor MTrace where
+ (<$>) = liftM1
+
+instance applyMTrace :: Apply MTrace where
+ (<*>) = ap
+
+instance applicativeMTrace :: Applicative MTrace where
+ pure = MTrace <<< return
+
+instance bindMTrace :: Bind MTrace where
+ (>>=) m f = MTrace (runMTrace m >>= (runMTrace <<< f))
+
+instance monadMTrace :: Monad MTrace
+
+instance writerMTrace :: MonadWriter String MTrace where
+ tell s = MTrace (trace s)
+
+main = runMTrace $ test "Done"
diff --git a/examples/passing/TCOCase.purs b/examples/passing/TCOCase.purs
new file mode 100644
index 0000000..563e628
--- /dev/null
+++ b/examples/passing/TCOCase.purs
@@ -0,0 +1,10 @@
+module Main where
+
+data Data = One | More Data
+
+main = Debug.Trace.trace (from (to 10000 One))
+ where
+ to 0 a = a
+ to n a = to (n - 1) (More a)
+ from One = "Done"
+ from (More d) = from d
diff --git a/examples/passing/TailCall.purs b/examples/passing/TailCall.purs
new file mode 100644
index 0000000..56e93cc
--- /dev/null
+++ b/examples/passing/TailCall.purs
@@ -0,0 +1,15 @@
+module Main where
+
+import Prelude
+
+test :: Number -> [Number] -> Number
+test n [] = n
+test n (x:xs) = test (n + x) xs
+
+loop :: forall a. Number -> a
+loop x = loop (x + 1)
+
+notATailCall = \x ->
+ (\notATailCall -> notATailCall x) (\x -> x)
+
+main = Debug.Trace.print (test 0 [1, 2, 3])
diff --git a/examples/passing/Tick.purs b/examples/passing/Tick.purs
new file mode 100644
index 0000000..d799fa7
--- /dev/null
+++ b/examples/passing/Tick.purs
@@ -0,0 +1,5 @@
+module Main where
+
+test' x = x
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/passing/TopLevelCase.purs b/examples/passing/TopLevelCase.purs
new file mode 100644
index 0000000..5421032
--- /dev/null
+++ b/examples/passing/TopLevelCase.purs
@@ -0,0 +1,18 @@
+module Main where
+
+ import Prelude
+
+ gcd :: Number -> Number -> Number
+ gcd 0 x = x
+ gcd x 0 = x
+ gcd x y | x > y = gcd (x % y) y
+ gcd x y = gcd (y % x) x
+
+ guardsTest (x:xs) | x > 0 = guardsTest xs
+ guardsTest xs = xs
+
+ data A = A
+
+ parseTest A 0 = 0
+
+ main = Debug.Trace.trace "Done"
diff --git a/examples/passing/TypeClassMemberOrderChange.purs b/examples/passing/TypeClassMemberOrderChange.purs
new file mode 100644
index 0000000..ccf98a2
--- /dev/null
+++ b/examples/passing/TypeClassMemberOrderChange.purs
@@ -0,0 +1,11 @@
+module Main where
+
+class Test a where
+ fn :: a -> a -> a
+ val :: a
+
+instance testBoolean :: Test Boolean where
+ val = true
+ fn x y = y
+
+main = Debug.Trace.trace (show (fn true val))
diff --git a/examples/passing/TypeClasses.purs b/examples/passing/TypeClasses.purs
new file mode 100644
index 0000000..a81acdb
--- /dev/null
+++ b/examples/passing/TypeClasses.purs
@@ -0,0 +1,69 @@
+module Main where
+
+import Prelude
+
+test1 = \_ -> show "testing"
+
+f :: forall a. (Prelude.Show a) => a -> String
+f x = show x
+
+test2 = \_ -> f "testing"
+
+test7 :: forall a. (Prelude.Show a) => a -> String
+test7 = show
+
+test8 = \_ -> show $ "testing"
+
+data Data a = Data a
+
+instance showData :: (Prelude.Show a) => Prelude.Show (Data a) where
+ show (Data a) = "Data (" ++ show a ++ ")"
+
+test3 = \_ -> show (Data "testing")
+
+instance functorData :: Functor Data where
+ (<$>) = liftM1
+
+instance applyData :: Apply Data where
+ (<*>) = ap
+
+instance applicativeData :: Applicative Data where
+ pure = Data
+
+instance bindData :: Bind Data where
+ (>>=) (Data a) f = f a
+
+instance monadData :: Monad Data
+
+data Maybe a = Nothing | Just a
+
+instance functorMaybe :: Functor Maybe where
+ (<$>) = liftM1
+
+instance applyMaybe :: Apply Maybe where
+ (<*>) = ap
+
+instance applicativeMaybe :: Applicative Maybe where
+ pure = Just
+
+instance bindMaybe :: Bind Maybe where
+ (>>=) Nothing _ = Nothing
+ (>>=) (Just a) f = f a
+
+instance monadMaybe :: Monad Maybe
+
+test4 :: forall a m. (Monad m) => a -> m Number
+test4 = \_ -> return 1
+
+test5 = \_ -> Just 1 >>= \n -> return (n + 1)
+
+ask r = r
+
+runReader r f = f r
+
+test9 _ = runReader 0 $ do
+ n <- ask
+ return $ n + 1
+
+main = Debug.Trace.trace (test7 "Done")
+
diff --git a/examples/passing/TypeClassesInOrder.purs b/examples/passing/TypeClassesInOrder.purs
new file mode 100644
index 0000000..d576a84
--- /dev/null
+++ b/examples/passing/TypeClassesInOrder.purs
@@ -0,0 +1,11 @@
+module Main where
+
+import Prelude
+
+class Foo a where
+ foo :: a -> String
+
+instance fooString :: Foo String where
+ foo s = s
+
+main = Debug.Trace.trace $ foo "Done"
diff --git a/examples/passing/TypeClassesWithOverlappingTypeVariables.purs b/examples/passing/TypeClassesWithOverlappingTypeVariables.purs
new file mode 100644
index 0000000..e8eae78
--- /dev/null
+++ b/examples/passing/TypeClassesWithOverlappingTypeVariables.purs
@@ -0,0 +1,11 @@
+module Main where
+
+ import Prelude
+
+ data Either a b = Left a | Right b
+
+ instance functorEither :: Prelude.Functor (Either a) where
+ (<$>) _ (Left x) = Left x
+ (<$>) f (Right y) = Right (f y)
+
+ main = Debug.Trace.trace "Done"
diff --git a/examples/passing/TypeDecl.purs b/examples/passing/TypeDecl.purs
new file mode 100644
index 0000000..8b6eb29
--- /dev/null
+++ b/examples/passing/TypeDecl.purs
@@ -0,0 +1,12 @@
+module Main where
+
+ import Prelude
+
+ k :: String -> Number -> String
+ k x y = x
+
+ iterate :: forall a. Number -> (a -> a) -> a -> a
+ iterate 0 f a = a
+ iterate n f a = iterate (n - 1) f (f a)
+
+ main = Debug.Trace.trace "Done"
diff --git a/examples/passing/TypeSynonymInData.purs b/examples/passing/TypeSynonymInData.purs
new file mode 100644
index 0000000..fff44e1
--- /dev/null
+++ b/examples/passing/TypeSynonymInData.purs
@@ -0,0 +1,9 @@
+module Main where
+
+type A a = [a]
+
+data Foo a = Foo (A a) | Bar
+
+foo (Foo []) = Bar
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/passing/TypeSynonyms.purs b/examples/passing/TypeSynonyms.purs
new file mode 100644
index 0000000..8d04444
--- /dev/null
+++ b/examples/passing/TypeSynonyms.purs
@@ -0,0 +1,25 @@
+module Main where
+
+ type Lens a b =
+ { get :: a -> b
+ , set :: a -> b -> a
+ }
+
+ composeLenses :: forall a b c. Lens a b -> Lens b c -> Lens a c
+ composeLenses = \l1 -> \l2 ->
+ { get: \a -> l2.get (l1.get a)
+ , set: \a c -> l1.set a (l2.set (l1.get a) c)
+ }
+
+ type Pair a b = { fst :: a, snd :: b }
+
+ fst :: forall a b. Lens (Pair a b) a
+ fst =
+ { get: \p -> p.fst
+ , set: \p a -> { fst: a, snd: p.snd }
+ }
+
+ test1 :: forall a b c. Lens (Pair (Pair a b) c) a
+ test1 = composeLenses fst fst
+
+ main = Debug.Trace.trace "Done"
diff --git a/examples/passing/TypedWhere.purs b/examples/passing/TypedWhere.purs
new file mode 100644
index 0000000..637af69
--- /dev/null
+++ b/examples/passing/TypedWhere.purs
@@ -0,0 +1,13 @@
+module Main where
+
+data E a b = L a | R b
+
+lefts :: forall a b. [E a b] -> [a]
+lefts = go []
+ where
+ go :: forall a b. [a] -> [E a b] -> [a]
+ go ls [] = ls
+ go ls (L a : rest) = go (a : ls) rest
+ go ls (_ : rest) = go ls rest
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/passing/Unit.purs b/examples/passing/Unit.purs
new file mode 100644
index 0000000..bda473c
--- /dev/null
+++ b/examples/passing/Unit.purs
@@ -0,0 +1,6 @@
+module Main where
+
+import Prelude
+import Debug.Trace
+
+main = print (const unit $ "Hello world")
diff --git a/examples/passing/UnknownInTypeClassLookup.purs b/examples/passing/UnknownInTypeClassLookup.purs
new file mode 100644
index 0000000..90a2097
--- /dev/null
+++ b/examples/passing/UnknownInTypeClassLookup.purs
@@ -0,0 +1,12 @@
+module Main where
+
+class EQ a b
+
+instance eqAA :: EQ a a
+
+test :: forall a b. (EQ a b) => a -> b -> String
+test _ _ = "Done"
+
+runTest a = test a a
+
+main = Debug.Trace.trace $ runTest 0
diff --git a/examples/passing/Where.purs b/examples/passing/Where.purs
new file mode 100644
index 0000000..d63d774
--- /dev/null
+++ b/examples/passing/Where.purs
@@ -0,0 +1,49 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff
+import Control.Monad.ST
+
+test1 x = y
+ where
+ y :: Number
+ y = x + 1
+
+test2 x y = x' + y'
+ where
+ x' = x + 1
+ y' = y + 1
+
+
+test3 = f 1 2 3
+ where f x y z = x + y + z
+
+
+test4 = f (+) [1, 2]
+ where f x [y, z] = x y z
+
+
+test5 = g 10
+ where
+ f x | x > 0 = g (x / 2) + 1
+ f x = 0
+ g x = f (x - 1) + 1
+
+test6 = if f true then f 1 else f 2
+ where f :: forall a. a -> a
+ f x = x
+
+test7 :: Number -> Number
+test7 x = go x
+ where
+ go y | (x - 0.1 < y * y) && (y * y < x + 0.1) = y
+ go y = go $ (y + x / y) / 2
+
+main = do
+ Debug.Trace.print (test1 1)
+ Debug.Trace.print (test2 1 2)
+ Debug.Trace.print test3
+ Debug.Trace.print test4
+ Debug.Trace.print test5
+ Debug.Trace.print test6
+ Debug.Trace.print (test7 100)
diff --git a/examples/passing/iota.purs b/examples/passing/iota.purs
new file mode 100644
index 0000000..8d65c1c
--- /dev/null
+++ b/examples/passing/iota.purs
@@ -0,0 +1,9 @@
+module Main where
+
+ s = \x -> \y -> \z -> x z (y z)
+
+ k = \x -> \y -> x
+
+ iota = \x -> x s k
+
+ main = Debug.Trace.trace "Done"
diff --git a/examples/passing/s.purs b/examples/passing/s.purs
new file mode 100644
index 0000000..1281767
--- /dev/null
+++ b/examples/passing/s.purs
@@ -0,0 +1,5 @@
+module Main where
+
+ s = \x y z -> x z (y z)
+
+ main = Debug.Trace.trace "Done"
diff --git a/prelude/prelude.purs b/prelude/prelude.purs
index 23c1576..1c1788f 100644
--- a/prelude/prelude.purs
+++ b/prelude/prelude.purs
@@ -10,7 +10,6 @@ module Prelude
, Functor, (<$>), void
, Apply, (<*>)
, Applicative, pure, liftA1
- , Alternative, empty, (<|>)
, Bind, (>>=)
, Monad, return, liftM1, ap
, Num, (+), (-), (*), (/), (%)
@@ -130,12 +129,6 @@ module Prelude
liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
liftA1 f a = pure f <*> a
- infixl 3 <|>
-
- class Alternative f where
- empty :: forall a. f a
- (<|>) :: forall a. f a -> f a -> f a
-
infixl 1 >>=
class (Apply m) <= Bind m where
@@ -344,7 +337,7 @@ module Prelude
\ };\
\ };\
\}" :: forall a. Ordering -> Ordering -> Ordering -> a -> a -> Ordering
-
+
unsafeCompare :: forall a. a -> a -> Ordering
unsafeCompare = unsafeCompareImpl LT EQ GT
diff --git a/psci/Commands.hs b/psci/Commands.hs
index 001f3f5..88a67ac 100644
--- a/psci/Commands.hs
+++ b/psci/Commands.hs
@@ -24,7 +24,7 @@ data Command
-- |
-- A purescript expression
--
- = Expression Value
+ = Expression Expr
-- |
-- Show the help command
--
@@ -48,14 +48,14 @@ data Command
-- |
-- Binds a value to a name
--
- | Let (Value -> Value)
+ | Let (Expr -> Expr)
-- |
-- Find the type of an expression
--
- | TypeOf Value
+ | TypeOf Expr
-- |
-- Find the kind of an expression
- --
+ --
| KindOf Type
-- |
diff --git a/psci/Main.hs b/psci/Main.hs
index 6aed0d2..99d68e4 100644
--- a/psci/Main.hs
+++ b/psci/Main.hs
@@ -66,7 +66,7 @@ data PSCiState = PSCiState
{ psciImportedFilenames :: [FilePath]
, psciImportedModuleNames :: [P.ModuleName]
, psciLoadedModules :: [(FilePath, P.Module)]
- , psciLetBindings :: [P.Value -> P.Value]
+ , psciLetBindings :: [P.Expr -> P.Expr]
}
-- State helpers
@@ -92,7 +92,7 @@ updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modu
-- |
-- Updates the state to have more let bindings.
--
-updateLets :: (P.Value -> P.Value) -> PSCiState -> PSCiState
+updateLets :: (P.Expr -> P.Expr) -> PSCiState -> PSCiState
updateLets name st = st { psciLetBindings = name : psciLetBindings st }
-- File helpers
@@ -234,7 +234,7 @@ instance P.MonadMake Make where
mkdirp path
U.writeFile path text
liftError = either throwError return
- progress s = unless (s == "Compiling Main") $ makeIO . U.putStrLn $ s
+ progress s = unless (s == "Compiling $PSCI") $ makeIO . U.putStrLn $ s
mkdirp :: FilePath -> IO ()
mkdirp = createDirectoryIfMissing True . takeDirectory
@@ -242,11 +242,11 @@ mkdirp = createDirectoryIfMissing True . takeDirectory
-- |
-- Makes a volatile module to execute the current expression.
--
-createTemporaryModule :: Bool -> PSCiState -> P.Value -> P.Module
+createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module
createTemporaryModule exec PSCiState{psciImportedModuleNames = imports, psciLetBindings = lets} value =
let
- moduleName = P.ModuleName [P.ProperName "Main"]
- importDecl m = P.ImportDeclaration m Nothing Nothing
+ moduleName = P.ModuleName [P.ProperName "$PSCI"]
+ importDecl m = P.ImportDeclaration m P.Unqualified Nothing
traceModule = P.ModuleName [P.ProperName "Debug", P.ProperName "Trace"]
trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))
itValue = foldl (\x f -> f x) value lets
@@ -263,8 +263,8 @@ createTemporaryModule exec PSCiState{psciImportedModuleNames = imports, psciLetB
createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module
createTemporaryModuleForKind PSCiState{psciImportedModuleNames = imports} typ =
let
- moduleName = P.ModuleName [P.ProperName "Main"]
- importDecl m = P.ImportDeclaration m Nothing Nothing
+ moduleName = P.ModuleName [P.ProperName "$PSCI"]
+ importDecl m = P.ImportDeclaration m P.Unqualified Nothing
itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ
in
P.Module moduleName ((importDecl `map` imports) ++ [itDecl]) Nothing
@@ -278,15 +278,15 @@ indexFile = ".psci_modules" ++ pathSeparator : "index.js"
-- |
-- Takes a value declaration and evaluates it with the current state.
--
-handleDeclaration :: P.Value -> PSCI ()
+handleDeclaration :: P.Expr -> PSCI ()
handleDeclaration value = do
st <- PSCI $ lift get
let m = createTemporaryModule True st value
- e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("Main.purs", m)])
+ e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)])
case e of
Left err -> PSCI $ outputStrLn err
Right _ -> do
- psciIO $ writeFile indexFile $ "require('Main').main();"
+ psciIO $ writeFile indexFile $ "require('$PSCI').main();"
process <- psciIO findNodeProcess
result <- psciIO $ traverse (\node -> readProcessWithExitCode node [indexFile] "") process
case result of
@@ -297,15 +297,15 @@ handleDeclaration value = do
-- |
-- Takes a value and prints its type
--
-handleTypeOf :: P.Value -> PSCI ()
+handleTypeOf :: P.Expr -> PSCI ()
handleTypeOf value = do
st <- PSCI $ lift get
let m = createTemporaryModule False st value
- e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("Main.purs", m)])
+ e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)])
case e of
Left err -> PSCI $ outputStrLn err
Right env' ->
- case M.lookup (P.ModuleName [P.ProperName "Main"], P.Ident "it") (P.names env') of
+ case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of
Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty
Nothing -> PSCI $ outputStrLn "Could not find type"
@@ -316,8 +316,8 @@ handleKindOf :: P.Type -> PSCI ()
handleKindOf typ = do
st <- PSCI $ lift get
let m = createTemporaryModuleForKind st typ
- mName = P.ModuleName [P.ProperName "Main"]
- e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("Main.purs", m)])
+ mName = P.ModuleName [P.ProperName "$PSCI"]
+ e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)])
case e of
Left err -> PSCI $ outputStrLn err
Right env' ->
@@ -325,7 +325,7 @@ handleKindOf typ = do
Just (_, typ') -> do
let chk = P.CheckState env' 0 0 (Just mName)
k = L.runStateT (P.unCheck (P.kindOf mName typ')) chk
- case k of
+ case k of
Left errStack -> PSCI . outputStrLn . P.prettyPrintErrorStack False $ errStack
Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind
Nothing -> PSCI $ outputStrLn "Could not find kind"
@@ -340,6 +340,7 @@ getCommand = do
firstLine <- getInputLine "> "
case firstLine of
Nothing -> return (Right Nothing)
+ Just "" -> return (Right Nothing)
Just s@ (':' : _) -> return . either Left (Right . Just) $ parseCommand s -- The start of a command
Just s -> either Left (Right . Just) . parseCommand <$> go [s]
where
diff --git a/purescript.cabal b/purescript.cabal
index 4cb138f..5d683da 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.5.4
+version: 0.5.4.1
cabal-version: >=1.8
build-type: Custom
license: MIT
@@ -17,14 +17,17 @@ author: Phil Freeman <paf31@cantab.net>,
data-files: prelude/prelude.purs
data-dir: ""
+extra-source-files: examples/passing/*.purs
+ , examples/failing/*.purs
+
source-repository head
type: git
location: https://github.com/purescript/purescript.git
library
build-depends: base >=4 && <5, cmdtheline == 0.2.*, containers -any, unordered-containers -any,
- directory >= 1.2, filepath -any, mtl >= 2.1.0 && < 2.2.0, parsec -any,
- transformers >= 0.3 && < 0.4, utf8-string -any,
+ directory >= 1.2, filepath -any, mtl >= 2.1.0 && < 2.3.0, parsec -any,
+ transformers >= 0.3 && < 0.5, utf8-string -any,
pattern-arrows >= 0.0.2 && < 0.1,
monad-unify >= 0.2.2 && < 0.3,
xdg-basedir -any, time -any
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index 54bd11f..c2b2872 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -250,7 +250,7 @@ reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
addDefaultImport :: ModuleName -> Module -> Module
addDefaultImport toImport m@(Module mn decls exps) =
if isExistingImport `any` decls || mn == toImport then m
- else Module mn (ImportDeclaration toImport Nothing Nothing : decls) exps
+ else Module mn (ImportDeclaration toImport Unqualified Nothing : decls) exps
where
isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
isExistingImport (PositionedDeclaration _ d) = isExistingImport d
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index dfe965f..47a0703 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -56,7 +56,7 @@ moduleToJs mt opts (Module name decls (Just exps)) env = do
let jsImports = map (importToJs mt opts) . delete (ModuleName [ProperName C.prim]) . (\\ [name]) . nub $ concatMap imports decls
jsDecls <- mapM (\decl -> declToJs opts name decl env) decls
let optimized = concat $ map (map $ optimize opts) $ catMaybes jsDecls
- let isModuleEmpty = null optimized
+ let isModuleEmpty = null exps
let moduleBody = JSStringLiteral "use strict" : jsImports ++ optimized
let moduleExports = JSObjectLiteral $ concatMap exportToJs exps
return $ case mt of
@@ -83,7 +83,7 @@ imports other =
let (f, _, _, _, _) = everythingOnValues (++) (const []) collectV collectB (const []) (const [])
in f other
where
- collectV :: Value -> [ModuleName]
+ collectV :: Expr -> [ModuleName]
collectV (Var (Qualified (Just mn) _)) = [mn]
collectV (Constructor (Qualified (Just mn) _)) = [mn]
collectV (TypeClassDictionaryConstructorApp (Qualified (Just mn) _) _) = [mn]
@@ -190,7 +190,7 @@ accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)
-- |
-- Generate code in the simplified Javascript intermediate representation for a value or expression.
--
-valueToJs :: (Functor m, Applicative m, Monad m) => Options -> ModuleName -> Environment -> Value -> SupplyT m JS
+valueToJs :: (Functor m, Applicative m, Monad m) => Options -> ModuleName -> Environment -> Expr -> SupplyT m JS
valueToJs _ _ _ (NumericLiteral n) = return $ JSNumericLiteral n
valueToJs _ _ _ (StringLiteral s) = return $ JSStringLiteral s
valueToJs _ _ _ (BooleanLiteral b) = return $ JSBooleanLiteral b
@@ -221,7 +221,7 @@ valueToJs opts m e v@App{} = do
return $ JSUnary JSNew $ JSApp (qualifiedToJS m (Ident . runProperName) name) args'
_ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs opts m e f
where
- unApp :: Value -> [Value] -> (Value, [Value])
+ unApp :: Expr -> [Expr] -> (Expr, [Expr])
unApp (App val arg) args = unApp val (arg : args)
unApp (PositionedValue _ val) args = unApp val args
unApp (TypedValue _ val _) args = unApp val args
@@ -317,11 +317,12 @@ qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)
bindersToJs :: (Functor m, Applicative m, Monad m) => Options -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> SupplyT m JS
bindersToJs opts m e binders vals = do
valNames <- replicateM (length vals) freshName
+ let assignments = zipWith JSVariableIntroduction valNames (map Just vals)
jss <- forM binders $ \(CaseAlternative bs grd result) -> do
ret <- valueToJs opts m e result
go valNames [JSReturn ret] bs grd
- return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") $ [(JSStringLiteral "Failed pattern match")]])))
- vals
+ return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") $ [JSStringLiteral "Failed pattern match"]])))
+ []
where
go :: (Functor m, Applicative m, Monad m) => [String] -> [JS] -> [Binder] -> Maybe Guard -> SupplyT m [JS]
go _ done [] Nothing = return done
diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs
index 53879c6..d2c5a75 100644
--- a/src/Language/PureScript/Constants.hs
+++ b/src/Language/PureScript/Constants.hs
@@ -201,6 +201,9 @@ main = "main"
__superclass_ :: String
__superclass_ = "__superclass_"
+__unused :: String
+__unused = "__unused"
+
-- Modules
prim :: String
diff --git a/src/Language/PureScript/DeadCodeElimination.hs b/src/Language/PureScript/DeadCodeElimination.hs
index ed891a5..0d55e01 100644
--- a/src/Language/PureScript/DeadCodeElimination.hs
+++ b/src/Language/PureScript/DeadCodeElimination.hs
@@ -79,7 +79,7 @@ dependencies moduleName =
let (f, _, _, _, _) = everythingOnValues (++) (const []) values (const []) (const []) (const [])
in nub . f
where
- values :: Value -> [Key]
+ values :: Expr -> [Key]
values (Var ident) = let (mn, name) = qualify moduleName ident in [(mn, Left name)]
values (Constructor (Qualified (Just mn) name)) = [(mn, Right name)]
values (Constructor (Qualified Nothing _)) = error "Found unqualified data constructor"
diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs
index ef7e413..a3b7689 100644
--- a/src/Language/PureScript/Declarations.hs
+++ b/src/Language/PureScript/Declarations.hs
@@ -114,6 +114,24 @@ instance Eq DeclarationRef where
_ == _ = False
-- |
+-- The data type which specifies type of import declaration
+--
+data ImportDeclarationType
+ -- |
+ -- Unqualified import
+ --
+ = Unqualified
+ -- |
+ -- Qualified import with a list of references to import
+ --
+ | Qualifying [DeclarationRef]
+ -- |
+ -- Import with hiding clause with a list of references to hide
+ --
+ | Hiding [DeclarationRef]
+ deriving (Show, D.Data, D.Typeable)
+
+-- |
-- The data type of declarations
--
data Declaration
@@ -136,11 +154,11 @@ data Declaration
-- |
-- A value declaration (name, top-level binders, optional guard, value)
--
- | ValueDeclaration Ident NameKind [Binder] (Maybe Guard) Value
+ | ValueDeclaration Ident NameKind [Binder] (Maybe Guard) Expr
-- |
-- A minimal mutually recursive set of value declarations
--
- | BindingGroupDeclaration [(Ident, NameKind, Value)]
+ | BindingGroupDeclaration [(Ident, NameKind, Expr)]
-- |
-- A foreign import declaration (type, name, optional inline Javascript, type)
--
@@ -158,10 +176,10 @@ data Declaration
--
| FixityDeclaration Fixity String
-- |
- -- A module import (module name, optional set of identifiers to import, optional "qualified as"
- -- name)
+ -- A module import (module name, optional set of identifiers to import,
+ -- optional set of identifiers to hide, optional "qualified as" name)
--
- | ImportDeclaration ModuleName (Maybe [DeclarationRef]) (Maybe ModuleName)
+ | ImportDeclaration ModuleName ImportDeclarationType (Maybe ModuleName)
-- |
-- A type class declaration (name, argument, implies, member declarations)
--
@@ -246,12 +264,12 @@ isTypeClassDeclaration _ = False
-- |
-- A guard is just a boolean-valued expression that appears alongside a set of binders
--
-type Guard = Value
+type Guard = Expr
-- |
--- Data type for values
+-- Data type for expressions and terms
--
-data Value
+data Expr
-- |
-- A numeric literal
--
@@ -267,41 +285,41 @@ data Value
-- |
-- A prefix -, will be desugared
--
- | UnaryMinus Value
+ | UnaryMinus Expr
-- |
-- Binary operator application. During the rebracketing phase of desugaring, this data constructor
-- will be removed.
--
- | BinaryNoParens (Qualified Ident) Value Value
+ | BinaryNoParens (Qualified Ident) Expr Expr
-- |
-- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor
-- will be removed.
--
- | Parens Value
+ | Parens Expr
-- |
-- An array literal
--
- | ArrayLiteral [Value]
+ | ArrayLiteral [Expr]
-- |
-- An object literal
--
- | ObjectLiteral [(String, Value)]
+ | ObjectLiteral [(String, Expr)]
-- |
-- An record property accessor expression
--
- | Accessor String Value
+ | Accessor String Expr
-- |
-- Partial record update
--
- | ObjectUpdate Value [(String, Value)]
+ | ObjectUpdate Expr [(String, Expr)]
-- |
-- Function introduction
--
- | Abs (Either Ident Binder) Value
+ | Abs (Either Ident Binder) Expr
-- |
-- Function application
--
- | App Value Value
+ | App Expr Expr
-- |
-- Variable
--
@@ -309,7 +327,7 @@ data Value
-- |
-- Conditional (if-then-else expression)
--
- | IfThenElse Value Value Value
+ | IfThenElse Expr Expr Expr
-- |
-- A data constructor
--
@@ -318,15 +336,15 @@ data Value
-- A case expression. During the case expansion phase of desugaring, top-level binders will get
-- desugared into case expressions, hence the need for guards and multiple binders per branch here.
--
- | Case [Value] [CaseAlternative]
+ | Case [Expr] [CaseAlternative]
-- |
-- A value with a type annotation
--
- | TypedValue Bool Value Type
+ | TypedValue Bool Expr Type
-- |
-- A let binding
--
- | Let [Declaration] Value
+ | Let [Declaration] Expr
-- |
-- A do-notation block
--
@@ -335,7 +353,7 @@ data Value
-- An application of a typeclass dictionary constructor. The value should be
-- an ObjectLiteral.
--
- | TypeClassDictionaryConstructorApp (Qualified ProperName) Value
+ | TypeClassDictionaryConstructorApp (Qualified ProperName) Expr
-- |
-- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these
-- placeholders will be replaced with actual expressions representing type classes dictionaries which
@@ -351,7 +369,7 @@ data Value
-- |
-- A value with source position information
--
- | PositionedValue SourcePos Value deriving (Show, D.Data, D.Typeable)
+ | PositionedValue SourcePos Expr deriving (Show, D.Data, D.Typeable)
-- |
-- An alternative in a case statement
@@ -368,7 +386,7 @@ data CaseAlternative = CaseAlternative
-- |
-- The result expression
--
- , caseAlternativeResult :: Value
+ , caseAlternativeResult :: Expr
} deriving (Show, D.Data, D.Typeable)
-- |
@@ -385,11 +403,11 @@ data DoNotationElement
-- |
-- A monadic value without a binder
--
- = DoNotationValue Value
+ = DoNotationValue Expr
-- |
-- A monadic value with a binder
--
- | DoNotationBind Binder Value
+ | DoNotationBind Binder Expr
-- |
-- A let statement, i.e. a pure value with a binder
--
@@ -468,9 +486,9 @@ binderNames = go []
--
everywhereOnValues :: (Declaration -> Declaration) ->
- (Value -> Value) ->
+ (Expr -> Expr) ->
(Binder -> Binder) ->
- (Declaration -> Declaration, Value -> Value, Binder -> Binder)
+ (Declaration -> Declaration, Expr -> Expr, Binder -> Binder)
everywhereOnValues f g h = (f', g', h')
where
f' :: Declaration -> Declaration
@@ -482,7 +500,7 @@ everywhereOnValues f g h = (f', g', h')
f' (PositionedDeclaration pos d) = f (PositionedDeclaration pos (f' d))
f' other = f other
- g' :: Value -> Value
+ g' :: Expr -> Expr
g' (UnaryMinus v) = g (UnaryMinus (g' v))
g' (BinaryNoParens op v1 v2) = g (BinaryNoParens op (g' v1) (g' v2))
g' (Parens v) = g (Parens (g' v))
@@ -526,9 +544,9 @@ everywhereOnValues f g h = (f', g', h')
everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>
(Declaration -> m Declaration) ->
- (Value -> m Value) ->
+ (Expr -> m Expr) ->
(Binder -> m Binder) ->
- (Declaration -> m Declaration, Value -> m Value, Binder -> m Binder)
+ (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)
everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
where
f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f' <=< f) ds
@@ -576,9 +594,9 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
everywhereOnValuesM :: (Functor m, Applicative m, Monad m) =>
(Declaration -> m Declaration) ->
- (Value -> m Value) ->
+ (Expr -> m Expr) ->
(Binder -> m Binder) ->
- (Declaration -> m Declaration, Value -> m Value, Binder -> m Binder)
+ (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)
everywhereOnValuesM f g h = (f' <=< f, g' <=< g, h' <=< h)
where
f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> mapM f' ds) >>= f
@@ -626,11 +644,11 @@ everywhereOnValuesM f g h = (f' <=< f, g' <=< g, h' <=< h)
everythingOnValues :: (r -> r -> r) ->
(Declaration -> r) ->
- (Value -> r) ->
+ (Expr -> r) ->
(Binder -> r) ->
(CaseAlternative -> r) ->
(DoNotationElement -> r) ->
- (Declaration -> r, Value -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)
+ (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)
everythingOnValues (<>) f g h i j = (f', g', h', i', j')
where
f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds)
@@ -682,12 +700,12 @@ everythingWithContextOnValues ::
r ->
(r -> r -> r) ->
(s -> Declaration -> (s, r)) ->
- (s -> Value -> (s, r)) ->
+ (s -> Expr -> (s, r)) ->
(s -> Binder -> (s, r)) ->
(s -> CaseAlternative -> (s, r)) ->
(s -> DoNotationElement -> (s, r)) ->
( Declaration -> r
- , Value -> r
+ , Expr -> r
, Binder -> r
, CaseAlternative -> r
, DoNotationElement -> r)
@@ -749,12 +767,12 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
everywhereWithContextOnValuesM :: (Functor m, Applicative m, Monad m) =>
s ->
(s -> Declaration -> m (s, Declaration)) ->
- (s -> Value -> m (s, Value)) ->
+ (s -> Expr -> m (s, Expr)) ->
(s -> Binder -> m (s, Binder)) ->
(s -> CaseAlternative -> m (s, CaseAlternative)) ->
(s -> DoNotationElement -> m (s, DoNotationElement)) ->
( Declaration -> m Declaration
- , Value -> m Value
+ , Expr -> m Expr
, Binder -> m Binder
, CaseAlternative -> m CaseAlternative
, DoNotationElement -> m DoNotationElement)
@@ -811,7 +829,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
j' s (DoNotationLet ds) = DoNotationLet <$> mapM (f'' s) ds
j' s (PositionedDoNotationElement pos e1) = PositionedDoNotationElement pos <$> j'' s e1
-accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Value -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)
+accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)
accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)
where
forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 03814d7..27e28e1 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -30,9 +30,9 @@ import Language.PureScript.Types
--
data ErrorSource
-- |
- -- An error which originated at a Value
+ -- An error which originated at a Expr
--
- = ValueError Value
+ = ExprError Expr
-- |
-- An error which originated at a Type
--
@@ -89,7 +89,7 @@ isErrorNonEmpty = not . null . compileErrorMessage
showError :: CompileError -> String
showError (CompileError msg Nothing _) = msg
-showError (CompileError msg (Just (ValueError val)) _) = "Error in value " ++ prettyPrintValue val ++ ":\n" ++ msg
+showError (CompileError msg (Just (ExprError val)) _) = "Error in expression " ++ prettyPrintValue val ++ ":\n" ++ msg
showError (CompileError msg (Just (TypeError ty)) _) = "Error in type " ++ prettyPrintType ty ++ ":\n" ++ msg
mkErrorStack :: String -> Maybe ErrorSource -> ErrorStack
diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs
index 6c23255..e191e15 100644
--- a/src/Language/PureScript/ModuleDependencies.hs
+++ b/src/Language/PureScript/ModuleDependencies.hs
@@ -52,7 +52,7 @@ usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (
forDecls (ImportDeclaration mn _ _) = [mn]
forDecls _ = []
- forValues :: Value -> [ModuleName]
+ forValues :: Expr -> [ModuleName]
forValues (Var (Qualified (Just mn) _)) = [mn]
forValues (BinaryNoParens (Qualified (Just mn) _) _ _) = [mn]
forValues (Constructor (Qualified (Just mn) _)) = [mn]
diff --git a/src/Language/PureScript/Optimizer/Inliner.hs b/src/Language/PureScript/Optimizer/Inliner.hs
index bf39d2e..cdcca29 100644
--- a/src/Language/PureScript/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/Optimizer/Inliner.hs
@@ -49,8 +49,8 @@ etaConvert = everywhereOnJS convert
not (any (`isRebound` block) (map JSVar idents)) &&
not (any (`isRebound` block) args)
= JSBlock (map (replaceIdents (zip idents args)) body)
- convert (JSFunction Nothing ["_"] (JSBlock [JSReturn (JSApp fn@JSVar{} [JSObjectLiteral []])]))
- = fn
+ convert (JSFunction Nothing [arg] (JSBlock [JSReturn (JSApp fn@JSVar{} [JSObjectLiteral []])]))
+ | arg == C.__unused = fn
convert js = js
unThunk :: JS -> JS
diff --git a/src/Language/PureScript/Optimizer/MagicDo.hs b/src/Language/PureScript/Optimizer/MagicDo.hs
index e271de8..6d27a6b 100644
--- a/src/Language/PureScript/Optimizer/MagicDo.hs
+++ b/src/Language/PureScript/Optimizer/MagicDo.hs
@@ -60,7 +60,7 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert
-- Desugar pure
convert (JSApp (JSApp pure' [val]) []) | isPure pure' = val
-- Desugar >>
- convert (JSApp (JSApp bind [m]) [JSFunction Nothing ["_"] (JSBlock js)]) | isBind bind && isJSReturn (last js) =
+ convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock js)]) | isBind bind && isJSReturn (last js) && arg == C.__unused =
let JSReturn ret = last js in
JSFunction (Just fnName) [] $ JSBlock (JSApp m [] : init js ++ [JSReturn (JSApp ret [])] )
-- Desugar >>=
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 26b7595..9c79a55 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -123,16 +123,27 @@ parseImportDeclaration = do
where
stdImport = do
moduleName' <- moduleName
- idents <- P.optionMaybe $ indented *> (parens $ commaSep parseDeclarationRef)
- return $ ImportDeclaration moduleName' idents Nothing
+ stdImportHiding moduleName' <|> stdImportQualifying moduleName'
+ where
+ stdImportHiding mn = do
+ reserved "hiding"
+ declType <- importDeclarationType Hiding
+ return $ ImportDeclaration mn declType Nothing
+ stdImportQualifying mn = do
+ declType <- importDeclarationType Qualifying
+ return $ ImportDeclaration mn declType Nothing
qualImport = do
reserved "qualified"
indented
moduleName' <- moduleName
- idents <- P.optionMaybe $ indented *> (parens $ commaSep parseDeclarationRef)
+ declType <- importDeclarationType Qualifying
reserved "as"
asQ <- moduleName
- return $ ImportDeclaration moduleName' idents (Just asQ)
+ return $ ImportDeclaration moduleName' declType (Just asQ)
+ importDeclarationType expectedType = do
+ idents <- P.optionMaybe $ indented *> (parens $ commaSep parseDeclarationRef)
+ return $ fromMaybe Unqualified (expectedType <$> idents)
+
parseDeclarationRef :: P.Parsec String ParseState DeclarationRef
parseDeclarationRef = PositionedDeclarationRef <$> sourcePos <*>
@@ -219,26 +230,26 @@ parseModules = whiteSpace *> mark (P.many (same *> parseModule)) <* P.eof
booleanLiteral :: P.Parsec String ParseState Bool
booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)
-parseNumericLiteral :: P.Parsec String ParseState Value
+parseNumericLiteral :: P.Parsec String ParseState Expr
parseNumericLiteral = NumericLiteral <$> C.integerOrFloat
-parseStringLiteral :: P.Parsec String ParseState Value
+parseStringLiteral :: P.Parsec String ParseState Expr
parseStringLiteral = StringLiteral <$> C.stringLiteral
-parseBooleanLiteral :: P.Parsec String ParseState Value
+parseBooleanLiteral :: P.Parsec String ParseState Expr
parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
-parseArrayLiteral :: P.Parsec String ParseState Value
+parseArrayLiteral :: P.Parsec String ParseState Expr
parseArrayLiteral = ArrayLiteral <$> C.squares (C.commaSep parseValue)
-parseObjectLiteral :: P.Parsec String ParseState Value
+parseObjectLiteral :: P.Parsec String ParseState Expr
parseObjectLiteral = ObjectLiteral <$> C.braces (C.commaSep parseIdentifierAndValue)
-parseIdentifierAndValue :: P.Parsec String ParseState (String, Value)
+parseIdentifierAndValue :: P.Parsec String ParseState (String, Expr)
parseIdentifierAndValue = (,) <$> (C.indented *> (C.identifier <|> C.stringLiteral) <* C.indented <* C.colon)
<*> (C.indented *> parseValue)
-parseAbs :: P.Parsec String ParseState Value
+parseAbs :: P.Parsec String ParseState Expr
parseAbs = do
C.reservedOp "\\"
args <- P.many1 (C.indented *> (Abs <$> (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens)))
@@ -246,16 +257,16 @@ parseAbs = do
value <- parseValue
return $ toFunction args value
where
- toFunction :: [Value -> Value] -> Value -> Value
+ toFunction :: [Expr -> Expr] -> Expr -> Expr
toFunction args value = foldr ($) value args
-parseVar :: P.Parsec String ParseState Value
+parseVar :: P.Parsec String ParseState Expr
parseVar = Var <$> C.parseQualified C.parseIdent
-parseConstructor :: P.Parsec String ParseState Value
+parseConstructor :: P.Parsec String ParseState Expr
parseConstructor = Constructor <$> C.parseQualified C.properName
-parseCase :: P.Parsec String ParseState Value
+parseCase :: P.Parsec String ParseState Expr
parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") (return <$> parseValue)
<*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))
@@ -265,12 +276,12 @@ parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder)
<*> (C.indented *> C.reservedOp "->" *> parseValue)
P.<?> "case alternative"
-parseIfThenElse :: P.Parsec String ParseState Value
+parseIfThenElse :: P.Parsec String ParseState Expr
parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parseValue)
<*> (C.indented *> C.reserved "then" *> C.indented *> parseValue)
<*> (C.indented *> C.reserved "else" *> C.indented *> parseValue)
-parseLet :: P.Parsec String ParseState Value
+parseLet :: P.Parsec String ParseState Expr
parseLet = do
C.reserved "let"
C.indented
@@ -280,7 +291,7 @@ parseLet = do
result <- parseValue
return $ Let ds result
-parseValueAtom :: P.Parsec String ParseState Value
+parseValueAtom :: P.Parsec String ParseState Expr
parseValueAtom = P.choice
[ P.try parseNumericLiteral
, P.try parseStringLiteral
@@ -296,18 +307,18 @@ parseValueAtom = P.choice
, parseLet
, Parens <$> C.parens parseValue ]
-parsePropertyUpdate :: P.Parsec String ParseState (String, Value)
+parsePropertyUpdate :: P.Parsec String ParseState (String, Expr)
parsePropertyUpdate = do
name <- C.lexeme (C.identifier <|> C.stringLiteral)
_ <- C.lexeme $ C.indented *> P.char '='
value <- C.indented *> parseValue
return (name, value)
-parseAccessor :: Value -> P.Parsec String ParseState Value
+parseAccessor :: Expr -> P.Parsec String ParseState Expr
parseAccessor (Constructor _) = P.unexpected "constructor"
parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> (C.identifier <|> C.stringLiteral)) <*> pure obj
-parseDo :: P.Parsec String ParseState Value
+parseDo :: P.Parsec String ParseState Expr
parseDo = do
C.reserved "do"
C.indented
@@ -328,7 +339,7 @@ parseDoNotationElement = P.choice
-- |
-- Parse a value
--
-parseValue :: P.Parsec String ParseState Value
+parseValue :: P.Parsec String ParseState Expr
parseValue = PositionedValue <$> sourcePos <*>
(P.buildExpressionParser operators
. C.buildPostfixParser postfixTable2
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index 9476053..b560446 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -30,10 +30,10 @@ import Language.PureScript.Declarations
import Language.PureScript.Pretty.Common
import Language.PureScript.Pretty.Types (prettyPrintType)
-literals :: Pattern PrinterState Value String
+literals :: Pattern PrinterState Expr String
literals = mkPattern' match
where
- match :: Value -> StateT PrinterState Maybe String
+ match :: Expr -> StateT PrinterState Maybe String
match (NumericLiteral n) = return $ either show show n
match (StringLiteral s) = return $ show s
match (BooleanLiteral True) = return "true"
@@ -118,31 +118,31 @@ prettyPrintDoNotationElement (DoNotationLet ds) =
]
prettyPrintDoNotationElement (PositionedDoNotationElement _ el) = prettyPrintDoNotationElement el
-ifThenElse :: Pattern PrinterState Value ((Value, Value), Value)
+ifThenElse :: Pattern PrinterState Expr ((Expr, Expr), Expr)
ifThenElse = mkPattern match
where
match (IfThenElse cond th el) = Just ((th, el), cond)
match _ = Nothing
-accessor :: Pattern PrinterState Value (String, Value)
+accessor :: Pattern PrinterState Expr (String, Expr)
accessor = mkPattern match
where
match (Accessor prop val) = Just (prop, val)
match _ = Nothing
-objectUpdate :: Pattern PrinterState Value ([String], Value)
+objectUpdate :: Pattern PrinterState Expr ([String], Expr)
objectUpdate = mkPattern match
where
match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)
match _ = Nothing
-app :: Pattern PrinterState Value (String, Value)
+app :: Pattern PrinterState Expr (String, Expr)
app = mkPattern match
where
match (App val arg) = Just (prettyPrintValue arg, val)
match _ = Nothing
-lam :: Pattern PrinterState Value (String, Value)
+lam :: Pattern PrinterState Expr (String, Expr)
lam = mkPattern match
where
match (Abs (Left arg) val) = Just (show arg, val)
@@ -151,15 +151,15 @@ lam = mkPattern match
-- |
-- Generate a pretty-printed string representing an expression
--
-prettyPrintValue :: Value -> String
+prettyPrintValue :: Expr -> String
prettyPrintValue = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintValue'
-prettyPrintValue' :: Value -> StateT PrinterState Maybe String
+prettyPrintValue' :: Expr -> StateT PrinterState Maybe String
prettyPrintValue' = runKleisli $ runPattern matchValue
where
- matchValue :: Pattern PrinterState Value String
+ matchValue :: Pattern PrinterState Expr String
matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
- operators :: OperatorTable PrinterState Value String
+ operators :: OperatorTable PrinterState Expr String
operators =
OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
, [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]
@@ -224,7 +224,7 @@ prettyPrintObjectPropertyBinder (key, binder) = fmap concat $ sequence
, prettyPrintBinder' binder
]
-prettyPrintObjectProperty :: (String, Value) -> StateT PrinterState Maybe String
+prettyPrintObjectProperty :: (String, Expr) -> StateT PrinterState Maybe String
prettyPrintObjectProperty (key, value) = fmap concat $ sequence
[ return $ prettyPrintObjectKey key ++ ": "
, prettyPrintValue' value
diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs
index 259edef..907b3db 100644
--- a/src/Language/PureScript/Renamer.hs
+++ b/src/Language/PureScript/Renamer.hs
@@ -28,6 +28,8 @@ import Language.PureScript.Environment
import Language.PureScript.Names
import Language.PureScript.Traversals
+import qualified Language.PureScript.Constants as C
+
-- |
-- The state object used in this module
--
@@ -69,6 +71,7 @@ newScope x = do
-- unique name is generated and stored.
--
updateScope :: Ident -> Rename Ident
+updateScope i@(Ident name) | name == C.__unused = return i
updateScope name = do
scope <- get
let name' = case name `S.member` rsUsedNames scope of
@@ -87,6 +90,7 @@ updateScope name = do
-- Finds the new name to use for an ident.
--
lookupIdent :: Ident -> Rename Ident
+lookupIdent i@(Ident name) | name == C.__unused = return i
lookupIdent name = do
name' <- gets $ M.lookup name . rsBoundNames
case name' of
@@ -132,11 +136,11 @@ renameInDecl isTopLevel (BindingGroupDeclaration ds) = do
ds' <- mapM updateNames ds
BindingGroupDeclaration <$> mapM updateValues ds'
where
- updateNames :: (Ident, NameKind, Value) -> Rename (Ident, NameKind, Value)
+ updateNames :: (Ident, NameKind, Expr) -> Rename (Ident, NameKind, Expr)
updateNames (name, nameKind, val) = do
name' <- if isTopLevel then return name else updateScope name
return (name', nameKind, val)
- updateValues :: (Ident, NameKind, Value) -> Rename (Ident, NameKind, Value)
+ updateValues :: (Ident, NameKind, Expr) -> Rename (Ident, NameKind, Expr)
updateValues (name, nameKind, val) =
(,,) name nameKind <$> renameInValue val
renameInDecl _ (TypeInstanceDeclaration name cs className args ds) =
@@ -148,7 +152,7 @@ renameInDecl _ other = return other
-- |
-- Renames within a value.
--
-renameInValue :: Value -> Rename Value
+renameInValue :: Expr -> Rename Expr
renameInValue (UnaryMinus v) =
UnaryMinus <$> renameInValue v
renameInValue (ArrayLiteral vs) =
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index 180ef7f..011dce1 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -85,7 +85,7 @@ collapseBindingGroups = let (f, _, _) = everywhereOnValues id collapseBindingGro
go (PositionedDeclaration pos d) = map (PositionedDeclaration pos) $ go d
go other = [other]
-collapseBindingGroupsForValue :: Value -> Value
+collapseBindingGroupsForValue :: Expr -> Expr
collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val
collapseBindingGroupsForValue other = other
@@ -94,7 +94,7 @@ usedIdents moduleName =
let (f, _, _, _, _) = everythingOnValues (++) (const []) usedNames (const []) (const []) (const [])
in nub . f
where
- usedNames :: Value -> [Ident]
+ usedNames :: Expr -> [Ident]
usedNames (Var (Qualified Nothing name)) = [name]
usedNames (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]
usedNames _ = []
@@ -142,7 +142,7 @@ isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn
isTypeSynonym (PositionedDeclaration _ d) = isTypeSynonym d
isTypeSynonym _ = Nothing
-fromValueDecl :: Declaration -> (Ident, NameKind, Value)
+fromValueDecl :: Declaration -> (Ident, NameKind, Expr)
fromValueDecl (ValueDeclaration ident nameKind [] Nothing val) = (ident, nameKind, val)
fromValueDecl ValueDeclaration{} = error "Binders should have been desugared"
fromValueDecl (PositionedDeclaration _ d) = fromValueDecl d
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index 805a00c..44bd0d3 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -45,7 +45,7 @@ desugarAbs = mapM f
where
(f, _, _) = everywhereOnValuesM return replace return
- replace :: Value -> SupplyT (Either ErrorStack) Value
+ replace :: Expr -> SupplyT (Either ErrorStack) Expr
replace (Abs (Right binder) val) = do
ident <- Ident <$> freshName
return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing val]
@@ -98,12 +98,12 @@ isVarBinder :: Binder -> Bool
isVarBinder (VarBinder _) = True
isVarBinder _ = False
-toTuple :: Declaration -> ([Binder], (Maybe Guard, Value))
+toTuple :: Declaration -> ([Binder], (Maybe Guard, Expr))
toTuple (ValueDeclaration _ _ bs g val) = (bs, (g, val))
toTuple (PositionedDeclaration _ d) = toTuple d
toTuple _ = error "Not a value declaration"
-makeCaseDeclaration :: Ident -> [([Binder], (Maybe Guard, Value))] -> SupplyT (Either ErrorStack) Declaration
+makeCaseDeclaration :: Ident -> [([Binder], (Maybe Guard, Expr))] -> SupplyT (Either ErrorStack) Declaration
makeCaseDeclaration ident alternatives = do
let argPattern = length . fst . head $ alternatives
args <- map Ident <$> replicateM argPattern freshName
diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs
index f8f83c8..16ca51c 100644
--- a/src/Language/PureScript/Sugar/DoNotation.hs
+++ b/src/Language/PureScript/Sugar/DoNotation.hs
@@ -44,20 +44,20 @@ desugarDo d =
prelude :: ModuleName
prelude = ModuleName [ProperName C.prelude]
- bind :: Value
+ bind :: Expr
bind = Var (Qualified (Just prelude) (Op (C.>>=)))
- replace :: Value -> SupplyT (Either ErrorStack) Value
+ replace :: Expr -> SupplyT (Either ErrorStack) Expr
replace (Do els) = go els
replace (PositionedValue pos v) = PositionedValue pos <$> rethrowWithPosition pos (replace v)
replace other = return other
- go :: [DoNotationElement] -> SupplyT (Either ErrorStack) Value
+ go :: [DoNotationElement] -> SupplyT (Either ErrorStack) Expr
go [] = error "The impossible happened in desugarDo"
go [DoNotationValue val] = return val
go (DoNotationValue val : rest) = do
rest' <- go rest
- return $ App (App bind val) (Abs (Left (Ident "_")) rest')
+ return $ App (App bind val) (Abs (Left (Ident C.__unused)) rest')
go [DoNotationBind _ _] = lift $ Left $ mkErrorStack "Bind statement cannot be the last statement in a do block" Nothing
go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)
go (DoNotationBind (VarBinder ident) val : rest) = do
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index 205c57a..97fd33d 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -198,7 +198,7 @@ renameInModule imports exports (Module mn decls exps) =
(,) (pos, name : bound) <$> (ExternDeclaration fit name js <$> updateTypesEverywhere pos ty)
updateDecl s d = return (s, d)
- updateValue :: (Maybe SourcePos, [Ident]) -> Value -> Either ErrorStack ((Maybe SourcePos, [Ident]), Value)
+ updateValue :: (Maybe SourcePos, [Ident]) -> Expr -> Either ErrorStack ((Maybe SourcePos, [Ident]), Expr)
updateValue (_, bound) v@(PositionedValue pos' _) = return ((Just pos', bound), v)
updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')
updateValue (pos, bound) (Let ds val') =
@@ -253,15 +253,19 @@ renameInModule imports exports (Module mn decls exps) =
-> Qualified a
-> Maybe SourcePos
-> Either ErrorStack (Qualified a)
- update t getI checkE qname@(Qualified mn' name) pos = case (M.lookup qname (getI imports), mn') of
+ update t getI checkE qname@(Qualified mn' name) pos = positioned $ case (M.lookup qname imports', mn') of
(Just qname', _) -> return qname'
(Nothing, Just mn'') -> do
+ when (isExplicitQualModule mn'') $ throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show qname ++ "'") Nothing
modExports <- getExports mn''
if checkE modExports name
then return qname
- else positioned $ throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show qname ++ "'") Nothing
- _ -> positioned $ throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show name ++ "'") Nothing
+ else throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show qname ++ "'") Nothing
+ _ -> throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show name ++ "'") Nothing
where
+ isExplicitQualModule :: ModuleName -> Bool
+ isExplicitQualModule = flip elem $ mapMaybe (\(Qualified q _) -> q) (M.keys imports')
+ imports' = getI imports
positioned err = case pos of
Nothing -> err
Just pos' -> rethrowWithPosition pos' err
@@ -360,18 +364,13 @@ filterExports mn exps env = do
filterValues _ result _ = return result
-- |
--- Type representing a set of declarations being explicitly imported from a module
---
-type ExplicitImports = [DeclarationRef]
-
--- |
-- Finds the imports within a module, mapping the imported module name to an optional set of
-- explicitly imported declarations.
--
-findImports :: [Declaration] -> M.Map ModuleName (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName)
+findImports :: [Declaration] -> M.Map ModuleName (Maybe SourcePos, ImportDeclarationType, Maybe ModuleName)
findImports = foldl (findImports' Nothing) M.empty
where
- findImports' pos result (ImportDeclaration mn expl qual) = M.insert mn (pos, expl, qual) result
+ findImports' pos result (ImportDeclaration mn typ qual) = M.insert mn (pos, typ, qual) result
findImports' _ result (PositionedDeclaration pos d) = findImports' (Just pos) result d
findImports' _ result _ = result
@@ -386,13 +385,13 @@ resolveImports env (Module currentModule decls _) =
-- A Map from module name to the source position for the import, the list of imports from that
-- module (where Nothing indicates everything is to be imported), and optionally a qualified name
-- for the module
- scope :: M.Map ModuleName (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName)
- scope = M.insert currentModule (Nothing, Nothing, Nothing) (findImports decls)
+ scope :: M.Map ModuleName (Maybe SourcePos, ImportDeclarationType, Maybe ModuleName)
+ scope = M.insert currentModule (Nothing, Unqualified, Nothing) (findImports decls)
- resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName)) -> Either ErrorStack ImportEnvironment
- resolveImport' imp (mn, (pos, explImports, impQual)) = do
+ resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourcePos, ImportDeclarationType, Maybe ModuleName)) -> Either ErrorStack ImportEnvironment
+ resolveImport' imp (mn, (pos, typ, impQual)) = do
modExports <- positioned $ maybe (throwError $ mkErrorStack ("Cannot import unknown module '" ++ show mn ++ "'") Nothing) return $ mn `M.lookup` env
- positioned $ resolveImport currentModule mn modExports imp impQual explImports
+ positioned $ resolveImport currentModule mn modExports imp impQual typ
where
positioned err = case pos of
Nothing -> err
@@ -401,37 +400,77 @@ resolveImports env (Module currentModule decls _) =
-- |
-- Extends the local environment for a module by resolving an import of another module.
--
-resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> Maybe ExplicitImports-> Either ErrorStack ImportEnvironment
-resolveImport currentModule importModule exps imps impQual = maybe importAll (foldM importExplicit imps)
+resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> ImportDeclarationType -> Either ErrorStack ImportEnvironment
+resolveImport currentModule importModule exps imps impQual =
+ resolveByType
where
- -- Import everything from a module
- importAll :: Either ErrorStack ImportEnvironment
- importAll = do
- imp' <- foldM (\m (name, dctors) -> importExplicit m (TypeRef name (Just dctors))) imps (exportedTypes exps)
- imp'' <- foldM (\m name -> importExplicit m (ValueRef name)) imp' (exportedValues exps)
- foldM (\m name -> importExplicit m (TypeClassRef name)) imp'' (exportedTypeClasses exps)
+ resolveByType :: ImportDeclarationType -> Either ErrorStack ImportEnvironment
+ resolveByType Unqualified = importAll importExplicit
+ resolveByType (Qualifying explImports) = (checkedRefs >=> foldM importExplicit imps) explImports
+ resolveByType (Hiding hiddenImports) = do
+ hiddenImports' <- checkedRefs hiddenImports
+ importAll (importNonHidden hiddenImports')
+
+ importNonHidden :: [DeclarationRef] -> ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment
+ importNonHidden hidden m ref =
+ if isHidden hidden ref
+ then return m
+ else importExplicit m ref
+
+ isHidden :: [DeclarationRef] -> DeclarationRef -> Bool
+ isHidden hidden ref@(TypeRef _ _) =
+ let
+ checkTypeRef _ True _ = True
+ checkTypeRef (TypeRef _ Nothing) acc (TypeRef _ (Just _)) = acc
+ checkTypeRef (TypeRef name (Just dctor)) _ (TypeRef name' (Just dctor')) = name == name' && dctor == dctor'
+ checkTypeRef (TypeRef name _) _ (TypeRef name' Nothing) = name == name'
+ checkTypeRef (PositionedDeclarationRef _ r) acc hiddenRef = checkTypeRef r acc hiddenRef
+ checkTypeRef _ acc _ = acc
+ in foldl (checkTypeRef ref) False hidden
+ isHidden hidden ref = ref `elem` hidden
+
+ -- Import all symbols
+ importAll :: (ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment) -> Either ErrorStack ImportEnvironment
+ importAll importer = do
+ imp' <- foldM (\m (name, dctors) -> importer m (TypeRef name (Just dctors))) imps (exportedTypes exps)
+ imp'' <- foldM (\m name -> importer m (ValueRef name)) imp' (exportedValues exps)
+ foldM (\m name -> importer m (TypeClassRef name)) imp'' (exportedTypeClasses exps)
-- Import something explicitly
importExplicit :: ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment
importExplicit imp (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ importExplicit imp r
importExplicit imp (ValueRef name) = do
- _ <- checkImportExists "value" values name
values' <- updateImports (importedValues imp) name
return $ imp { importedValues = values' }
importExplicit imp (TypeRef name dctors) = do
- _ <- checkImportExists "type" availableTypes name
types' <- updateImports (importedTypes imp) name
let allDctors = allExportedDataConstructors name
dctors' <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
dctors'' <- foldM updateImports (importedDataConstructors imp) dctors'
return $ imp { importedTypes = types', importedDataConstructors = dctors'' }
importExplicit imp (TypeClassRef name) = do
- _ <- checkImportExists "type class" classes name
typeClasses' <- updateImports (importedTypeClasses imp) name
return $ imp { importedTypeClasses = typeClasses' }
importExplicit _ _ = error "Invalid argument to importExplicit"
+ -- Check if DeclarationRef points to an existent symbol
+ checkedRefs :: [DeclarationRef] -> Either ErrorStack [DeclarationRef]
+ checkedRefs = mapM check
+ where
+ check (PositionedDeclarationRef pos r) =
+ rethrowWithPosition pos $ check r
+ check ref@(ValueRef name) =
+ checkImportExists "value" values name >> return ref
+ check ref@(TypeRef name dctors) = do
+ _ <- checkImportExists "type" availableTypes name
+ let allDctors = allExportedDataConstructors name
+ _ <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
+ return ref
+ check ref@(TypeClassRef name) =
+ checkImportExists "type class" classes name >> return ref
+ check _ = error "Invalid argument to checkRefIsValid"
+
-- Find all exported data constructors for a given type
allExportedDataConstructors :: ProperName -> [ProperName]
allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exps
@@ -444,7 +483,7 @@ resolveImport currentModule importModule exps imps impQual = maybe importAll (fo
Just x@(Qualified (Just mn) _) -> throwError $ mkErrorStack err Nothing
where
err = if mn == currentModule || importModule == currentModule
- then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just importModule) name) ++ "'"
+ then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just mn) name) ++ "'"
else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just importModule) name) ++ "'"
-- The available values, types, and classes in the module being imported
@@ -463,5 +502,3 @@ resolveImport currentModule importModule exps imps impQual = maybe importAll (fo
if item `elem` exports
then return item
else throwError $ mkErrorStack ("Cannot import unknown " ++ t ++ " '" ++ show item ++ "' from '" ++ show importModule ++ "'") Nothing
-
-
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index d53cc26..7ecf7af 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -63,7 +63,7 @@ removeSignedLiterals (Module mn ds exts) = Module mn (map f' ds) exts
go (UnaryMinus val) = App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.negate))) val
go other = other
-rebracketModule :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Module -> Either ErrorStack Module
+rebracketModule :: [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> Either ErrorStack Module
rebracketModule opTable (Module mn ds exts) =
let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return
in Module mn <$> (map removeParens <$> mapM f ds) <*> pure exts
@@ -95,7 +95,7 @@ ensureNoDuplicates m = go $ sortBy (compare `on` fst) m
throwError $ mkErrorStack ("Redefined fixity for " ++ show name) Nothing
go (_ : rest) = go rest
-customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]]
+customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]]
customOperatorTable fixities =
let
applyUserOp ident t1 = App (App (Var ident) t1)
@@ -105,18 +105,18 @@ customOperatorTable fixities =
in
map (map (\(name, f, _, a) -> (name, f, a))) groups
-type Chain = [Either Value (Qualified Ident)]
+type Chain = [Either Expr (Qualified Ident)]
-matchOperators :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either ErrorStack Value
+matchOperators :: [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Expr -> Either ErrorStack Expr
matchOperators ops = parseChains
where
- parseChains :: Value -> Either ErrorStack Value
+ parseChains :: Expr -> Either ErrorStack Expr
parseChains b@BinaryNoParens{} = bracketChain (extendChain b)
parseChains other = return other
- extendChain :: Value -> Chain
+ extendChain :: Expr -> Chain
extendChain (BinaryNoParens name l r) = Left l : Right name : extendChain r
extendChain other = [Left other]
- bracketChain :: Chain -> Either ErrorStack Value
+ bracketChain :: Chain -> Either ErrorStack Expr
bracketChain = either (Left . (`mkErrorStack` Nothing) . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"
opTable = [P.Infix (P.try (parseTicks >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft]
: map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops
@@ -130,7 +130,7 @@ toAssoc Infix = P.AssocNone
token :: (P.Stream s Identity t, Show t) => (t -> Maybe a) -> P.Parsec s u a
token = P.token show (const (P.initialPos ""))
-parseValue :: P.Parsec Chain () Value
+parseValue :: P.Parsec Chain () Expr
parseValue = token (either Just (const Nothing)) P.<?> "expression"
parseOp :: P.Parsec Chain () (Qualified Ident)
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index b34425d..2218936 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -239,7 +239,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
-- must be guarded by at least one function abstraction. For that reason, if the dictionary has no
-- dependencies, we introduce an unnamed function parameter.
let superclasses =
- [ (fieldName, Abs (Left (Ident "_")) (SuperClassDictionary superclass tyArgs))
+ [ (fieldName, Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs))
| (index, (superclass, suTyArgs)) <- zip [0..] implies
, let tyArgs = map (replaceAllTypeVars (zip args tys)) suTyArgs
, let fieldName = mkSuperclassDictionaryName superclass index
@@ -249,7 +249,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
dictTy = foldl TypeApp (TypeConstructor className) tys
constrainedTy = quantify (if null deps then function unit dictTy else ConstrainedType deps dictTy)
dict = TypeClassDictionaryConstructorApp className memberNames'
- dict' = if null deps then Abs (Left (Ident "_")) dict else dict
+ dict' = if null deps then Abs (Left (Ident C.__unused)) dict else dict
result = ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict' constrainedTy)
return result
@@ -261,7 +261,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
declName (TypeDeclaration ident _) = Just ident
declName _ = Nothing
- memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Value)
+ memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Expr)
memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do
_ <- lift . lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'
let memberValue = typeInstanceDictionaryEntryValue d
@@ -271,7 +271,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
return (ident, PositionedValue pos val)
memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"
- typeInstanceDictionaryEntryValue :: Declaration -> Value
+ typeInstanceDictionaryEntryValue :: Declaration -> Expr
typeInstanceDictionaryEntryValue (ValueDeclaration _ _ [] _ val) = val
typeInstanceDictionaryEntryValue (PositionedDeclaration pos d) = PositionedValue pos (typeInstanceDictionaryEntryValue d)
typeInstanceDictionaryEntryValue _ = error "Invalid declaration in type instance definition"
diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs
index 9ffb69e..c4e3825 100644
--- a/src/Language/PureScript/Sugar/TypeDeclarations.hs
+++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs
@@ -49,7 +49,7 @@ desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do
(_, nameKind, val) <- fromValueDeclaration d
desugarTypeDeclarations (ValueDeclaration name nameKind [] Nothing (TypedValue True val ty) : rest)
where
- fromValueDeclaration :: Declaration -> Either ErrorStack (Ident, NameKind, Value)
+ fromValueDeclaration :: Declaration -> Either ErrorStack (Ident, NameKind, Expr)
fromValueDeclaration (ValueDeclaration name' nameKind [] Nothing val) | name == name' = return (name', nameKind, val)
fromValueDeclaration (PositionedDeclaration pos d') = do
(ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 78a4d0b..bfbe16a 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -168,7 +168,7 @@ unifyRows r1 r2 =
-- Infer the types of multiple mutually-recursive values, and return elaborated values including
-- type class dictionaries and type annotations.
--
-typesOf :: Maybe ModuleName -> ModuleName -> [(Ident, Value)] -> Check [(Ident, (Value, Type))]
+typesOf :: Maybe ModuleName -> ModuleName -> [(Ident, Expr)] -> Check [(Ident, (Expr, Type))]
typesOf mainModuleName moduleName vals = do
tys <- fmap tidyUp . liftUnify $ do
(es, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals
@@ -194,7 +194,7 @@ typesOf mainModuleName moduleName vals = do
-- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts
-typeDictionaryForBindingGroup :: ModuleName -> [(Ident, Value)] -> UnifyT Type Check ([(Ident, (Value, Maybe (Type, Bool)))], M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility), [(Ident, Type)])
+typeDictionaryForBindingGroup :: ModuleName -> [(Ident, Expr)] -> UnifyT Type Check ([(Ident, (Expr, Maybe (Type, Bool)))], M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility), [(Ident, Type)])
typeDictionaryForBindingGroup moduleName vals = do
let
-- Map each declaration to a name/value pair, with an optional type, if the declaration is typed
@@ -215,7 +215,7 @@ typeDictionaryForBindingGroup moduleName vals = do
dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable, Undefined))) $ typedDict ++ untypedDict)
return (es, dict, untypedDict)
-typeForBindingGroupElement :: ModuleName -> (Ident, (Value, Maybe (Type, Bool))) -> M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> [(Ident, Type)] -> UnifyT Type Check (Ident, (Value, Type))
+typeForBindingGroupElement :: ModuleName -> (Ident, (Expr, Maybe (Type, Bool))) -> M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> [(Ident, Type)] -> UnifyT Type Check (Ident, (Expr, Type))
typeForBindingGroupElement moduleName el dict untypedDict =
-- If the declaration is a function, it has access to other values in the binding group.
-- If not, the generated code might fail at runtime since those values might be undefined.
@@ -241,17 +241,17 @@ typeForBindingGroupElement moduleName el dict untypedDict =
-- |
-- Check if a value contains a type annotation
--
-isTyped :: (Ident, Value) -> (Ident, (Value, Maybe (Type, Bool)))
+isTyped :: (Ident, Expr) -> (Ident, (Expr, Maybe (Type, Bool)))
isTyped (name, TypedValue checkType value ty) = (name, (value, Just (ty, checkType)))
isTyped (name, value) = (name, (value, Nothing))
-- |
-- Map a function over type annotations appearing inside a value
--
-overTypes :: (Type -> Type) -> Value -> Value
+overTypes :: (Type -> Type) -> Expr -> Expr
overTypes f = let (_, f', _) = everywhereOnValues id g id in f'
where
- g :: Value -> Value
+ g :: Expr -> Expr
g (TypedValue checkTy val t) = TypedValue checkTy val (f t)
g (TypeClassDictionary b (nm, tys) sco) = TypeClassDictionary b (nm, map f tys) sco
g other = other
@@ -259,7 +259,7 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f'
-- |
-- Replace type class dictionary placeholders with inferred type class dictionaries
--
-replaceTypeClassDictionaries :: ModuleName -> Value -> Check Value
+replaceTypeClassDictionaries :: ModuleName -> Expr -> Check Expr
replaceTypeClassDictionaries mn =
let (_, f, _) = everywhereOnValuesTopDownM return go return
in f
@@ -296,7 +296,7 @@ data DictionaryValue
-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
-- return a type class dictionary reference.
--
-entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Bool -> Check Value
+entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Bool -> Check Expr
entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filter filterModule context))
where
sortedNubBy :: (Ord k) => (v -> k) -> [v] -> [v]
@@ -354,8 +354,8 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
mkDictionary fnName Nothing = LocalDictionaryValue fnName
mkDictionary fnName (Just []) = GlobalDictionaryValue fnName
mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts
- -- Turn a DictionaryValue into a Value
- dictionaryValueToValue :: DictionaryValue -> Value
+ -- Turn a DictionaryValue into a Expr
+ dictionaryValueToValue :: DictionaryValue -> Expr
dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName
dictionaryValueToValue (GlobalDictionaryValue fnName) = App (Var fnName) (ObjectLiteral [])
dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)
@@ -434,7 +434,7 @@ typeHeadsAreEqual _ _ _ _ = Nothing
-- |
-- Ensure skolem variables do not escape their scope
--
-skolemEscapeCheck :: Value -> Check ()
+skolemEscapeCheck :: Expr -> Check ()
skolemEscapeCheck (TypedValue False _ _) = return ()
skolemEscapeCheck root@TypedValue{} =
-- Every skolem variable is created when a ForAll type is skolemized.
@@ -446,11 +446,11 @@ skolemEscapeCheck root@TypedValue{} =
let (_, f, _, _, _) = everythingWithContextOnValues [] [] (++) def go def def def
in case f root of
[] -> return ()
- ((binding, val) : _) -> throwError $ mkErrorStack ("Rigid/skolem type variable " ++ maybe "" (("bound by " ++) . prettyPrintValue) binding ++ " has escaped.") (Just (ValueError val))
+ ((binding, val) : _) -> throwError $ mkErrorStack ("Rigid/skolem type variable " ++ maybe "" (("bound by " ++) . prettyPrintValue) binding ++ " has escaped.") (Just (ExprError val))
where
def s _ = (s, [])
- go :: [(SkolemScope, Value)] -> Value -> ([(SkolemScope, Value)], [(Maybe Value, Value)])
+ go :: [(SkolemScope, Expr)] -> Expr -> ([(SkolemScope, Expr)], [(Maybe Expr, Expr)])
go scos val@(TypedValue _ _ (ForAll _ _ (Just sco))) = ((sco, val) : scos, [])
go scos val@(TypedValue _ _ ty) = case collectSkolems ty \\ map fst scos of
(sco : _) -> (scos, [(findBindingScope sco, val)])
@@ -462,14 +462,14 @@ skolemEscapeCheck root@TypedValue{} =
collect (Skolem _ _ scope) = [scope]
collect _ = []
go scos _ = (scos, [])
- findBindingScope :: SkolemScope -> Maybe Value
+ findBindingScope :: SkolemScope -> Maybe Expr
findBindingScope sco =
let (_, f, _, _, _) = everythingOnValues mappend (const mempty) go' (const mempty) (const mempty) (const mempty)
in getFirst $ f root
where
go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = First (Just val)
go' _ = mempty
-skolemEscapeCheck val = throwError $ mkErrorStack "Untyped value passed to skolemEscapeCheck" (Just (ValueError val))
+skolemEscapeCheck val = throwError $ mkErrorStack "Untyped value passed to skolemEscapeCheck" (Just (ExprError val))
-- |
-- Ensure a row contains no duplicate labels
@@ -503,7 +503,7 @@ varIfUnknown ty =
-- This is necessary during type checking to avoid unifying a polymorphic type with a
-- unification variable.
--
-instantiatePolyTypeWithUnknowns :: Value -> Type -> UnifyT Type Check (Value, Type)
+instantiatePolyTypeWithUnknowns :: Expr -> Type -> UnifyT Type Check (Expr, Type)
instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do
ty' <- replaceVarWithUnknown ident ty
instantiatePolyTypeWithUnknowns val ty'
@@ -571,19 +571,19 @@ expandAllTypeSynonyms = everywhereOnTypesTopDownM go
-- |
-- Ensure a set of property names and value does not contain duplicate labels
--
-ensureNoDuplicateProperties :: (Error e, MonadError e m) => [(String, Value)] -> m ()
+ensureNoDuplicateProperties :: (Error e, MonadError e m) => [(String, Expr)] -> m ()
ensureNoDuplicateProperties ps = guardWith (strMsg "Duplicate property names") $ length (nub . map fst $ ps) == length ps
-- |
-- Infer a type for a value, rethrowing any error to provide a more useful error message
--
-infer :: Value -> UnifyT Type Check Value
-infer val = rethrow (mkErrorStack "Error inferring type of value" (Just (ValueError val)) <>) $ infer' val
+infer :: Expr -> UnifyT Type Check Expr
+infer val = rethrow (mkErrorStack "Error inferring type of value" (Just (ExprError val)) <>) $ infer' val
-- |
-- Infer a type for a value
--
-infer' :: Value -> UnifyT Type Check Value
+infer' :: Expr -> UnifyT Type Check Expr
infer' v@(NumericLiteral _) = return $ TypedValue True v tyNumber
infer' v@(StringLiteral _) = return $ TypedValue True v tyString
infer' v@(BooleanLiteral _) = return $ TypedValue True v tyBoolean
@@ -670,7 +670,7 @@ infer' (TypedValue checkType val ty) = do
infer' (PositionedValue pos val) = rethrowWithPosition pos $ infer' val
infer' _ = error "Invalid argument to infer"
-inferLetBinding :: [Declaration] -> [Declaration] -> Value -> (Value -> UnifyT Type Check Value) -> UnifyT Type Check ([Declaration], Value)
+inferLetBinding :: [Declaration] -> [Declaration] -> Expr -> (Expr -> UnifyT Type Check Expr) -> UnifyT Type Check ([Declaration], Expr)
inferLetBinding seen [] ret j = (,) seen <$> makeBindingGroupVisible (j ret)
inferLetBinding seen (ValueDeclaration ident nameKind [] Nothing tv@(TypedValue checkType val ty) : rest) ret j = do
Just moduleName <- checkCurrentModule <$> get
@@ -810,7 +810,7 @@ skolemize ident sko scope = replaceTypeVars ident (Skolem ident sko scope)
-- SuperClassDictionary placeholder. These type variables are somewhat unique since they are the
-- only example of scoped type variables.
--
-skolemizeTypesInValue :: String -> Int -> SkolemScope -> Value -> Value
+skolemizeTypesInValue :: String -> Int -> SkolemScope -> Expr -> Expr
skolemizeTypesInValue ident sko scope = let (_, f, _) = everywhereOnValues id go id in f
where
go (SuperClassDictionary c ts) = SuperClassDictionary c (map (skolemize ident sko scope) ts)
@@ -828,8 +828,8 @@ introduceSkolemScope = everywhereOnTypesM go
-- |
-- Check the type of a value, rethrowing errors to provide a better error message
--
-check :: Value -> Type -> UnifyT Type Check Value
-check val ty = rethrow (mkErrorStack errorMessage (Just (ValueError val)) <>) $ check' val ty
+check :: Expr -> Type -> UnifyT Type Check Expr
+check val ty = rethrow (mkErrorStack errorMessage (Just (ExprError val)) <>) $ check' val ty
where
errorMessage =
"Error checking type of term " ++
@@ -840,7 +840,7 @@ check val ty = rethrow (mkErrorStack errorMessage (Just (ValueError val)) <>) $
-- |
-- Check the type of a value
--
-check' :: Value -> Type -> UnifyT Type Check Value
+check' :: Expr -> Type -> UnifyT Type Check Expr
check' val (ForAll ident ty _) = do
scope <- newSkolemScope
sko <- newSkolemConstant
@@ -911,12 +911,13 @@ check' (TypedValue checkType val ty1) ty2 = do
kind <- liftCheck $ kindOf moduleName ty1
guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
- val' <- subsumes (Just val) ty1' ty2
+ ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty2
+ val' <- subsumes (Just val) ty1' ty2'
case val' of
Nothing -> throwError . strMsg $ "Unable to check type subsumption"
Just val'' -> do
- val''' <- if checkType then check val'' ty1' else return val''
- return $ TypedValue checkType (TypedValue True val''' ty1) ty2
+ val''' <- if checkType then check val'' ty2' else return val''
+ return $ TypedValue checkType (TypedValue True val''' ty1') ty2'
check' (Case vals binders) ret = do
vals' <- mapM infer vals
let ts = map (\(TypedValue _ _ t) -> t) vals'
@@ -963,7 +964,7 @@ check' val ty | containsTypeSynonyms ty = do
check val ty'
check' (PositionedValue pos val) ty =
rethrowWithPosition pos $ check val ty
-check' val ty = throwError $ mkErrorStack ("Value does not have type " ++ prettyPrintType ty) (Just (ValueError val))
+check' val ty = throwError $ mkErrorStack ("Expr does not have type " ++ prettyPrintType ty) (Just (ExprError val))
containsTypeSynonyms :: Type -> Bool
containsTypeSynonyms = everythingOnTypes (||) go where
@@ -975,15 +976,15 @@ containsTypeSynonyms = everythingOnTypes (||) go where
--
-- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.
--
-checkProperties :: [(String, Value)] -> Type -> Bool -> UnifyT Type Check [(String, Value)]
+checkProperties :: [(String, Expr)] -> Type -> Bool -> UnifyT Type Check [(String, Expr)]
checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
go [] [] REmpty = return []
go [] [] u@(TUnknown _) = do u =?= REmpty
return []
go [] [] (Skolem _ _ _) | lax = return []
go [] ((p, _): _) _ | lax = return []
- | otherwise = throwError $ mkErrorStack ("Object does not have property " ++ p) (Just (ValueError (ObjectLiteral ps)))
- go ((p,_):_) [] REmpty = throwError $ mkErrorStack ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ValueError (ObjectLiteral ps)))
+ | otherwise = throwError $ mkErrorStack ("Object does not have property " ++ p) (Just (ExprError (ObjectLiteral ps)))
+ go ((p,_):_) [] REmpty = throwError $ mkErrorStack ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ExprError (ObjectLiteral ps)))
go ((p,v):ps') [] u@(TUnknown _) = do
v'@(TypedValue _ _ ty) <- infer v
rest <- fresh
@@ -1002,13 +1003,13 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
v' <- check v ty
ps'' <- go ps' (delete (p, ty) ts) r
return $ (p, v') : ps''
- go _ _ _ = throwError $ mkErrorStack ("Object does not have type " ++ prettyPrintType (TypeApp tyObject row)) (Just (ValueError (ObjectLiteral ps)))
+ go _ _ _ = throwError $ mkErrorStack ("Object does not have type " ++ prettyPrintType (TypeApp tyObject row)) (Just (ExprError (ObjectLiteral ps)))
-- |
-- Check the type of a function application, rethrowing errors to provide a better error message
--
-checkFunctionApplication :: Value -> Type -> Value -> Maybe Type -> UnifyT Type Check (Type, Value)
-checkFunctionApplication fn fnTy arg ret = rethrow (mkErrorStack errorMessage (Just (ValueError fn)) <>) $ do
+checkFunctionApplication :: Expr -> Type -> Expr -> Maybe Type -> UnifyT Type Check (Type, Expr)
+checkFunctionApplication fn fnTy arg ret = rethrow (mkErrorStack errorMessage (Just (ExprError fn)) <>) $ do
subst <- unifyCurrentSubstitution <$> UnifyT get
checkFunctionApplication' fn (subst $? fnTy) arg (($?) subst <$> ret)
where
@@ -1019,7 +1020,7 @@ checkFunctionApplication fn fnTy arg ret = rethrow (mkErrorStack errorMessage (J
-- |
-- Check the type of a function application
--
-checkFunctionApplication' :: Value -> Type -> Value -> Maybe Type -> UnifyT Type Check (Type, Value)
+checkFunctionApplication' :: Expr -> Type -> Expr -> Maybe Type -> UnifyT Type Check (Type, Expr)
checkFunctionApplication' fn (TypeApp (TypeApp tyFunction' argTy) retTy) arg ret = do
tyFunction' =?= tyFunction
arg' <- check arg argTy
@@ -1046,6 +1047,8 @@ checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg ret = do
checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do
dicts <- getTypeClassDictionaries
checkFunctionApplication' (foldl App fn (map (flip (TypeClassDictionary True) dicts) constraints)) fnTy arg ret
+checkFunctionApplication' fn fnTy dict@(TypeClassDictionary _ _ _) _ =
+ return (fnTy, App fn dict)
checkFunctionApplication' _ fnTy arg _ = throwError . strMsg $ "Cannot apply a function of type "
++ prettyPrintType fnTy
++ " to argument " ++ prettyPrintValue arg
@@ -1053,8 +1056,8 @@ checkFunctionApplication' _ fnTy arg _ = throwError . strMsg $ "Cannot apply a f
-- |
-- Check whether one type subsumes another, rethrowing errors to provide a better error message
--
-subsumes :: Maybe Value -> Type -> Type -> UnifyT Type Check (Maybe Value)
-subsumes val ty1 ty2 = rethrow (mkErrorStack errorMessage (ValueError <$> val) <>) $ subsumes' val ty1 ty2
+subsumes :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr)
+subsumes val ty1 ty2 = rethrow (mkErrorStack errorMessage (ExprError <$> val) <>) $ subsumes' val ty1 ty2
where
errorMessage = "Error checking that type "
++ prettyPrintType ty1
@@ -1064,7 +1067,7 @@ subsumes val ty1 ty2 = rethrow (mkErrorStack errorMessage (ValueError <$> val) <
-- |
-- Check whether one type subsumes another
--
-subsumes' :: Maybe Value -> Type -> Type -> UnifyT Type Check (Maybe Value)
+subsumes' :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr)
subsumes' val (ForAll ident ty1 _) ty2 = do
replaced <- replaceVarWithUnknown ident ty1
subsumes val replaced ty2