summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2016-11-08 18:03:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-11-08 18:03:00 (GMT)
commitab4b395c66e5fb609628ec32fc9142fafc083207 (patch)
tree432c87153702073fdac385e799131906faabc4b0
parente5b503a26b0ba5a50755c25430e73c644877fdbe (diff)
version 0.10.20.10.2
-rw-r--r--CONTRIBUTORS.md3
-rw-r--r--examples/failing/2378.purs6
-rw-r--r--examples/failing/2378/Lib.purs3
-rw-r--r--examples/failing/2379.purs6
-rw-r--r--examples/failing/2379/Lib.purs9
-rw-r--r--examples/failing/ConstraintFailure.purs13
-rw-r--r--examples/failing/ConstraintInference.purs2
-rw-r--r--examples/failing/NonWildcardNewtypeInstance.purs2
-rw-r--r--examples/passing/2378.purs9
-rw-r--r--examples/passing/DctorName.purs33
-rw-r--r--examples/passing/GHCGenerics.purs140
-rw-r--r--examples/passing/GenericsRep.purs53
-rw-r--r--examples/passing/RowsInInstanceContext.purs25
-rw-r--r--examples/warning/2383.purs12
-rw-r--r--examples/warning/2411.purs15
-rw-r--r--hierarchy/Main.hs4
-rw-r--r--psc-docs/Main.hs13
-rw-r--r--psc-package/Main.hs259
-rw-r--r--psc/Main.hs7
-rw-r--r--psci/Main.hs51
-rw-r--r--purescript.cabal31
-rw-r--r--src/Control/Monad/Supply.hs3
-rw-r--r--src/Control/Monad/Supply/Class.hs16
-rw-r--r--src/Language/PureScript/AST/Declarations.hs40
-rw-r--r--src/Language/PureScript/AST/Traversals.hs17
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs16
-rw-r--r--src/Language/PureScript/CodeGen/JS/Common.hs7
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs36
-rw-r--r--src/Language/PureScript/Constants.hs16
-rw-r--r--src/Language/PureScript/Docs/ParseAndBookmark.hs13
-rw-r--r--src/Language/PureScript/Environment.hs9
-rw-r--r--src/Language/PureScript/Errors.hs80
-rw-r--r--src/Language/PureScript/Ide/CaseSplit.hs12
-rw-r--r--src/Language/PureScript/Ide/Command.hs3
-rw-r--r--src/Language/PureScript/Ide/Conversions.hs12
-rw-r--r--src/Language/PureScript/Ide/Error.hs6
-rw-r--r--src/Language/PureScript/Ide/Externs.hs57
-rw-r--r--src/Language/PureScript/Ide/Filter.hs7
-rw-r--r--src/Language/PureScript/Ide/Imports.hs55
-rw-r--r--src/Language/PureScript/Ide/Matcher.hs2
-rw-r--r--src/Language/PureScript/Ide/Pursuit.hs46
-rw-r--r--src/Language/PureScript/Ide/Rebuild.hs6
-rw-r--r--src/Language/PureScript/Ide/Reexports.hs29
-rw-r--r--src/Language/PureScript/Ide/SourceFile.hs14
-rw-r--r--src/Language/PureScript/Ide/State.hs82
-rw-r--r--src/Language/PureScript/Ide/Types.hs93
-rw-r--r--src/Language/PureScript/Ide/Util.hs50
-rw-r--r--src/Language/PureScript/Interactive.hs2
-rw-r--r--src/Language/PureScript/Interactive/Completion.hs1
-rw-r--r--src/Language/PureScript/Interactive/Directive.hs3
-rw-r--r--src/Language/PureScript/Interactive/IO.hs11
-rw-r--r--src/Language/PureScript/Interactive/Message.hs6
-rw-r--r--src/Language/PureScript/Interactive/Module.hs6
-rw-r--r--src/Language/PureScript/Interactive/Parser.hs1
-rw-r--r--src/Language/PureScript/Interactive/Types.hs43
-rw-r--r--src/Language/PureScript/Linter/Imports.hs2
-rw-r--r--src/Language/PureScript/Make.hs2
-rw-r--r--src/Language/PureScript/Parser/Common.hs19
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs15
-rw-r--r--src/Language/PureScript/Parser/Lexer.hs53
-rw-r--r--src/Language/PureScript/Pretty/Types.hs69
-rwxr-xr-xsrc/Language/PureScript/Sugar/TypeClasses/Deriving.hs205
-rw-r--r--src/Language/PureScript/TypeChecker.hs4
-rw-r--r--src/Language/PureScript/TypeChecker/Entailment.hs63
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs6
-rw-r--r--src/Language/PureScript/TypeChecker/Subsumption.hs168
-rw-r--r--src/Language/PureScript/TypeChecker/TypeSearch.hs94
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs110
-rw-r--r--src/System/IO/UTF8.hs14
-rw-r--r--stack.yaml11
-rw-r--r--tests/Language/PureScript/Ide/FilterSpec.hs2
-rw-r--r--tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs8
-rw-r--r--tests/Language/PureScript/Ide/ImportsSpec.hs55
-rw-r--r--tests/Language/PureScript/Ide/MatcherSpec.hs2
-rw-r--r--tests/Language/PureScript/Ide/ReexportsSpec.hs10
-rw-r--r--tests/Language/PureScript/Ide/StateSpec.hs12
-rw-r--r--tests/TestCompiler.hs5
-rw-r--r--tests/TestUtils.hs32
-rw-r--r--tests/support/bower.json3
79 files changed, 1702 insertions, 758 deletions
diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md
index 5f0f220..ae69642 100644
--- a/CONTRIBUTORS.md
+++ b/CONTRIBUTORS.md
@@ -63,6 +63,7 @@ This file lists the contributors to the PureScript compiler project, and the ter
- [@paulyoung](https://github.com/paulyoung) (Paul Young) My existing contributions and all future contributions until further notice are Copyright Paul Young, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@pelotom](https://github.com/pelotom) (Thomas Crockett) My existing contributions and all future contributions until further notice are Copyright Thomas Crockett, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@phadej](https://github.com/phadej) (Oleg Grenrus) My existing contributions and all future contributions until further notice are Copyright Oleg Grenrus, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@phiggins](https://github.com/phiggins) (Pete Higgins) My existing contributions and all future contributions until further notice are Copyright Pete Higgins, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@philopon](https://github.com/philopon) (Hirotomo Moriwaki) - My existing contributions and all future contributions until further notice are Copyright Hirotomo Moriwaki, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@pseudonom](https://github.com/pseudonom) (Eric Easley) My existing contributions and all future contributions until further notice are Copyright Eric Easley, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@puffnfresh](https://github.com/puffnfresh) (Brian McKenna) All contributions I made during June 2015 were during employment at [SlamData, Inc.](#companies) who owns the copyright. I assign copyright of all my personal contributions before June 2015 to the owners of the PureScript compiler.
@@ -81,6 +82,8 @@ This file lists the contributors to the PureScript compiler project, and the ter
- [@utkarshkukreti](https://github.com/utkarshkukreti) (Utkarsh Kukreti) My existing contributions and all future contributions until further notice are Copyright Utkarsh Kukreti, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@vkorablin](https://github.com/vkorablin) (Vladimir Korablin) - My existing contributions and all future contributions until further notice are Copyright Vladimir Korablin, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
- [@zudov](https://github.com/zudov) (Konstantin Zudov) My existing contributions and all future contributions until further notice are Copyright Konstantin Zudov, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@brandonhamilton](https://github.com/brandonhamilton) (Brandon Hamilton) My existing contributions and all future contributions until further notice are Copyright Brandon Hamilton, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@bbqbaron](https://github.com/bbqbaron) (Eric Loren) My existing contributions and all future contributions until further notice are Copyright Eric Loren, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
### Companies
diff --git a/examples/failing/2378.purs b/examples/failing/2378.purs
new file mode 100644
index 0000000..59de79c
--- /dev/null
+++ b/examples/failing/2378.purs
@@ -0,0 +1,6 @@
+-- @shouldFailWith OrphanInstance
+module Main where
+
+import Lib
+
+instance fooX :: Foo "x"
diff --git a/examples/failing/2378/Lib.purs b/examples/failing/2378/Lib.purs
new file mode 100644
index 0000000..8890d66
--- /dev/null
+++ b/examples/failing/2378/Lib.purs
@@ -0,0 +1,3 @@
+module Lib (class Foo) where
+
+class Foo (a :: Symbol)
diff --git a/examples/failing/2379.purs b/examples/failing/2379.purs
new file mode 100644
index 0000000..f124dd3
--- /dev/null
+++ b/examples/failing/2379.purs
@@ -0,0 +1,6 @@
+-- @shouldFailWith UnknownClass
+module Main where
+
+import Lib
+
+test = x [1, 2, 3]
diff --git a/examples/failing/2379/Lib.purs b/examples/failing/2379/Lib.purs
new file mode 100644
index 0000000..eb69e86
--- /dev/null
+++ b/examples/failing/2379/Lib.purs
@@ -0,0 +1,9 @@
+module Lib (class X, x) where
+
+class X a where
+ x :: a -> String
+
+class Y a
+
+instance xArray :: Y a => X (Array a) where
+ x _ = "[]"
diff --git a/examples/failing/ConstraintFailure.purs b/examples/failing/ConstraintFailure.purs
new file mode 100644
index 0000000..b24cb58
--- /dev/null
+++ b/examples/failing/ConstraintFailure.purs
@@ -0,0 +1,13 @@
+-- @shouldFailWith NoInstanceFound
+
+module Main where
+
+import Prelude
+
+data Foo = Bar
+
+spin :: forall a. a -> Foo
+spin x = Bar
+
+main = show <<< spin
+
diff --git a/examples/failing/ConstraintInference.purs b/examples/failing/ConstraintInference.purs
index f451fa0..ef68dbb 100644
--- a/examples/failing/ConstraintInference.purs
+++ b/examples/failing/ConstraintInference.purs
@@ -1,4 +1,4 @@
--- @shouldFailWith NoInstanceFound
+-- @shouldFailWith AmbiguousTypeVariables
module Main where
diff --git a/examples/failing/NonWildcardNewtypeInstance.purs b/examples/failing/NonWildcardNewtypeInstance.purs
index 3c8f947..3c1ac5d 100644
--- a/examples/failing/NonWildcardNewtypeInstance.purs
+++ b/examples/failing/NonWildcardNewtypeInstance.purs
@@ -1,4 +1,4 @@
--- @shouldFailWith NonWildcardNewtypeInstance
+-- @shouldFailWith ExpectedWildcard
module NonWildcardNewtypeInstance where
import Data.Newtype
diff --git a/examples/passing/2378.purs b/examples/passing/2378.purs
new file mode 100644
index 0000000..75ada8c
--- /dev/null
+++ b/examples/passing/2378.purs
@@ -0,0 +1,9 @@
+module Main where
+
+import Control.Monad.Eff.Console (log)
+
+class Foo (a :: Symbol)
+
+instance fooX :: Foo "x"
+
+main = log "Done"
diff --git a/examples/passing/DctorName.purs b/examples/passing/DctorName.purs
new file mode 100644
index 0000000..05d4f8d
--- /dev/null
+++ b/examples/passing/DctorName.purs
@@ -0,0 +1,33 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console (log)
+
+newtype Bar' = Bar' Int
+
+data Foo' = Foo' Bar'
+
+data Baz'' = Baz'' | Baz'
+
+f ∷ Foo' → Boolean
+f a = case a of Foo' b → true
+
+f' ∷ Boolean
+f' = f $ Foo' $ Bar' 0
+
+g ∷ Baz'' → Int
+g Baz'' = 0
+g Baz' = 1
+
+g' ∷ Int
+g' = g Baz''
+
+h ∷ Bar' → Int
+h (Bar' x)
+ | x <= 10 = x * 2
+ | otherwise = 10
+
+h' ∷ Int
+h' = h $ Bar' 4
+
+main = log "Done" \ No newline at end of file
diff --git a/examples/passing/GHCGenerics.purs b/examples/passing/GHCGenerics.purs
deleted file mode 100644
index d3f0abe..0000000
--- a/examples/passing/GHCGenerics.purs
+++ /dev/null
@@ -1,140 +0,0 @@
--- An example to show how we could implement GHC-style Generics using
--- functional dependencies.
---
--- See https://hackage.haskell.org/package/base-4.9.0.0/docs/GHC-Generics.html
-
-module Main where
-
-import Prelude
-import Control.Monad.Eff (Eff)
-import Control.Monad.Eff.Console (CONSOLE, log, logShow)
-
--- Representation for types with no constructors
-data V1
-
--- Representation for constructors with no arguments
-data U1 = U1
-
--- Representation for sum types
-data Sum a b = Inl a | Inr b
-
-infixr 5 type Sum as +
-
--- Representation for product types
-data Product a b = Product a b
-
-infixr 6 type Product as *
-
--- Representation for data constructors, with the data constructor name indicated
--- at the type level.
-data Ctor (name :: Symbol) a = Ctor a
-
--- Representation for occurrences of other types in a data type definition.
-data K a = K a
-
--- The Generic class asserts the existence of a type function from "real" types
--- to representation types, and an isomorphism between them.
-class Generic a repr | a -> repr where
- to :: a -> repr
- from :: repr -> a
-
--- We can write an instance for the (recursive) type of lists. Note that these
--- instances would be generated by the compiler ideally.
-data List a = Nil | Cons a (List a)
-
-instance genericList :: Generic (List a) (Ctor "Nil" U1 + Ctor "Cons" (K a * K (List a))) where
- to Nil = Inl (Ctor U1)
- to (Cons x xs) = Inr (Ctor (Product (K x) (K xs)))
- from (Inl (Ctor U1)) = Nil
- from (Inr (Ctor (Product (K x) (K xs)))) = Cons x xs
-
--- We'd like to refect type level strings (for data constructor names) at the value
--- level, so that we can "show" them. Again, these instances would ideally be derived
--- for us.
-class KnownSymbol (sym :: Symbol) where
- symbol :: forall proxy. proxy sym -> String
-
-instance knownSymbolNil :: KnownSymbol "Nil" where
- symbol _ = "Nil"
-
-instance knownSymbolCons :: KnownSymbol "Cons" where
- symbol _ = "Cons"
-
--- A proxy for a type-level string.
-data SProxy (sym :: Symbol) = SProxy
-
--- To write generic functions, we create a corresponding type class, and use the
--- type class machinery to infer the correct function based on the representation
--- type.
-class GShow a where
- gShow :: a -> String
-
--- Now provide instances for GShow for the appropriate representation types.
--- Note: we don't have to implement all instances here.
-
-instance gShowU1 :: GShow U1 where
- gShow _ = ""
-
-instance gShowSum :: (GShow a, GShow b) => GShow (a + b) where
- gShow (Inl a) = gShow a
- gShow (Inr b) = gShow b
-
-instance gShowProduct :: (GShow a, GShow b) => GShow (a * b) where
- gShow (Product a b) = gShow a <> gShow b
-
-instance gShowCtor :: (KnownSymbol ctor, GShow a) => GShow (Ctor ctor a) where
- gShow (Ctor a) = "(" <> symbol (SProxy :: SProxy ctor) <> gShow a <> ")"
-
-instance gShowK :: Show a => GShow (K a) where
- gShow (K a) = " " <> show a
-
--- Now we can implement a generic show function which uses the GShow instance
--- on the representation type.
-genericShow :: forall a repr. (Generic a repr, GShow repr) => a -> String
-genericShow x = gShow (to x)
-
--- Note how the required instance here is Show a, and not Generic a.
--- This allows us to use generic programming on a wider variety of types
--- (including types which contain foreign types) than we can use now.
-instance showList :: Show a => Show (List a) where
- show xs = genericShow xs -- (we need to eta expand here to avoid stack overflow
- -- due to recursion implicit in the instance lookup)
-
--- Another example: Eq
-
-class GEq a where
- gEq :: a -> a -> Boolean
-
-instance gEqU1 :: GEq U1 where
- gEq _ _ = true
-
-instance gEqSum :: (GEq a, GEq b) => GEq (a + b) where
- gEq (Inl a1) (Inl a2) = gEq a1 a2
- gEq (Inr b1) (Inr b2) = gEq b1 b2
- gEq _ _ = false
-
-instance gEqProduct :: (GEq a, GEq b) => GEq (a * b) where
- gEq (Product a1 b1) (Product a2 b2) = gEq a1 a2 && gEq b1 b2
-
-instance gEqCtor :: (KnownSymbol ctor, GEq a) => GEq (Ctor ctor a) where
- gEq (Ctor a1) (Ctor a2) = gEq a1 a2
-
-instance gEqK :: Eq a => GEq (K a) where
- gEq (K a1) (K a2) = a1 == a2
-
-genericEq :: forall a repr. (Generic a repr, GEq repr) => a -> a -> Boolean
-genericEq x y = gEq (to x) (to y)
-
-instance eqList :: Eq a => Eq (List a) where
- eq xs ys = genericEq xs ys
-
-main :: Eff (console :: CONSOLE) Unit
-main = do
- logShow (Cons 1 Nil)
- logShow (Cons 1 (Cons 2 Nil))
- logShow (Cons 'x' (Cons 'y' (Cons 'z' Nil)))
-
- logShow (Cons 1 (Cons 2 Nil) == Cons 1 (Cons 2 Nil))
- logShow (Cons 1 (Cons 2 Nil) == Cons 1 Nil)
-
- log "Done"
diff --git a/examples/passing/GenericsRep.purs b/examples/passing/GenericsRep.purs
new file mode 100644
index 0000000..4f60106
--- /dev/null
+++ b/examples/passing/GenericsRep.purs
@@ -0,0 +1,53 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff (Eff)
+import Control.Monad.Eff.Console (CONSOLE, log, logShow)
+import Data.Generic.Rep (class Generic)
+import Data.Generic.Rep.Eq (genericEq)
+
+data X a = X a
+
+derive instance genericX :: Generic (X a) _
+
+instance eqX :: Eq a => Eq (X a) where
+ eq xs ys = genericEq xs ys
+
+data Y a = Y | Z a (Y a)
+
+derive instance genericY :: Generic (Y a) _
+
+instance eqY :: Eq a => Eq (Y a) where
+ eq xs ys = genericEq xs ys
+
+data Z
+
+derive instance genericZ :: Generic Z _
+
+instance eqZ :: Eq Z where
+ eq x y = genericEq x y
+
+newtype W = W { x :: Int, y :: String }
+
+derive instance genericW :: Generic W _
+
+instance eqW :: Eq W where
+ eq x y = genericEq x y
+
+data V = V { x :: Int } { x :: Int }
+
+derive instance genericV :: Generic V _
+
+instance eqV :: Eq V where
+ eq x y = genericEq x y
+
+main :: Eff (console :: CONSOLE) Unit
+main = do
+ logShow (X 0 == X 1)
+ logShow (X 1 == X 1)
+ logShow (Z 1 Y == Z 1 Y)
+ logShow (Z 1 Y == Y)
+ logShow (Y == Y :: Y Z)
+ logShow (W { x: 0, y: "A" } == W { x: 0, y: "A" })
+ logShow (V { x: 0 } { x: 0 } == V { x: 0 } { x: 0 })
+ log "Done"
diff --git a/examples/passing/RowsInInstanceContext.purs b/examples/passing/RowsInInstanceContext.purs
new file mode 100644
index 0000000..708d9d4
--- /dev/null
+++ b/examples/passing/RowsInInstanceContext.purs
@@ -0,0 +1,25 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff (Eff)
+import Control.Monad.Eff.Console (CONSOLE, log)
+import Data.Newtype (class Newtype, unwrap)
+
+class TypeEquals a b | a -> b, b -> a where
+ coerce :: a -> b
+ coerceBack :: b -> a
+
+instance refl :: TypeEquals a a where
+ coerce = id
+ coerceBack = id
+
+newtype RecordNewtype = RecordNewtype { x :: String }
+
+instance newtypeRecordNewtype ::
+ TypeEquals inner { x :: String }
+ => Newtype RecordNewtype inner where
+ wrap = RecordNewtype <<< coerce
+ unwrap (RecordNewtype rec) = coerceBack rec
+
+main :: Eff (console :: CONSOLE) Unit
+main = log (unwrap (RecordNewtype { x: "Done" })).x
diff --git a/examples/warning/2383.purs b/examples/warning/2383.purs
new file mode 100644
index 0000000..dfcb8eb
--- /dev/null
+++ b/examples/warning/2383.purs
@@ -0,0 +1,12 @@
+-- | This specifically shouldn't warn about `x` being shadowed in `main`
+-- | See https://github.com/purescript/purescript/issues/2383
+module Main where
+
+import Prelude
+
+import Control.Monad.Eff (Eff)
+
+main :: Eff () Unit
+main = do
+ x <- let x = pure unit in x
+ pure unit
diff --git a/examples/warning/2411.purs b/examples/warning/2411.purs
new file mode 100644
index 0000000..c53ca23
--- /dev/null
+++ b/examples/warning/2411.purs
@@ -0,0 +1,15 @@
+-- @shouldWarnWith ShadowedName
+module Main where
+
+import Prelude
+
+import Control.Monad.Eff (Eff)
+
+test :: forall m. Monad m => Int -> m Unit
+test x =
+ let x = unit
+ in pure x
+
+main :: Eff () Unit
+main = test 42
+
diff --git a/hierarchy/Main.hs b/hierarchy/Main.hs
index d40e661..291d4a3 100644
--- a/hierarchy/Main.hs
+++ b/hierarchy/Main.hs
@@ -33,7 +33,7 @@ import System.FilePath ((</>))
import System.FilePath.Glob (glob)
import System.Exit (exitFailure, exitSuccess)
import System.IO (hPutStr, stderr)
-import System.IO.UTF8 (readUTF8File)
+import System.IO.UTF8 (readUTF8FileT)
import qualified Language.PureScript as P
import qualified Paths_purescript as Paths
@@ -60,7 +60,7 @@ runModuleName (P.ModuleName pns) = intercalate "_" (P.runProperName `map` pns)
readInput :: [FilePath] -> IO (Either P.MultipleErrors [P.Module])
readInput paths = do
- content <- mapM (\path -> (path, ) <$> readUTF8File path) paths
+ content <- mapM (\path -> (path, ) <$> readUTF8FileT path) paths
return $ map snd <$> P.parseModulesFromFiles id content
compile :: HierarchyOptions -> IO ()
diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs
index 63d0f31..2f5abb4 100644
--- a/psc-docs/Main.hs
+++ b/psc-docs/Main.hs
@@ -7,6 +7,7 @@ import Control.Monad.Trans.Except (runExceptT)
import Control.Arrow (first, second)
import Control.Category ((>>>))
import Control.Monad.Writer
+import Data.Text (Text)
import Data.Function (on)
import Data.List
import Data.Maybe (fromMaybe)
@@ -20,7 +21,7 @@ import qualified Language.PureScript as P
import qualified Paths_purescript as Paths
import System.Exit (exitFailure)
import System.IO (hPutStrLn, hPrint, hSetEncoding, stderr, stdout, utf8)
-import System.IO.UTF8 (readUTF8File)
+import System.IO.UTF8 (readUTF8FileT)
import System.Directory (createDirectoryIfMissing)
import System.FilePath (takeDirectory)
import System.FilePath.Glob (glob)
@@ -139,8 +140,8 @@ dumpTags input renderTags = do
ldump :: [String] -> IO ()
ldump = mapM_ putStrLn
-parseFile :: FilePath -> IO (FilePath, String)
-parseFile input = (,) input <$> readUTF8File input
+parseFile :: FilePath -> IO (FilePath, Text)
+parseFile input = (,) input <$> readUTF8FileT input
inputFile :: Parser FilePath
inputFile = strArgument $
@@ -235,16 +236,16 @@ examples =
PP.vcat $ map PP.text
[ "Examples:"
, " print documentation for Data.List to stdout:"
- , " psc-docs \"src/**/*.purs\" \"bower_components/*/src/**/*.purs\" \\"
+ , " psc-docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\" \\"
, " --docgen Data.List"
, ""
, " write documentation for Data.List to docs/Data.List.md:"
- , " psc-docs \"src/**/*.purs\" \"bower_components/*/src/**/*.purs\" \\"
+ , " psc-docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\" \\"
, " --docgen Data.List:docs/Data.List.md"
, ""
, " write documentation for Data.List to docs/Data.List.md, and"
, " documentation for Data.List.Lazy to docs/Data.List.Lazy.md:"
- , " psc-docs \"src/**/*.purs\" \"bower_components/*/src/**/*.purs\" \\"
+ , " psc-docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\" \\"
, " --docgen Data.List:docs/Data.List.md \\"
, " --docgen Data.List.Lazy:docs/Data.List.Lazy.md"
]
diff --git a/psc-package/Main.hs b/psc-package/Main.hs
new file mode 100644
index 0000000..ef90ee1
--- /dev/null
+++ b/psc-package/Main.hs
@@ -0,0 +1,259 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TupleSections #-}
+
+module Main where
+
+import qualified Data.Aeson as Aeson
+import Data.Aeson.Encode.Pretty
+import Data.Foldable (fold, for_, traverse_)
+import Data.List (nub)
+import qualified Data.Map as Map
+import Data.Maybe (mapMaybe)
+import qualified Data.Set as Set
+import Data.Text (pack)
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Builder as TB
+import Data.Text.Encoding (encodeUtf8)
+import Data.Traversable (for)
+import Data.Version (showVersion)
+import qualified Filesystem.Path.CurrentOS as Path
+import GHC.Generics (Generic)
+import qualified Options.Applicative as Opts
+import qualified Paths_purescript as Paths
+import qualified System.IO as IO
+import Turtle hiding (fold)
+
+packageFile :: Path.FilePath
+packageFile = "psc-package.json"
+
+data PackageConfig = PackageConfig
+ { name :: Text
+ , depends :: [Text]
+ , set :: Text
+ , source :: Text
+ } deriving (Show, Generic, Aeson.FromJSON, Aeson.ToJSON)
+
+pathToTextUnsafe :: Turtle.FilePath -> Text
+pathToTextUnsafe = either (error "Path.toText failed") id . Path.toText
+
+defaultPackage :: Text -> PackageConfig
+defaultPackage pkgName =
+ PackageConfig { name = pkgName
+ , depends = [ "prelude" ]
+ , set = "psc-" <> pack (showVersion Paths.version)
+ , source = "https://github.com/purescript/package-sets.git"
+ }
+
+readPackageFile :: IO PackageConfig
+readPackageFile = do
+ exists <- testfile packageFile
+ unless exists $ do
+ echo "psc-package.json does not exist"
+ exit (ExitFailure 1)
+ mpkg <- Aeson.decodeStrict . encodeUtf8 <$> readTextFile packageFile
+ case mpkg of
+ Nothing -> do
+ echo "Unable to parse psc-package.json"
+ exit (ExitFailure 1)
+ Just pkg -> return pkg
+
+encodePrettyToText :: Aeson.ToJSON json => json -> Text
+encodePrettyToText =
+ TL.toStrict
+ . TB.toLazyText
+ . encodePrettyToTextBuilder' config
+ where
+ config = defConfig
+ { confCompare =
+ keyOrder [ "name"
+ , "set"
+ , "source"
+ , "depends"
+ ]
+ }
+
+writePackageFile :: PackageConfig -> IO ()
+writePackageFile =
+ writeTextFile packageFile
+ . encodePrettyToText
+
+data PackageInfo = PackageInfo
+ { repo :: Text
+ , version :: Text
+ , dependencies :: [Text]
+ } deriving (Show, Eq, Generic, Aeson.FromJSON, Aeson.ToJSON)
+
+type PackageSet = Map.Map Text PackageInfo
+
+cloneShallow
+ :: Text
+ -- ^ repo
+ -> Text
+ -- ^ branch/tag
+ -> Turtle.FilePath
+ -- ^ target directory
+ -> IO ExitCode
+cloneShallow from ref into =
+ proc "git"
+ [ "clone"
+ , "-q"
+ , "-c", "advice.detachedHead=false"
+ , "--depth", "1"
+ , "-b", ref
+ , from
+ , pathToTextUnsafe into
+ ] empty .||. exit (ExitFailure 1)
+
+getPackageSet :: PackageConfig -> IO ()
+getPackageSet PackageConfig{ source, set } = do
+ let pkgDir = ".psc-package" </> fromText set </> ".set"
+ exists <- testdir pkgDir
+ unless exists . void $ cloneShallow source set pkgDir
+
+readPackageSet :: PackageConfig -> IO PackageSet
+readPackageSet PackageConfig{ set } = do
+ let dbFile = ".psc-package" </> fromText set </> ".set" </> "packages.json"
+ exists <- testfile dbFile
+ unless exists $ do
+ echo "packages.json does not exist"
+ exit (ExitFailure 1)
+ mdb <- Aeson.decodeStrict . encodeUtf8 <$> readTextFile dbFile
+ case mdb of
+ Nothing -> do
+ echo "Unable to parse packages.json"
+ exit (ExitFailure 1)
+ Just db -> return db
+
+installOrUpdate :: PackageConfig -> Text -> PackageInfo -> IO ()
+installOrUpdate PackageConfig{ set } pkgName PackageInfo{ repo, version } = do
+ let pkgDir = ".psc-package" </> fromText set </> fromText pkgName </> fromText version
+ exists <- testdir pkgDir
+ unless exists . void $ cloneShallow repo version pkgDir
+
+getTransitiveDeps :: PackageSet -> [Text] -> IO [(Text, PackageInfo)]
+getTransitiveDeps db depends = do
+ pkgs <- for depends $ \pkg ->
+ case Map.lookup pkg db of
+ Nothing -> do
+ echo ("Package " <> pkg <> " does not exist in package set")
+ exit (ExitFailure 1)
+ Just PackageInfo{ dependencies } -> return (pkg : dependencies)
+ let unique = Set.toList (foldMap Set.fromList pkgs)
+ return (mapMaybe (\name -> fmap (name, ) (Map.lookup name db)) unique)
+
+updateImpl :: PackageConfig -> IO ()
+updateImpl config@PackageConfig{ depends } = do
+ getPackageSet config
+ db <- readPackageSet config
+ trans <- getTransitiveDeps db depends
+ echo ("Updating " <> pack (show (length trans)) <> " packages...")
+ for_ trans $ \(pkgName, pkg) -> do
+ echo ("Updating " <> pkgName)
+ installOrUpdate config pkgName pkg
+
+initialize :: IO ()
+initialize = do
+ exists <- testfile "psc-package.json"
+ when exists $ do
+ echo "psc-package.json already exists"
+ exit (ExitFailure 1)
+ echo "Initializing new project in current directory"
+ pkgName <- pathToTextUnsafe . Path.filename <$> pwd
+ let pkg = defaultPackage pkgName
+ writePackageFile pkg
+ updateImpl pkg
+
+update :: IO ()
+update = do
+ pkg <- readPackageFile
+ updateImpl pkg
+ echo "Update complete"
+
+install :: String -> IO ()
+install pkgName = do
+ pkg <- readPackageFile
+ let pkg' = pkg { depends = nub (pack pkgName : depends pkg) }
+ updateImpl pkg'
+ writePackageFile pkg'
+ echo "psc-package.json file was updated"
+
+listDependencies :: IO ()
+listDependencies = do
+ pkg@PackageConfig{ depends } <- readPackageFile
+ db <- readPackageSet pkg
+ trans <- getTransitiveDeps db depends
+ traverse_ (echo . fst) trans
+
+getSourcePaths :: PackageConfig -> PackageSet -> [Text] -> IO [Turtle.FilePath]
+getSourcePaths PackageConfig{..} db pkgNames = do
+ trans <- getTransitiveDeps db pkgNames
+ let paths = [ ".psc-package"
+ </> fromText set
+ </> fromText pkgName
+ </> fromText version
+ </> "src" </> "**" </> "*.purs"
+ | (pkgName, PackageInfo{ version }) <- trans
+ ]
+ return paths
+
+listSourcePaths :: IO ()
+listSourcePaths = do
+ pkg@PackageConfig{ depends } <- readPackageFile
+ db <- readPackageSet pkg
+ paths <- getSourcePaths pkg db depends
+ traverse_ (echo . pathToTextUnsafe) paths
+
+exec :: Text -> IO ()
+exec exeName = do
+ pkg@PackageConfig{..} <- readPackageFile
+ db <- readPackageSet pkg
+ paths <- getSourcePaths pkg db depends
+ procs exeName
+ (map pathToTextUnsafe ("src" </> "**" </> "*.purs" : paths))
+ empty
+
+main :: IO ()
+main = do
+ IO.hSetEncoding IO.stdout IO.utf8
+ IO.hSetEncoding IO.stderr IO.utf8
+ cmd <- Opts.execParser opts
+ cmd
+ where
+ opts = Opts.info (versionInfo <*> Opts.helper <*> commands) infoModList
+ infoModList = Opts.fullDesc <> headerInfo <> footerInfo
+ headerInfo = Opts.progDesc "Manage package dependencies"
+ footerInfo = Opts.footer $ "psc-package " ++ showVersion Paths.version
+
+ versionInfo :: Parser (a -> a)
+ versionInfo = Opts.abortOption (Opts.InfoMsg (showVersion Paths.version)) $
+ Opts.long "version" <> Opts.help "Show the version number" <> Opts.hidden
+
+ commands :: Parser (IO ())
+ commands = (Opts.subparser . fold)
+ [ Opts.command "init"
+ (Opts.info (pure initialize)
+ (Opts.progDesc "Initialize a new package"))
+ , Opts.command "update"
+ (Opts.info (pure update)
+ (Opts.progDesc "Update dependencies"))
+ , Opts.command "install"
+ (Opts.info (install <$> pkg)
+ (Opts.progDesc "Install the named package"))
+ , Opts.command "build"
+ (Opts.info (pure (exec "psc"))
+ (Opts.progDesc "Build the current package and dependencies"))
+ , Opts.command "dependencies"
+ (Opts.info (pure listDependencies)
+ (Opts.progDesc "List all (transitive) dependencies for the current package"))
+ , Opts.command "sources"
+ (Opts.info (pure listSourcePaths)
+ (Opts.progDesc "List all (active) source paths for dependencies"))
+ ]
+ where
+ pkg = Opts.strArgument $
+ Opts.metavar "PACKAGE"
+ <> Opts.help "The name of the package to install"
diff --git a/psc/Main.hs b/psc/Main.hs
index 47ae898..be42b3f 100644
--- a/psc/Main.hs
+++ b/psc/Main.hs
@@ -15,6 +15,7 @@ import Data.Bool (bool)
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.UTF8 as BU8
import qualified Data.Map as M
+import Data.Text (Text)
import Data.Version (showVersion)
import qualified Language.PureScript as P
@@ -29,7 +30,7 @@ import qualified System.Console.ANSI as ANSI
import System.Exit (exitSuccess, exitFailure)
import System.FilePath.Glob (glob)
import System.IO (hSetEncoding, hPutStrLn, stdout, stderr, utf8)
-import System.IO.UTF8
+import System.IO.UTF8 (readUTF8FileT)
data PSCMakeOptions = PSCMakeOptions
{ pscmInput :: [FilePath]
@@ -85,8 +86,8 @@ globWarningOnMisses warn = concatMapM globWithWarning
return paths
concatMapM f = fmap concat . mapM f
-readInput :: [FilePath] -> IO [(FilePath, String)]
-readInput inputFiles = forM inputFiles $ \inFile -> (inFile, ) <$> readUTF8File inFile
+readInput :: [FilePath] -> IO [(FilePath, Text)]
+readInput inputFiles = forM inputFiles $ \inFile -> (inFile, ) <$> readUTF8FileT inFile
inputFile :: Parser FilePath
inputFile = strArgument $
diff --git a/psci/Main.hs b/psci/Main.hs
index 9bd3096..e86f758 100644
--- a/psci/Main.hs
+++ b/psci/Main.hs
@@ -63,17 +63,10 @@ import System.Process (readProcessWithExitCode)
-- | Command line options
data PSCiOptions = PSCiOptions
- { psciMultiLineMode :: Bool
- , psciInputFile :: [FilePath]
+ { psciInputFile :: [FilePath]
, psciBackend :: Backend
}
-multiLineMode :: Opts.Parser Bool
-multiLineMode = Opts.switch $
- Opts.long "multi-line-mode"
- <> Opts.short 'm'
- <> Opts.help "Run in multi-line mode (use ^D to terminate commands)"
-
inputFile :: Opts.Parser FilePath
inputFile = Opts.strArgument $
Opts.metavar "FILE"
@@ -100,8 +93,7 @@ backend =
<|> (nodeBackend <$> nodeFlagsFlag)
psciOptions :: Opts.Parser PSCiOptions
-psciOptions = PSCiOptions <$> multiLineMode
- <*> many inputFile
+psciOptions = PSCiOptions <$> many inputFile
<*> backend
version :: Opts.Parser (a -> a)
@@ -119,17 +111,20 @@ getOpt = Opts.execParser opts
footerInfo = Opts.footer $ "psci " ++ showVersion Paths.version
-- | Parses the input and returns either a command, or an error as a 'String'.
-getCommand :: forall m. MonadException m => Bool -> InputT m (Either String (Maybe Command))
-getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do
- firstLine <- withInterrupt $ getInputLine "> "
- case firstLine of
+getCommand :: forall m. MonadException m => InputT m (Either String (Maybe Command))
+getCommand = handleInterrupt (return (Right Nothing)) $ do
+ line <- withInterrupt $ getInputLine "> "
+ case line of
Nothing -> return (Right (Just QuitPSCi)) -- Ctrl-D when input is empty
Just "" -> return (Right Nothing)
- Just s | singleLineMode || head s == ':' -> return . fmap Just $ parseCommand s
- Just s -> fmap Just . parseCommand <$> go [s]
+ Just s -> return . fmap Just $ parseCommand s
+
+pasteMode :: forall m. MonadException m => InputT m (Either String Command)
+pasteMode =
+ parseCommand <$> go []
where
go :: [String] -> InputT m String
- go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " "
+ go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine "… "
-- | Make a JavaScript bundle for the browser.
bundle :: IO (Either Bundle.ErrorMessage String)
@@ -349,16 +344,28 @@ main = getOpt >>= loop
go :: state -> InputT (StateT PSCiState (ReaderT PSCiConfig IO)) ()
go state = do
- c <- getCommand (not psciMultiLineMode)
+ c <- getCommand
case c of
Left err -> outputStrLn err >> go state
Right Nothing -> go state
+ Right (Just PasteLines) -> do
+ c' <- pasteMode
+ case c' of
+ Left err -> outputStrLn err >> go state
+ Right c'' -> handleCommandWithInterrupts state c''
Right (Just QuitPSCi) -> do
outputStrLn quitMessage
liftIO $ shutdown state
- Right (Just c') -> do
- handleInterrupt (outputStrLn "Interrupted.")
- (withInterrupt (lift (handleCommand (liftIO . eval state) (liftIO (reload state)) c')))
- go state
+ Right (Just c') -> handleCommandWithInterrupts state c'
+
+ handleCommandWithInterrupts
+ :: state
+ -> Command
+ -> InputT (StateT PSCiState (ReaderT PSCiConfig IO)) ()
+ handleCommandWithInterrupts state cmd = do
+ handleInterrupt (outputStrLn "Interrupted.")
+ (withInterrupt (lift (handleCommand (liftIO . eval state) (liftIO (reload state)) cmd)))
+ go state
+
putStrLn prologueMessage
setup >>= runner . go
diff --git a/purescript.cabal b/purescript.cabal
index 18ce548..0c3540a 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.10.1
+version: 0.10.2
cabal-version: >=1.8
build-type: Simple
license: BSD3
@@ -55,6 +55,8 @@ extra-source-files: examples/passing/*.purs
, examples/passing/TypeWithoutParens/*.purs
, examples/failing/*.purs
, examples/failing/1733/*.purs
+ , examples/failing/2378/*.purs
+ , examples/failing/2379/*.purs
, examples/failing/ConflictingExports/*.purs
, examples/failing/ConflictingImports/*.purs
, examples/failing/ConflictingImports2/*.purs
@@ -119,9 +121,10 @@ library
fsnotify >= 0.2.1,
Glob >= 0.7 && < 0.8,
haskeline >= 0.7.0.0,
- http-client >= 0.4.30 && <0.6,
+ http-client >= 0.4.30 && <0.5,
http-types -any,
language-javascript == 0.6.*,
+ lens == 4.*,
lifted-base >= 0.2.3 && < 0.2.4,
monad-control >= 1.0.0.0 && < 1.1,
monad-logger >= 0.3 && < 0.4,
@@ -237,6 +240,7 @@ library
Language.PureScript.TypeChecker.Subsumption
Language.PureScript.TypeChecker.Synonyms
Language.PureScript.TypeChecker.Types
+ Language.PureScript.TypeChecker.TypeSearch
Language.PureScript.TypeChecker.Unify
Language.PureScript.TypeClassDictionaries
Language.PureScript.Types
@@ -330,6 +334,7 @@ executable psc
mtl -any,
optparse-applicative >= 0.12.1,
parsec -any,
+ text -any,
time -any,
transformers -any,
transformers-compat -any,
@@ -383,6 +388,7 @@ executable psc-docs
optparse-applicative >= 0.12.1,
process -any,
split -any,
+ text -any,
transformers -any,
transformers-compat -any
main-is: Main.hs
@@ -406,6 +412,24 @@ executable psc-publish
hs-source-dirs: psc-publish
ghc-options: -Wall -O2
+executable psc-package
+ build-depends: base >=4 && <5,
+ purescript -any,
+ aeson -any,
+ aeson-pretty -any,
+ bytestring -any,
+ containers -any,
+ foldl -any,
+ optparse-applicative -any,
+ system-filepath -any,
+ text -any,
+ turtle -any
+ main-is: Main.hs
+ other-modules: Paths_purescript
+ buildable: True
+ hs-source-dirs: psc-package
+ ghc-options: -Wall -O2
+
executable psc-hierarchy
build-depends: base >=4 && <5,
purescript -any,
@@ -415,7 +439,8 @@ executable psc-hierarchy
mtl -any,
optparse-applicative >= 0.12.1,
parsec -any,
- process -any
+ process -any,
+ text -any
main-is: Main.hs
other-modules: Paths_purescript
buildable: True
diff --git a/src/Control/Monad/Supply.hs b/src/Control/Monad/Supply.hs
index 2fa7aaa..49df7d4 100644
--- a/src/Control/Monad/Supply.hs
+++ b/src/Control/Monad/Supply.hs
@@ -7,6 +7,7 @@ module Control.Monad.Supply where
import Prelude.Compat
+import Control.Applicative
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Reader
import Control.Monad.State
@@ -15,7 +16,7 @@ import Control.Monad.Writer
import Data.Functor.Identity
newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a }
- deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r)
+ deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r, Alternative, MonadPlus)
runSupplyT :: Integer -> SupplyT m a -> m (a, Integer)
runSupplyT n = flip runStateT n . unSupplyT
diff --git a/src/Control/Monad/Supply/Class.hs b/src/Control/Monad/Supply/Class.hs
index 88fc979..00d70cf 100644
--- a/src/Control/Monad/Supply/Class.hs
+++ b/src/Control/Monad/Supply/Class.hs
@@ -1,6 +1,9 @@
-- |
-- A class for monads supporting a supply of fresh names
--
+
+{-# LANGUAGE DefaultSignatures #-}
+
module Control.Monad.Supply.Class where
import Prelude.Compat
@@ -11,18 +14,21 @@ import Control.Monad.Writer
class Monad m => MonadSupply m where
fresh :: m Integer
+ peek :: m Integer
+ default fresh :: MonadTrans t => t m Integer
+ fresh = lift fresh
+ default peek :: MonadTrans t => t m Integer
+ peek = lift peek
instance Monad m => MonadSupply (SupplyT m) where
fresh = SupplyT $ do
n <- get
put (n + 1)
return n
+ peek = SupplyT get
-instance MonadSupply m => MonadSupply (StateT s m) where
- fresh = lift fresh
-
-instance (Monoid w, MonadSupply m) => MonadSupply (WriterT w m) where
- fresh = lift fresh
+instance MonadSupply m => MonadSupply (StateT s m)
+instance (Monoid w, MonadSupply m) => MonadSupply (WriterT w m)
freshName :: MonadSupply m => m String
freshName = fmap (('$' :) . show) fresh
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index 513d8e0..fde3ff5 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -29,6 +29,15 @@ import qualified Text.Parsec as P
-- | A map of locally-bound names in scope.
type Context = [(Ident, Type)]
+-- | Holds the data necessary to do type directed search for typed holes
+data TypeSearch
+ = TSBefore Environment
+ -- ^ An Environment captured for later consumption by type directed search
+ | TSAfter [(Qualified Ident, Type)]
+ -- ^ Results of applying type directed search to the previously captured
+ -- Environment
+ deriving Show
+
-- | A type of error messages
data SimpleErrorMessage
= ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)
@@ -74,6 +83,8 @@ data SimpleErrorMessage
| ConstrainedTypeUnified Type Type
| OverlappingInstances (Qualified (ProperName 'ClassName)) [Type] [Qualified Ident]
| NoInstanceFound Constraint
+ | AmbiguousTypeVariables Type Constraint
+ | UnknownClass (Qualified (ProperName 'ClassName))
| PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type]
| CannotDerive (Qualified (ProperName 'ClassName)) [Type]
| InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [Type]
@@ -99,7 +110,7 @@ data SimpleErrorMessage
| ShadowedTypeVar String
| UnusedTypeVar String
| WildcardInferredType Type Context
- | HoleInferredType String Type Context
+ | HoleInferredType String Type Context TypeSearch
| MissingTypeDeclaration Ident Type
| OverlappingPattern [[Binder]] Bool
| IncompleteExhaustivityCheck
@@ -123,7 +134,7 @@ data SimpleErrorMessage
| DeprecatedRequirePath
| CannotGeneralizeRecursiveFunction Ident Type
| CannotDeriveNewtypeForData (ProperName 'TypeName)
- | NonWildcardNewtypeInstance (ProperName 'TypeName)
+ | ExpectedWildcard (ProperName 'TypeName)
deriving (Show)
-- | Error message hints, providing more detailed information about failure.
@@ -250,6 +261,31 @@ instance Eq DeclarationRef where
r == (PositionedDeclarationRef _ _ r') = r == r'
_ == _ = False
+-- enable sorting lists of explicitly imported refs when suggesting imports in linting, IDE, etc.
+-- not an Ord because this implementation is not consistent with its Eq instance.
+-- think of it as a notion of contextual, not inherent, ordering.
+compDecRef :: DeclarationRef -> DeclarationRef -> Ordering
+compDecRef (TypeRef name _) (TypeRef name' _) = compare name name'
+compDecRef (TypeOpRef name) (TypeOpRef name') = compare name name'
+compDecRef (ValueRef ident) (ValueRef ident') = compare ident ident'
+compDecRef (ValueOpRef name) (ValueOpRef name') = compare name name'
+compDecRef (TypeClassRef name) (TypeClassRef name') = compare name name'
+compDecRef (TypeInstanceRef ident) (TypeInstanceRef ident') = compare ident ident'
+compDecRef (ModuleRef name) (ModuleRef name') = compare name name'
+compDecRef (ReExportRef name _) (ReExportRef name' _) = compare name name'
+compDecRef (PositionedDeclarationRef _ _ ref) ref' = compDecRef ref ref'
+compDecRef ref (PositionedDeclarationRef _ _ ref') = compDecRef ref ref'
+compDecRef ref ref' = compare
+ (orderOf ref) (orderOf ref')
+ where
+ orderOf :: DeclarationRef -> Int
+ orderOf (TypeClassRef _) = 0
+ orderOf (TypeOpRef _) = 1
+ orderOf (TypeRef _ _) = 2
+ orderOf (ValueRef _) = 3
+ orderOf (ValueOpRef _) = 4
+ orderOf _ = 5
+
getTypeRef :: DeclarationRef -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName])
getTypeRef (TypeRef name dctors) = Just (name, dctors)
getTypeRef (PositionedDeclarationRef _ _ r) = getTypeRef r
diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs
index b1ce9fb..610cd7e 100644
--- a/src/Language/PureScript/AST/Traversals.hs
+++ b/src/Language/PureScript/AST/Traversals.hs
@@ -474,7 +474,8 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
in foldMap (f'' s') ds
f' s (ValueDeclaration name _ bs (Right val)) =
let s' = S.insert name s
- in foldMap (h'' s') bs <> g'' s' val
+ s'' = S.union s' (S.fromList (concatMap binderNames bs))
+ in foldMap (h'' s') bs <> g'' s'' val
f' s (ValueDeclaration name _ bs (Left gs)) =
let s' = S.insert name s
s'' = S.union s' (S.fromList (concatMap binderNames bs))
@@ -551,7 +552,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
j' s (DoNotationValue v) = (s, g'' s v)
j' s (DoNotationBind b v) =
let s' = S.union (S.fromList (binderNames b)) s
- in (s', h'' s b <> g'' s' v)
+ in (s', h'' s b <> g'' s v)
j' s (DoNotationLet ds) =
let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds))
in (s', foldMap (f'' s') ds)
@@ -586,3 +587,15 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con
forValues (DeferredDictionary _ tys) = mconcat (map f tys)
forValues (TypedValue _ _ ty) = f ty
forValues _ = mempty
+
+-- |
+-- Map a function over type annotations appearing inside a value
+--
+overTypes :: (Type -> Type) -> Expr -> Expr
+overTypes f = let (_, f', _) = everywhereOnValues id g id in f'
+ where
+ g :: Expr -> Expr
+ g (TypedValue checkTy val t) = TypedValue checkTy val (f t)
+ g (TypeClassDictionary c sco hints) = TypeClassDictionary (mapConstraintArgs (map f) c) sco hints
+ g other = other
+
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index db1ea96..94b5c5e 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -244,23 +244,23 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
ret <- valueToJs val
return $ JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing (ds' ++ [JSReturn Nothing ret]))) []
valueToJs' (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =
- return $ JSVariableIntroduction Nothing ctor (Just $
+ return $ JSVariableIntroduction Nothing (properToJs ctor) (Just $
JSObjectLiteral Nothing [("create",
JSFunction Nothing Nothing ["value"]
(JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))])
valueToJs' (Constructor _ _ (ProperName ctor) []) =
- return $ iife ctor [ JSFunction Nothing (Just ctor) [] (JSBlock Nothing [])
- , JSAssignment Nothing (JSAccessor Nothing "value" (JSVar Nothing ctor))
- (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing ctor) []) ]
+ return $ iife (properToJs ctor) [ JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing [])
+ , JSAssignment Nothing (JSAccessor Nothing "value" (JSVar Nothing (properToJs ctor)))
+ (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) []) ]
valueToJs' (Constructor _ _ (ProperName ctor) fields) =
let constructor =
let body = [ JSAssignment Nothing (JSAccessor Nothing (identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ]
- in JSFunction Nothing (Just ctor) (identToJs `map` fields) (JSBlock Nothing body)
+ in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body)
createFn =
- let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing ctor) (var `map` fields)
+ let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields)
in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields
- in return $ iife ctor [ constructor
- , JSAssignment Nothing (JSAccessor Nothing "create" (JSVar Nothing ctor)) createFn
+ in return $ iife (properToJs ctor) [ constructor
+ , JSAssignment Nothing (JSAccessor Nothing "create" (JSVar Nothing (properToJs ctor))) createFn
]
iife :: String -> [JS] -> JS
diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs
index f0d180c..758e235 100644
--- a/src/Language/PureScript/CodeGen/JS/Common.hs
+++ b/src/Language/PureScript/CodeGen/JS/Common.hs
@@ -26,10 +26,13 @@ moduleNameToJs (ModuleName pns) =
-- * Symbols are prefixed with '$' followed by a symbol name or their ordinal value.
--
identToJs :: Ident -> String
-identToJs (Ident name)
+identToJs (Ident name) = properToJs name
+identToJs (GenIdent _ _) = internalError "GenIdent in identToJs"
+
+properToJs :: String -> String
+properToJs name
| nameIsJsReserved name || nameIsJsBuiltIn name = "$$" ++ name
| otherwise = concatMap identCharToString name
-identToJs (GenIdent _ _) = internalError "GenIdent in identToJs"
-- |
-- Test if a string is a valid JS identifier without escaping.
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
index 7f953e9..ff8c7c3 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
@@ -99,15 +99,6 @@ inlineCommonValues = everywhereOnJS convert
fnSubtract = (C.dataRing, C.sub)
intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0))
-inlineNonClassFunction :: (String, String) -> (JS -> JS -> JS) -> JS -> JS
-inlineNonClassFunction (m, op) f = everywhereOnJS convert
- where
- convert :: JS -> JS
- convert (JSApp _ (JSApp _ op' [x]) [y]) | isOp op' = f x y
- convert other = other
- isOp (JSAccessor _ op' (JSVar _ m')) = m == m' && op == op'
- isOp _ = False
-
inlineCommonOperators :: JS -> JS
inlineCommonOperators = applyAll $
[ binary semiringNumber opAdd Add
@@ -159,17 +150,17 @@ inlineCommonOperators = applyAll $
, binary heytingAlgebraBoolean opDisj Or
, unary heytingAlgebraBoolean opNot Not
- , binary' C.dataIntBits (C..|.) BitwiseOr
- , binary' C.dataIntBits (C..&.) BitwiseAnd
- , binary' C.dataIntBits (C..^.) BitwiseXor
+ , binary' C.dataIntBits C.or BitwiseOr
+ , binary' C.dataIntBits C.and BitwiseAnd
+ , binary' C.dataIntBits C.xor BitwiseXor
, binary' C.dataIntBits C.shl ShiftLeft
, binary' C.dataIntBits C.shr ShiftRight
, binary' C.dataIntBits C.zshr ZeroFillShiftRight
, unary' C.dataIntBits C.complement BitwiseNot
- , inlineNonClassFunction (C.dataFunction, C.apply) $ \f x -> JSApp Nothing f [x]
- , inlineNonClassFunction (C.dataFunction, C.applyFlipped) $ \x f -> JSApp Nothing f [x]
- , inlineNonClassFunction (C.dataArrayUnsafe, C.unsafeIndex) $ flip (JSIndexer Nothing)
+ , inlineNonClassFunction (isModFn (C.dataFunction, C.apply)) $ \f x -> JSApp Nothing f [x]
+ , inlineNonClassFunction (isModFn (C.dataFunction, C.applyFlipped)) $ \x f -> JSApp Nothing f [x]
+ , inlineNonClassFunction (isModFnWithDict (C.dataArray, C.unsafeIndex)) $ flip (JSIndexer Nothing)
] ++
[ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]
where
@@ -233,6 +224,21 @@ inlineCommonOperators = applyAll $
go m acc (JSApp _ lhs [arg]) = go (m - 1) (arg : acc) lhs
go _ _ _ = Nothing
+ inlineNonClassFunction :: (JS -> Bool) -> (JS -> JS -> JS) -> JS -> JS
+ inlineNonClassFunction p f = everywhereOnJS convert
+ where
+ convert :: JS -> JS
+ convert (JSApp _ (JSApp _ op' [x]) [y]) | p op' = f x y
+ convert other = other
+
+ isModFn :: (String, String) -> JS -> Bool
+ isModFn (m, op) (JSAccessor _ op' (JSVar _ m')) = m == m' && op == op'
+ isModFn _ _ = False
+
+ isModFnWithDict :: (String, String) -> JS -> Bool
+ isModFnWithDict (m, op) (JSApp _ (JSAccessor _ op' (JSVar _ m')) [(JSVar _ _)]) = m == m' && op == op'
+ isModFnWithDict _ _ = False
+
-- (f <<< g $ x) = f (g x)
-- (f <<< g) = \x -> f (g x)
inlineFnComposition :: (MonadSupply m) => JS -> m JS
diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs
index 021d3e0..8f607b9 100644
--- a/src/Language/PureScript/Constants.hs
+++ b/src/Language/PureScript/Constants.hs
@@ -118,14 +118,14 @@ disj = "disj"
unsafeIndex :: String
unsafeIndex = "unsafeIndex"
-(.|.) :: String
-(.|.) = ".|."
+or :: String
+or = "or"
-(.&.) :: String
-(.&.) = ".&."
+and :: String
+and = "and"
-(.^.) :: String
-(.^.) = ".^."
+xor :: String
+xor = "xor"
(<<<) :: String
(<<<) = "<<<"
@@ -346,8 +346,8 @@ prim = "Prim"
prelude :: String
prelude = "Prelude"
-dataArrayUnsafe :: String
-dataArrayUnsafe = "Data_Array_Unsafe"
+dataArray :: String
+dataArray = "Data_Array"
eff :: String
eff = "Control_Monad_Eff"
diff --git a/src/Language/PureScript/Docs/ParseAndBookmark.hs b/src/Language/PureScript/Docs/ParseAndBookmark.hs
index b87fb41..c45da01 100644
--- a/src/Language/PureScript/Docs/ParseAndBookmark.hs
+++ b/src/Language/PureScript/Docs/ParseAndBookmark.hs
@@ -9,13 +9,12 @@ import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.IO.Class (MonadIO(..))
import qualified Data.Map as M
+import Data.Text (Text)
import Language.PureScript.Docs.Convert (collectBookmarks)
import Language.PureScript.Docs.Types
import qualified Language.PureScript as P
-
-import System.IO.UTF8 (readUTF8File)
-
+import System.IO.UTF8 (readUTF8FileT)
import Web.Bower.PackageMeta (PackageName)
-- |
@@ -45,7 +44,7 @@ parseAndBookmark inputFiles depsFiles = do
parseFiles ::
(MonadError P.MultipleErrors m) =>
- [(FileInfo, FilePath)]
+ [(FileInfo, Text)]
-> m [(FileInfo, P.Module)]
parseFiles =
throwLeft . P.parseModulesFromFiles fileInfoToString
@@ -77,10 +76,10 @@ fileInfoToString :: FileInfo -> FilePath
fileInfoToString (Local fn) = fn
fileInfoToString (FromDep _ fn) = fn
-parseFile :: FilePath -> IO (FilePath, String)
-parseFile input' = (,) input' <$> readUTF8File input'
+parseFile :: FilePath -> IO (FilePath, Text)
+parseFile input' = (,) input' <$> readUTF8FileT input'
-parseAs :: (MonadIO m) => (FilePath -> a) -> FilePath -> m (a, String)
+parseAs :: (MonadIO m) => (FilePath -> a) -> FilePath -> m (a, Text)
parseAs g = fmap (first g) . liftIO . parseFile
getDepsModuleNames :: [InPackage (FilePath, P.Module)] -> M.Map P.ModuleName PackageName
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index fbd665d..49043e2 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -236,8 +236,8 @@ function t1 = TypeApp (TypeApp tyFunction t1)
-- |
-- The primitive types in the external javascript environment with their
--- associated kinds. There is also a pseudo `Partial` type that corresponds to
--- the class with the same name.
+-- associated kinds. There are also pseudo `Fail` and `Partial` types
+-- that correspond to the classes with the same names.
--
primTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)
primTypes =
@@ -257,8 +257,9 @@ primTypes =
]
-- |
--- The primitive class map. This just contains to `Partial` class, used as a
--- kind of magic constraint for partial functions.
+-- The primitive class map. This just contains the `Fail` and `Partial`
+-- classes. `Partial` is used as a kind of magic constraint for partial
+-- functions. `Fail` is used for user-defined type errors.
--
primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData
primClasses =
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 967ccd1..60bba56 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -40,6 +40,7 @@ import qualified System.Console.ANSI as ANSI
import qualified Text.Parsec as P
import qualified Text.Parsec.Error as PE
import qualified Text.PrettyPrint.Boxes as Box
+import qualified Language.PureScript.Publish.BoxesHelpers as BoxHelpers
import Text.Parsec.Error (Message(..))
newtype ErrorSuggestion = ErrorSuggestion String
@@ -117,6 +118,8 @@ errorCode em = case unwrapErrorMessage em of
ConstrainedTypeUnified{} -> "ConstrainedTypeUnified"
OverlappingInstances{} -> "OverlappingInstances"
NoInstanceFound{} -> "NoInstanceFound"
+ AmbiguousTypeVariables{} -> "AmbiguousTypeVariables"
+ UnknownClass{} -> "UnknownClass"
PossiblyInfiniteInstance{} -> "PossiblyInfiniteInstance"
CannotDerive{} -> "CannotDerive"
InvalidNewtypeInstance{} -> "InvalidNewtypeInstance"
@@ -166,7 +169,7 @@ errorCode em = case unwrapErrorMessage em of
DeprecatedRequirePath{} -> "DeprecatedRequirePath"
CannotGeneralizeRecursiveFunction{} -> "CannotGeneralizeRecursiveFunction"
CannotDeriveNewtypeForData{} -> "CannotDeriveNewtypeForData"
- NonWildcardNewtypeInstance{} -> "NonWildcardNewtypeInstance"
+ ExpectedWildcard{} -> "ExpectedWildcard"
-- |
-- A stack trace for an error
@@ -259,6 +262,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse
gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t
gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t
gSimple (NoInstanceFound con) = NoInstanceFound <$> overConstraintArgs (traverse f) con
+ gSimple (AmbiguousTypeVariables t con) = AmbiguousTypeVariables <$> (f t) <*> pure con
gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts
gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts
gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts
@@ -266,7 +270,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse
gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k
gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts
gSimple (WildcardInferredType ty ctx) = WildcardInferredType <$> f ty <*> traverse (sndM f) ctx
- gSimple (HoleInferredType name ty ctx) = HoleInferredType name <$> f ty <*> traverse (sndM f) ctx
+ gSimple (HoleInferredType name ty ctx env) = HoleInferredType name <$> f ty <*> traverse (sndM f) ctx <*> gTypeSearch env
gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty
gSimple (CannotGeneralizeRecursiveFunction nm ty) = CannotGeneralizeRecursiveFunction nm <$> f ty
gSimple other = pure other
@@ -280,6 +284,9 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse
gHint (ErrorSolvingConstraint con) = ErrorSolvingConstraint <$> overConstraintArgs (traverse f) con
gHint other = pure other
+ gTypeSearch (TSBefore env) = pure (TSBefore env)
+ gTypeSearch (TSAfter result) = TSAfter <$> traverse (traverse f) result
+
wikiUri :: ErrorMessage -> String
wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e
@@ -287,19 +294,19 @@ wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ error
-- WildcardInferredType - source span not small enough
-- DuplicateSelectiveImport - would require 2 ranges to remove and 1 insert
errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion
-errorSuggestion err = case err of
- UnusedImport{} -> emptySuggestion
- DuplicateImport{} -> emptySuggestion
- UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual
- UnusedDctorImport mn _ qual refs -> suggest $ importSuggestion mn refs qual
- UnusedDctorExplicitImport mn _ _ qual refs -> suggest $ importSuggestion mn refs qual
- ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing
- ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule)
- HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing
- MissingTypeDeclaration ident ty -> suggest $ showIdent ident ++ " :: " ++ prettyPrintType ty
- WildcardInferredType ty _ -> suggest $ prettyPrintType ty
- _ -> Nothing
-
+errorSuggestion err =
+ case err of
+ UnusedImport{} -> emptySuggestion
+ DuplicateImport{} -> emptySuggestion
+ UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual
+ UnusedDctorImport mn _ qual refs -> suggest $ importSuggestion mn refs qual
+ UnusedDctorExplicitImport mn _ _ qual refs -> suggest $ importSuggestion mn refs qual
+ ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing
+ ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule)
+ HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing
+ MissingTypeDeclaration ident ty -> suggest $ showIdent ident ++ " :: " ++ prettyPrintSuggestedType ty
+ WildcardInferredType ty _ -> suggest $ prettyPrintSuggestedType ty
+ _ -> Nothing
where
emptySuggestion = Just $ ErrorSuggestion ""
suggest = Just . ErrorSuggestion
@@ -595,6 +602,11 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
, line "They may be disallowed completely in a future version of the compiler."
]
renderSimpleErrorMessage OverlappingInstances{} = internalError "OverlappingInstances: empty instance list"
+ renderSimpleErrorMessage (UnknownClass nm) =
+ paras [ line "No type class instance was found for class"
+ , markCodeBox $ indent $ line (showQualified runProperName nm)
+ , line "because the class was not in scope. Perhaps it was not exported."
+ ]
renderSimpleErrorMessage (NoInstanceFound (Constraint C.Fail [ ty ] _)) | Just box <- toTypelevelString ty =
paras [ line "A custom type error occurred while solving type class constraints:"
, indent box
@@ -626,6 +638,11 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
where
go TUnknown{} = True
go _ = False
+ renderSimpleErrorMessage (AmbiguousTypeVariables t _) =
+ paras [ line "The inferred type"
+ , indent $ line $ markCode $ prettyPrintType t
+ , line "has type variables which are not mentioned in the body of the type. Consider adding a type annotation."
+ ]
renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) =
paras [ line "Type class instance for"
, markCodeBox $ indent $ Box.hsep 1 Box.left
@@ -733,10 +750,31 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
paras $ [ line "Wildcard type definition has the inferred type "
, markCodeBox $ indent $ typeAsBox ty
] ++ renderContext ctx
- renderSimpleErrorMessage (HoleInferredType name ty ctx) =
- paras $ [ line $ "Hole '" ++ markCode name ++ "' has the inferred type "
- , markCodeBox $ indent $ typeAsBox ty
- ] ++ renderContext ctx
+ renderSimpleErrorMessage (HoleInferredType name ty ctx ts) =
+ let
+ maxTSResults = 15
+ tsResult = case ts of
+ (TSAfter idents) | not (null idents) ->
+ let
+ formatTS (names, types) =
+ let
+ idBoxes = Box.text . showQualified runIdent <$> names
+ tyBoxes = (\t -> BoxHelpers.indented
+ (Box.text ":: " Box.<> typeAsBox t)) <$> types
+ longestId = maximum (map Box.cols idBoxes)
+ in
+ Box.vcat Box.top $
+ zipWith (Box.<>)
+ (Box.alignHoriz Box.left longestId <$> idBoxes)
+ tyBoxes
+ in [ line "You could substitute the hole with one of these values:"
+ , markCodeBox (indent (formatTS (unzip (take maxTSResults idents))))
+ ]
+ _ -> []
+ in
+ paras $ [ line $ "Hole '" ++ markCode name ++ "' has the inferred type "
+ , markCodeBox (indent (typeAsBox ty))
+ ] ++ tsResult ++ renderContext ctx
renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =
paras [ line $ "No type declaration was provided for the top-level declaration of " ++ markCode (showIdent ident) ++ "."
, line "It is good practice to provide type declarations as a form of documentation."
@@ -834,8 +872,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
paras [ line $ "Cannot derive an instance of the " ++ markCode "Newtype" ++ " class for non-newtype " ++ markCode (runProperName tyName) ++ "."
]
- renderSimpleErrorMessage (NonWildcardNewtypeInstance tyName) =
- paras [ line $ "A type wildcard (_) should be used for the inner type when deriving the " ++ markCode "Newtype" ++ " instance for " ++ markCode (runProperName tyName) ++ "."
+ renderSimpleErrorMessage (ExpectedWildcard tyName) =
+ paras [ line $ "Expected a type wildcard (_) when deriving an instance for " ++ markCode (runProperName tyName) ++ "."
]
renderHint :: ErrorMessageHint -> Box.Box -> Box.Box
diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs
index 54f5137..00940e4 100644
--- a/src/Language/PureScript/Ide/CaseSplit.hs
+++ b/src/Language/PureScript/Ide/CaseSplit.hs
@@ -12,7 +12,7 @@
-- Casesplitting and adding function clauses
-----------------------------------------------------------------------------
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings #-}
module Language.PureScript.Ide.CaseSplit
( WildcardAnnotations()
@@ -23,10 +23,10 @@ module Language.PureScript.Ide.CaseSplit
, caseSplit
) where
-import Protolude hiding (Constructor)
+import Protolude hiding (Constructor)
-import qualified Data.Text as T
-import qualified Language.PureScript as P
+import qualified Data.Text as T
+import qualified Language.PureScript as P
import Language.PureScript.Externs
import Language.PureScript.Ide.Error
@@ -34,8 +34,8 @@ import Language.PureScript.Ide.State
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
-import Text.Parsec as Parsec
-import qualified Text.PrettyPrint.Boxes as Box
+import Text.Parsec as Parsec
+import qualified Text.PrettyPrint.Boxes as Box
type Constructor = (P.ProperName 'P.ConstructorName, [P.Type])
diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs
index 966afd2..6540db9 100644
--- a/src/Language/PureScript/Ide/Command.hs
+++ b/src/Language/PureScript/Ide/Command.hs
@@ -12,7 +12,8 @@
-- Datatypes for the commands psc-ide accepts
-----------------------------------------------------------------------------
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Language.PureScript.Ide.Command where
diff --git a/src/Language/PureScript/Ide/Conversions.hs b/src/Language/PureScript/Ide/Conversions.hs
index d0a46eb..bb5ec88 100644
--- a/src/Language/PureScript/Ide/Conversions.hs
+++ b/src/Language/PureScript/Ide/Conversions.hs
@@ -14,16 +14,23 @@
module Language.PureScript.Ide.Conversions where
-import Protolude
-import Data.Text (unwords, lines, strip)
+import Control.Lens.Iso
+import Data.Text (lines, strip, unwords)
import qualified Language.PureScript as P
+import Protolude
runProperNameT :: P.ProperName a -> Text
runProperNameT = toS . P.runProperName
+properNameT :: Iso' (P.ProperName a) Text
+properNameT = iso (toS . P.runProperName) (P.ProperName . toS)
+
runIdentT :: P.Ident -> Text
runIdentT = toS . P.runIdent
+identT :: Iso' P.Ident Text
+identT = iso (toS . P.runIdent) (P.Ident . toS)
+
runOpNameT :: P.OpName a -> Text
runOpNameT = toS . P.runOpName
@@ -32,4 +39,3 @@ runModuleNameT = toS . P.runModuleName
prettyTypeT :: P.Type -> Text
prettyTypeT = unwords . map strip . lines . toS . P.prettyPrintType
-
diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs
index 19c112a..5b56717 100644
--- a/src/Language/PureScript/Ide/Error.hs
+++ b/src/Language/PureScript/Ide/Error.hs
@@ -17,11 +17,11 @@ module Language.PureScript.Ide.Error
( PscIdeError(..)
) where
-import Protolude
import Data.Aeson
import Language.PureScript.Errors.JSON
-import Language.PureScript.Ide.Types (ModuleIdent)
-import qualified Text.Parsec.Error as P
+import Language.PureScript.Ide.Types (ModuleIdent)
+import Protolude
+import qualified Text.Parsec.Error as P
data PscIdeError
= GeneralError Text
diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs
index 4e00d8c..1e92bd9 100644
--- a/src/Language/PureScript/Ide/Externs.hs
+++ b/src/Language/PureScript/Ide/Externs.hs
@@ -14,7 +14,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE FlexibleContexts #-}
module Language.PureScript.Ide.Externs
( readExternFile
@@ -24,10 +23,11 @@ module Language.PureScript.Ide.Externs
import Protolude
+import Control.Lens ((^.))
import Data.Aeson (decodeStrict)
+import qualified Data.ByteString as BS
import Data.List (nub)
import qualified Data.Map as Map
-import qualified Data.ByteString as BS
import Language.PureScript.Ide.Error (PscIdeError (..))
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
@@ -58,14 +58,14 @@ convertExterns ef =
cleanDeclarations = nub $ appEndo typeClassFilter declarations
removeTypeDeclarationsForClass :: IdeDeclaration -> Endo [IdeDeclaration]
-removeTypeDeclarationsForClass (IdeTypeClass n) = Endo (filter notDuplicate)
- where notDuplicate (IdeType n' _) = runProperNameT n /= runProperNameT n'
- notDuplicate (IdeTypeSynonym n' _) = runProperNameT n /= runProperNameT n'
+removeTypeDeclarationsForClass (IdeDeclTypeClass n) = Endo (filter notDuplicate)
+ where notDuplicate (IdeDeclType t) = n ^. properNameT /= t ^. ideTypeName . properNameT
+ notDuplicate (IdeDeclTypeSynonym s) = n ^. properNameT /= s ^. ideSynonymName . properNameT
notDuplicate _ = True
removeTypeDeclarationsForClass _ = mempty
isTypeClassDeclaration :: IdeDeclaration -> Bool
-isTypeClassDeclaration IdeTypeClass{} = True
+isTypeClassDeclaration IdeDeclTypeClass{} = True
isTypeClassDeclaration _ = False
convertExport :: P.DeclarationRef -> Maybe (P.ModuleName, P.DeclarationRef)
@@ -73,19 +73,20 @@ convertExport (P.ReExportRef m r) = Just (m, r)
convertExport _ = Nothing
convertDecl :: P.ExternsDeclaration -> Maybe IdeDeclaration
-convertDecl P.EDType{..} = Just (IdeType edTypeName edTypeKind)
-convertDecl P.EDTypeSynonym{..} =
- Just (IdeTypeSynonym edTypeSynonymName edTypeSynonymType)
-convertDecl P.EDDataConstructor{..} = Just $
+convertDecl P.EDType{..} = Just $ IdeDeclType $
+ IdeType edTypeName edTypeKind
+convertDecl P.EDTypeSynonym{..} = Just $ IdeDeclTypeSynonym
+ (IdeSynonym edTypeSynonymName edTypeSynonymType)
+convertDecl P.EDDataConstructor{..} = Just $ IdeDeclDataConstructor $
IdeDataConstructor edDataCtorName edDataCtorTypeCtor edDataCtorType
-convertDecl P.EDValue{..} = Just $
+convertDecl P.EDValue{..} = Just $ IdeDeclValue $
IdeValue edValueName edValueType
-convertDecl P.EDClass{..} = Just (IdeTypeClass edClassName)
+convertDecl P.EDClass{..} = Just (IdeDeclTypeClass edClassName)
convertDecl P.EDInstance{} = Nothing
convertOperator :: P.ExternsFixity -> IdeDeclaration
convertOperator P.ExternsFixity{..} =
- IdeValueOperator
+ IdeDeclValueOperator $ IdeValueOperator
efOperator
efAlias
efPrecedence
@@ -94,7 +95,7 @@ convertOperator P.ExternsFixity{..} =
convertTypeOperator :: P.ExternsTypeFixity -> IdeDeclaration
convertTypeOperator P.ExternsTypeFixity{..} =
- IdeTypeOperator
+ IdeDeclTypeOperator $ IdeTypeOperator
efTypeOperator
efTypeAlias
efTypePrecedence
@@ -110,20 +111,20 @@ annotateModule (defs, types) (moduleName, decls) =
where
convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn
convertDeclaration (IdeDeclarationAnn ann d) = case d of
- IdeValue i t ->
- annotateFunction i (IdeValue i t)
- IdeType i k ->
- annotateType (runProperNameT i) (IdeType i k)
- IdeTypeSynonym i t ->
- annotateType (runProperNameT i) (IdeTypeSynonym i t)
- IdeDataConstructor i tn t ->
- annotateValue (runProperNameT i) (IdeDataConstructor i tn t)
- IdeTypeClass i ->
- annotateType (runProperNameT i) (IdeTypeClass i)
- IdeValueOperator n i p a t ->
- annotateValue (valueOperatorAliasT i) (IdeValueOperator n i p a t)
- IdeTypeOperator n i p a k ->
- annotateType (typeOperatorAliasT i) (IdeTypeOperator n i p a k)
+ IdeDeclValue v ->
+ annotateFunction (v ^. ideValueIdent) (IdeDeclValue v)
+ IdeDeclType t ->
+ annotateType (t ^. ideTypeName . properNameT) (IdeDeclType t)
+ IdeDeclTypeSynonym s ->
+ annotateType (s ^. ideSynonymName . properNameT) (IdeDeclTypeSynonym s)
+ IdeDeclDataConstructor dtor ->
+ annotateValue (dtor ^. ideDtorName . properNameT) (IdeDeclDataConstructor dtor)
+ IdeDeclTypeClass i ->
+ annotateType (runProperNameT i) (IdeDeclTypeClass i)
+ IdeDeclValueOperator op ->
+ annotateValue (op ^. ideValueOpAlias & valueOperatorAliasT) (IdeDeclValueOperator op)
+ IdeDeclTypeOperator op ->
+ annotateType (op ^. ideTypeOpAlias & typeOperatorAliasT) (IdeDeclTypeOperator op)
where
annotateFunction x = IdeDeclarationAnn (ann { annLocation = Map.lookup (Left (runIdentT x)) defs
, annTypeAnnotation = Map.lookup x types
diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs
index e0b79a4..6c52549 100644
--- a/src/Language/PureScript/Ide/Filter.hs
+++ b/src/Language/PureScript/Ide/Filter.hs
@@ -23,13 +23,13 @@ module Language.PureScript.Ide.Filter
, applyFilters
) where
-import Protolude hiding (isPrefixOf)
+import Protolude hiding (isPrefixOf)
import Data.Aeson
import Data.Text (isPrefixOf)
+import qualified Language.PureScript as P
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
-import qualified Language.PureScript as P
newtype Filter = Filter (Endo [Module]) deriving(Monoid)
@@ -65,8 +65,7 @@ identFilter predicate search =
where
filterModuleDecls :: Module -> Module
filterModuleDecls (moduleIdent, decls) =
- (moduleIdent, filter (flip predicate search . getDeclaration) decls)
- getDeclaration (IdeDeclarationAnn _ d) = d
+ (moduleIdent, filter (flip predicate search . discardAnn) decls)
runFilter :: Filter -> [Module] -> [Module]
runFilter (Filter f) = appEndo f
diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs
index e9065e9..b45e367 100644
--- a/src/Language/PureScript/Ide/Imports.hs
+++ b/src/Language/PureScript/Ide/Imports.hs
@@ -30,9 +30,10 @@ module Language.PureScript.Ide.Imports
where
import Protolude
+
+import Control.Lens ((^.))
+import Data.List (findIndex, nubBy)
import qualified Data.Text as T
-import Data.List (nubBy, findIndex)
-import qualified Data.Text.IO as TIO
import qualified Language.PureScript as P
import Language.PureScript.Ide.Completion
import Language.PureScript.Ide.Error
@@ -40,6 +41,7 @@ import Language.PureScript.Ide.Filter
import Language.PureScript.Ide.State
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
+import System.IO.UTF8 (readUTF8FileT, writeUTF8FileT)
data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName)
deriving (Eq, Show)
@@ -70,7 +72,7 @@ compImport (Import n i q) (Import n' i' q')
parseImportsFromFile :: (MonadIO m, MonadError PscIdeError m) =>
FilePath -> m (P.ModuleName, [Text], [Import], [Text])
parseImportsFromFile fp = do
- file <- liftIO (TIO.readFile fp)
+ file <- liftIO (readUTF8FileT fp)
case sliceImportSection (T.lines file) of
Right res -> pure res
Left err -> throwError (GeneralError err)
@@ -197,16 +199,16 @@ addExplicitImport' decl moduleName imports =
then imports
else updateAtFirstOrPrepend matches (insertDeclIntoImport decl) freshImport imports
where
- refFromDeclaration (IdeTypeClass n) =
+ refFromDeclaration (IdeDeclTypeClass n) =
P.TypeClassRef n
- refFromDeclaration (IdeDataConstructor n tn _) =
- P.TypeRef tn (Just [n])
- refFromDeclaration (IdeType n _) =
- P.TypeRef n (Just [])
- refFromDeclaration (IdeValueOperator op _ _ _ _) =
- P.ValueOpRef op
- refFromDeclaration (IdeTypeOperator op _ _ _ _) =
- P.TypeOpRef op
+ refFromDeclaration (IdeDeclDataConstructor dtor) =
+ P.TypeRef (dtor ^. ideDtorTypeName) Nothing
+ refFromDeclaration (IdeDeclType t) =
+ P.TypeRef (t ^. ideTypeName) (Just [])
+ refFromDeclaration (IdeDeclValueOperator op) =
+ P.ValueOpRef (op ^. ideValueOpName)
+ refFromDeclaration (IdeDeclTypeOperator op) =
+ P.TypeOpRef (op ^. ideTypeOpName)
refFromDeclaration d =
P.ValueRef $ P.Ident $ T.unpack (identifierFromIdeDeclaration d)
@@ -214,20 +216,19 @@ addExplicitImport' decl moduleName imports =
-- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe)
insertDeclIntoImport :: IdeDeclaration -> Import -> Import
insertDeclIntoImport decl' (Import mn (P.Explicit refs) Nothing) =
- Import mn (P.Explicit (insertDeclIntoRefs decl' refs)) Nothing
+ Import mn (P.Explicit (sortBy P.compDecRef (insertDeclIntoRefs decl' refs))) Nothing
insertDeclIntoImport _ is = is
insertDeclIntoRefs :: IdeDeclaration -> [P.DeclarationRef] -> [P.DeclarationRef]
- insertDeclIntoRefs (IdeDataConstructor dtor tn _) refs =
- updateAtFirstOrPrepend (matchType tn) (insertDtor dtor) (P.TypeRef tn (Just [dtor])) refs
+ insertDeclIntoRefs d@(IdeDeclDataConstructor dtor) refs =
+ updateAtFirstOrPrepend
+ (matchType (dtor ^. ideDtorTypeName))
+ (insertDtor (dtor ^. ideDtorName))
+ (refFromDeclaration d)
+ refs
insertDeclIntoRefs dr refs = nubBy ((==) `on` P.prettyPrintRef) (refFromDeclaration dr : refs)
- insertDtor dtor (P.TypeRef tn' dtors) =
- case dtors of
- Just dtors' -> P.TypeRef tn' (Just (ordNub (dtor : dtors')))
- -- This means the import was opened. We don't add anything in this case
- -- import Data.Maybe (Maybe(..)) -> import Data.Maybe (Maybe(Just))
- Nothing -> P.TypeRef tn' Nothing
+ insertDtor _ (P.TypeRef tn' _) = P.TypeRef tn' Nothing
insertDtor _ refs = refs
matchType :: P.ProperName 'P.TypeName -> P.DeclarationRef -> Bool
@@ -294,9 +295,9 @@ addImportForIdentifier fp ident filters = do
xs ->
pure $ Left xs
where
- decideRedundantCase dtor@(IdeDataConstructor _ t _) (IdeType t' _) =
- if t == t' then Just dtor else Nothing
- decideRedundantCase IdeType{} ts@IdeTypeSynonym{} =
+ decideRedundantCase d@(IdeDeclDataConstructor dtor) (IdeDeclType t) =
+ if dtor ^. ideDtorTypeName == t ^. ideTypeName then Just d else Nothing
+ decideRedundantCase IdeDeclType{} ts@IdeDeclTypeSynonym{} =
Just ts
decideRedundantCase _ _ = Nothing
@@ -316,10 +317,10 @@ prettyPrintImportSection imports = map prettyPrintImport' (sort imports)
answerRequest :: (MonadIO m) => Maybe FilePath -> [Text] -> m Success
answerRequest outfp rs =
case outfp of
- Nothing -> pure $ MultilineTextResult rs
+ Nothing -> pure (MultilineTextResult rs)
Just outfp' -> do
- liftIO $ TIO.writeFile outfp' (T.unlines rs)
- pure $ TextResult $ "Written to " <> T.pack outfp'
+ liftIO (writeUTF8FileT outfp' (T.unlines rs))
+ pure (TextResult ("Written to " <> T.pack outfp'))
-- | Test and ghci helper
parseImport :: Text -> Maybe Import
diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs
index 254ac55..7a495d2 100644
--- a/src/Language/PureScript/Ide/Matcher.hs
+++ b/src/Language/PureScript/Ide/Matcher.hs
@@ -12,9 +12,9 @@
-- Matchers for psc-ide commands
-----------------------------------------------------------------------------
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleInstances #-}
module Language.PureScript.Ide.Matcher
( Matcher
diff --git a/src/Language/PureScript/Ide/Pursuit.hs b/src/Language/PureScript/Ide/Pursuit.hs
index ae40238..90957fa 100644
--- a/src/Language/PureScript/Ide/Pursuit.hs
+++ b/src/Language/PureScript/Ide/Pursuit.hs
@@ -12,7 +12,7 @@
-- Pursuit client for psc-ide
-----------------------------------------------------------------------------
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings #-}
module Language.PureScript.Ide.Pursuit
( searchPursuitForDeclarations
@@ -35,37 +35,41 @@ import qualified Pipes.Prelude as P
-- TODO: remove this when the issue is fixed at Pursuit
queryPursuit :: Text -> IO ByteString
queryPursuit q = do
- let qClean = T.dropWhileEnd (== '.') q
- req' <- parseRequest "http://pursuit.purescript.org/search"
- let req = req'
- { queryString= "q=" <> (fromString . T.unpack) qClean
- , requestHeaders=[(hAccept, "application/json")]
- }
- m <- newManager tlsManagerSettings
- withHTTP req m $ \resp ->
- P.fold (<>) "" identity (responseBody resp)
+ let qClean = T.dropWhileEnd (== '.') q
+ req' <- parseRequest "http://pursuit.purescript.org/search"
+ let req = req'
+ { queryString= "q=" <> (fromString . T.unpack) qClean
+ , requestHeaders=[(hAccept, "application/json")]
+ }
+ m <- newManager tlsManagerSettings
+ withHTTP req m $ \resp ->
+ P.fold (<>) "" identity (responseBody resp)
+
handler :: HttpException -> IO [a]
+handler StatusCodeException{} = pure []
handler _ = pure []
searchPursuitForDeclarations :: Text -> IO [PursuitResponse]
-searchPursuitForDeclarations query = E.handle handler $ do
- r <- queryPursuit query
- let results' = decode (fromStrict r) :: Maybe Array
- case results' of
- Nothing -> pure []
- Just results -> pure (mapMaybe (isDeclarationResponse . fromJSON) (toList results))
+searchPursuitForDeclarations query =
+ (do r <- queryPursuit query
+ let results' = decode (fromStrict r) :: Maybe Array
+ case results' of
+ Nothing -> pure []
+ Just results -> pure (mapMaybe (isDeclarationResponse . fromJSON) (toList results))) `E.catch`
+ handler
where
isDeclarationResponse (Success a@DeclarationResponse{}) = Just a
isDeclarationResponse _ = Nothing
findPackagesForModuleIdent :: Text -> IO [PursuitResponse]
-findPackagesForModuleIdent query = E.handle handler $ do
- r <- queryPursuit query
- let results' = decode (fromStrict r) :: Maybe Array
- case results' of
+findPackagesForModuleIdent query =
+ (do r <- queryPursuit query
+ let results' = decode (fromStrict r) :: Maybe Array
+ case results' of
Nothing -> pure []
- Just results -> pure (mapMaybe (isModuleResponse . fromJSON) (toList results))
+ Just results -> pure (mapMaybe (isModuleResponse . fromJSON) (toList results))) `E.catch`
+ handler
where
isModuleResponse (Success a@ModuleResponse{}) = Just a
isModuleResponse _ = Nothing
diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs
index f9b9d18..a50646c 100644
--- a/src/Language/PureScript/Ide/Rebuild.hs
+++ b/src/Language/PureScript/Ide/Rebuild.hs
@@ -11,7 +11,7 @@ module Language.PureScript.Ide.Rebuild
import Protolude
import "monad-logger" Control.Monad.Logger
-import qualified Data.List as List
+import qualified Data.List as List
import qualified Data.Map.Lazy as M
import Data.Maybe (fromJust)
import qualified Data.Set as S
@@ -21,7 +21,7 @@ import Language.PureScript.Ide.Error
import Language.PureScript.Ide.State
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
-import System.IO.UTF8 (readUTF8File)
+import System.IO.UTF8 (readUTF8FileT)
-- | Given a filepath performs the following steps:
--
@@ -44,7 +44,7 @@ rebuildFile
-> m Success
rebuildFile path = do
- input <- liftIO (readUTF8File path)
+ input <- liftIO (readUTF8FileT path)
m <- case snd <$> P.parseModuleFromFile identity (path, input) of
Left parseError -> throwError
diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs
index dd56994..f0ac391 100644
--- a/src/Language/PureScript/Ide/Reexports.hs
+++ b/src/Language/PureScript/Ide/Reexports.hs
@@ -25,16 +25,18 @@ module Language.PureScript.Ide.Reexports
import Protolude
+import Control.Lens hiding ((&))
+
import qualified Data.Map as Map
+import qualified Language.PureScript as P
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
-import qualified Language.PureScript as P
-- | Contains the module with resolved reexports, and eventual failures
data ReexportResult a
= ReexportResult
{ reResolved :: a
- , reFailed :: [(P.ModuleName, P.DeclarationRef)]
+ , reFailed :: [(P.ModuleName, P.DeclarationRef)]
} deriving (Show, Eq, Functor)
-- | Uses the passed formatter to format the resolved module, and adds eventual
@@ -79,7 +81,7 @@ resolveRef
-> Either P.DeclarationRef [IdeDeclarationAnn]
resolveRef decls ref = case ref of
P.TypeRef tn mdtors ->
- case findRef (\case IdeType name _ -> name == tn; _ -> False) of
+ case findRef (\x -> x ^? _IdeDeclType . ideTypeName <&> (== tn) & fromMaybe False) of
Nothing -> Left ref
Just d -> Right $ d : case mdtors of
Nothing ->
@@ -89,28 +91,23 @@ resolveRef decls ref = case ref of
findDtors tn
Just dtors -> mapMaybe lookupDtor dtors
P.ValueRef i ->
- findWrapped (\case IdeValue i' _ -> i' == i; _ -> False)
- P.TypeOpRef name ->
- findWrapped (\case IdeTypeOperator n _ _ _ _ -> n == name; _ -> False)
+ findWrapped (\x -> x ^? _IdeDeclValue . ideValueIdent <&> (== i) & fromMaybe False)
P.ValueOpRef name ->
- findWrapped (\case IdeValueOperator n _ _ _ _ -> n == name; _ -> False)
+ findWrapped (\x -> x ^? _IdeDeclValueOperator . ideValueOpName <&> (== name) & fromMaybe False)
+ P.TypeOpRef name ->
+ findWrapped (\x -> x ^? _IdeDeclTypeOperator . ideTypeOpName <&> (== name) & fromMaybe False)
P.TypeClassRef name ->
- findWrapped (\case IdeTypeClass n -> n == name; _ -> False)
+ findWrapped (\case IdeDeclTypeClass n -> n == name; _ -> False)
_ ->
Left ref
where
- findWrapped = wrapSingle . findRef
- wrapSingle = maybe (Left ref) (Right . pure)
+ findWrapped = maybe (Left ref) (Right . pure) . findRef
findRef f = find (f . discardAnn) decls
lookupDtor name =
- findRef (\case IdeDataConstructor name' _ _ -> name == name'
- _ -> False)
+ findRef (\x -> x ^? _IdeDeclDataConstructor . ideDtorName <&> (== name) & fromMaybe False)
findDtors tn = filter (f . discardAnn) decls
where
f :: IdeDeclaration -> Bool
- f decl
- | (IdeDataConstructor _ tn' _) <- decl
- , tn == tn' = True
- | otherwise = False
+ f decl = decl ^? _IdeDeclDataConstructor . ideDtorTypeName <&> (== tn) & fromMaybe False
diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs
index 80bd30e..141e011 100644
--- a/src/Language/PureScript/Ide/SourceFile.hs
+++ b/src/Language/PureScript/Ide/SourceFile.hs
@@ -12,7 +12,7 @@
-- Getting declarations from PureScript sourcefiles
-----------------------------------------------------------------------------
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings #-}
module Language.PureScript.Ide.SourceFile
( parseModule
@@ -25,19 +25,19 @@ module Language.PureScript.Ide.SourceFile
import Protolude
-import qualified Data.Map as Map
-import qualified Language.PureScript as P
+import qualified Data.Map as Map
+import qualified Language.PureScript as P
import Language.PureScript.Ide.Error
-import Language.PureScript.Ide.Util
import Language.PureScript.Ide.Types
-import System.IO.UTF8 (readUTF8File)
+import Language.PureScript.Ide.Util
+import System.IO.UTF8 (readUTF8FileT)
parseModule
:: (MonadIO m)
=> FilePath
- -> m (Either FilePath (FilePath, P.Module) )
+ -> m (Either FilePath (FilePath, P.Module))
parseModule path = do
- contents <- liftIO (readUTF8File path)
+ contents <- liftIO (readUTF8FileT path)
case P.parseModuleFromFile identity (path, contents) of
Left _ -> pure (Left path)
Right m -> pure (Right m)
diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs
index d20f045..3a6ddfc 100644
--- a/src/Language/PureScript/Ide/State.hs
+++ b/src/Language/PureScript/Ide/State.hs
@@ -32,20 +32,20 @@ module Language.PureScript.Ide.State
, resolveOperatorsForModule
) where
-import Protolude
import qualified Prelude
+import Protolude
import Control.Concurrent.STM
+import Control.Lens hiding (op, (&))
import "monad-logger" Control.Monad.Logger
-import qualified Data.Map.Lazy as Map
-import qualified Data.List as List
+import qualified Data.Map.Lazy as Map
+import qualified Language.PureScript as P
import Language.PureScript.Externs
import Language.PureScript.Ide.Externs
import Language.PureScript.Ide.Reexports
import Language.PureScript.Ide.SourceFile
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
-import qualified Language.PureScript as P
import System.Clock
-- | Resets all State inside psc-ide
@@ -235,47 +235,39 @@ resolveOperatorsForModule
:: Map P.ModuleName [IdeDeclarationAnn]
-> [IdeDeclarationAnn]
-> [IdeDeclarationAnn]
-resolveOperatorsForModule modules = map (mapIdeDeclaration resolveOperator)
+resolveOperatorsForModule modules = map ((over idaDeclaration) resolveOperator)
where
- resolveOperator (IdeValueOperator
- opName
- i@(P.Qualified (Just moduleName)
- (Left ident)) precedence assoc _) =
- let t = do
- sourceModule <- Map.lookup moduleName modules
- IdeValue _ tP <-
- List.find (\case
- IdeValue iP _ -> iP == ident
- _ -> False) (discardAnn <$> sourceModule)
- pure tP
-
- in IdeValueOperator opName i precedence assoc t
- resolveOperator (IdeValueOperator
- opName
- i@(P.Qualified (Just moduleName)
- (Right ctor)) precedence assoc _) =
- let t = do
- sourceModule <- Map.lookup moduleName modules
- IdeDataConstructor _ _ tP <-
- List.find (\case
- IdeDataConstructor cname _ _ -> ctor == cname
- _ -> False) (discardAnn <$> sourceModule)
- pure tP
-
- in IdeValueOperator opName i precedence assoc t
- resolveOperator (IdeTypeOperator
- opName
- i@(P.Qualified (Just moduleName) properName) precedence assoc _) =
- let k = do
- sourceModule <- Map.lookup moduleName modules
- IdeType _ kP <-
- List.find (\case
- IdeType name _ -> name == properName
- _ -> False) (discardAnn <$> sourceModule)
- pure kP
-
- in IdeTypeOperator opName i precedence assoc k
+ hasName :: Eq b => Lens' a b -> b -> a -> Bool
+ hasName l a x = x ^. l == a
+
+ getDeclarations :: P.ModuleName -> [IdeDeclaration]
+ getDeclarations moduleName =
+ Map.lookup moduleName modules
+ & fromMaybe []
+ & map discardAnn
+
+ resolveOperator (IdeDeclValueOperator op)
+ | (P.Qualified (Just mn) (Left ident)) <- op ^. ideValueOpAlias =
+ let t = getDeclarations mn
+ & mapMaybe (preview _IdeDeclValue)
+ & filter (hasName ideValueIdent ident)
+ & map (view ideValueType)
+ & listToMaybe
+ in IdeDeclValueOperator (op & ideValueOpType .~ t)
+ | (P.Qualified (Just mn) (Right dtor)) <- op ^. ideValueOpAlias =
+ let t = getDeclarations mn
+ & mapMaybe (preview _IdeDeclDataConstructor)
+ & filter (hasName ideDtorName dtor)
+ & map (view ideDtorType)
+ & listToMaybe
+ in IdeDeclValueOperator (op & ideValueOpType .~ t)
+ resolveOperator (IdeDeclTypeOperator op)
+ | P.Qualified (Just mn) properName <- op ^. ideTypeOpAlias =
+ let k = getDeclarations mn
+ & mapMaybe (preview _IdeDeclType)
+ & filter (hasName ideTypeName properName)
+ & map (view ideTypeKind)
+ & listToMaybe
+ in IdeDeclTypeOperator (op & ideTypeOpKind .~ k)
resolveOperator x = x
-mapIdeDeclaration :: (IdeDeclaration -> IdeDeclaration) -> IdeDeclarationAnn -> IdeDeclarationAnn
-mapIdeDeclaration f (IdeDeclarationAnn ann decl) = IdeDeclarationAnn ann (f decl)
diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs
index 56b7550..a9f98aa 100644
--- a/src/Language/PureScript/Ide/Types.hs
+++ b/src/Language/PureScript/Ide/Types.hs
@@ -12,42 +12,93 @@
-- Type definitions for psc-ide
-----------------------------------------------------------------------------
-{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
module Language.PureScript.Ide.Types where
import Protolude
import Control.Concurrent.STM
+import Control.Lens.TH
import Data.Aeson
-import qualified Data.Map.Lazy as M
-import qualified Language.PureScript.Errors.JSON as P
-import qualified Language.PureScript as P
+import qualified Data.Map.Lazy as M
+import qualified Language.PureScript as P
+import qualified Language.PureScript.Errors.JSON as P
import Language.PureScript.Ide.Conversions
type ModuleIdent = Text
data IdeDeclaration
- = IdeValue P.Ident P.Type
- | IdeType (P.ProperName 'P.TypeName) P.Kind
- | IdeTypeSynonym (P.ProperName 'P.TypeName) P.Type
- | IdeDataConstructor (P.ProperName 'P.ConstructorName) (P.ProperName 'P.TypeName) P.Type
- | IdeTypeClass (P.ProperName 'P.ClassName)
- | IdeValueOperator (P.OpName 'P.ValueOpName) (P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName))) P.Precedence P.Associativity (Maybe P.Type)
- | IdeTypeOperator (P.OpName 'P.TypeOpName) (P.Qualified (P.ProperName 'P.TypeName)) P.Precedence P.Associativity (Maybe P.Kind)
+ = IdeDeclValue IdeValue
+ | IdeDeclType IdeType
+ | IdeDeclTypeSynonym IdeSynonym
+ | IdeDeclDataConstructor IdeDataConstructor
+ | IdeDeclTypeClass (P.ProperName 'P.ClassName)
+ | IdeDeclValueOperator IdeValueOperator
+ | IdeDeclTypeOperator IdeTypeOperator
deriving (Show, Eq, Ord)
-data IdeDeclarationAnn = IdeDeclarationAnn Annotation IdeDeclaration
- deriving (Show, Eq, Ord)
+data IdeValue = IdeValue
+ { _ideValueIdent :: P.Ident
+ , _ideValueType :: P.Type
+ } deriving (Show, Eq, Ord)
+
+data IdeType = IdeType
+ { _ideTypeName :: P.ProperName 'P.TypeName
+ , _ideTypeKind :: P.Kind
+ } deriving (Show, Eq, Ord)
+
+data IdeSynonym = IdeSynonym
+ { _ideSynonymName :: P.ProperName 'P.TypeName
+ , _ideSynonymType :: P.Type
+ } deriving (Show, Eq, Ord)
+
+data IdeDataConstructor = IdeDataConstructor
+ { _ideDtorName :: P.ProperName 'P.ConstructorName
+ , _ideDtorTypeName :: P.ProperName 'P.TypeName
+ , _ideDtorType :: P.Type
+ } deriving (Show, Eq, Ord)
+
+data IdeValueOperator = IdeValueOperator
+ { _ideValueOpName :: P.OpName 'P.ValueOpName
+ , _ideValueOpAlias :: P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName))
+ , _ideValueOpPrecedence :: P.Precedence
+ , _ideValueOpAssociativity :: P.Associativity
+ , _ideValueOpType :: Maybe P.Type
+ } deriving (Show, Eq, Ord)
+
+data IdeTypeOperator = IdeTypeOperator
+ { _ideTypeOpName :: P.OpName 'P.TypeOpName
+ , _ideTypeOpAlias :: P.Qualified (P.ProperName 'P.TypeName)
+ , _ideTypeOpPrecedence :: P.Precedence
+ , _ideTypeOpAssociativity :: P.Associativity
+ , _ideTypeOpKind :: Maybe P.Kind
+ } deriving (Show, Eq, Ord)
+
+makePrisms ''IdeDeclaration
+makeLenses ''IdeValue
+makeLenses ''IdeType
+makeLenses ''IdeSynonym
+makeLenses ''IdeDataConstructor
+makeLenses ''IdeValueOperator
+makeLenses ''IdeTypeOperator
+
+data IdeDeclarationAnn = IdeDeclarationAnn
+ { _idaAnnotation :: Annotation
+ , _idaDeclaration :: IdeDeclaration
+ } deriving (Show, Eq, Ord)
data Annotation
= Annotation
- { annLocation :: Maybe P.SourceSpan
- , annExportedFrom :: Maybe P.ModuleName
+ { annLocation :: Maybe P.SourceSpan
+ , annExportedFrom :: Maybe P.ModuleName
, annTypeAnnotation :: Maybe P.Type
} deriving (Show, Eq, Ord)
+makeLenses ''IdeDeclarationAnn
+
emptyAnn :: Annotation
emptyAnn = Annotation Nothing Nothing Nothing
@@ -103,7 +154,7 @@ data Stage2 = Stage2
}
data Stage3 = Stage3
- { s3Declarations :: M.Map P.ModuleName [IdeDeclarationAnn]
+ { s3Declarations :: M.Map P.ModuleName [IdeDeclarationAnn]
, s3CachedRebuild :: Maybe (P.ModuleName, P.ExternsFile)
}
@@ -112,11 +163,11 @@ newtype Match a = Match (P.ModuleName, a)
-- | A completion as it gets sent to the editors
data Completion = Completion
- { complModule :: Text
- , complIdentifier :: Text
- , complType :: Text
- , complExpandedType :: Text
- , complLocation :: Maybe P.SourceSpan
+ { complModule :: Text
+ , complIdentifier :: Text
+ , complType :: Text
+ , complExpandedType :: Text
+ , complLocation :: Maybe P.SourceSpan
, complDocumentation :: Maybe Text
} deriving (Show, Eq)
diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs
index b0bcc30..63d208e 100644
--- a/src/Language/PureScript/Ide/Util.hs
+++ b/src/Language/PureScript/Ide/Util.hs
@@ -29,23 +29,25 @@ module Language.PureScript.Ide.Util
, module Language.PureScript.Ide.Conversions
) where
-import Protolude hiding (decodeUtf8, encodeUtf8)
+import Control.Lens ((^.))
import Data.Aeson
-import qualified Data.Text as T
-import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)
-import qualified Language.PureScript as P
-import Language.PureScript.Ide.Types
+import qualified Data.Text as T
+import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)
+import qualified Language.PureScript as P
import Language.PureScript.Ide.Conversions
+import Language.PureScript.Ide.Types
+import Protolude hiding (decodeUtf8,
+ encodeUtf8)
identifierFromIdeDeclaration :: IdeDeclaration -> Text
identifierFromIdeDeclaration d = case d of
- IdeValue name _ -> runIdentT name
- IdeType name _ -> runProperNameT name
- IdeTypeSynonym name _ -> runProperNameT name
- IdeDataConstructor name _ _ -> runProperNameT name
- IdeTypeClass name -> runProperNameT name
- IdeValueOperator op _ _ _ _ -> runOpNameT op
- IdeTypeOperator op _ _ _ _ -> runOpNameT op
+ IdeDeclValue v -> v ^. ideValueIdent . identT
+ IdeDeclType t -> t ^. ideTypeName . properNameT
+ IdeDeclTypeSynonym s -> s ^. ideSynonymName . properNameT
+ IdeDeclDataConstructor dtor -> dtor ^. ideDtorName . properNameT
+ IdeDeclTypeClass name -> runProperNameT name
+ IdeDeclValueOperator op -> op ^. ideValueOpName & runOpNameT
+ IdeDeclTypeOperator op -> op ^. ideTypeOpName & runOpNameT
discardAnn :: IdeDeclarationAnn -> IdeDeclaration
discardAnn (IdeDeclarationAnn _ d) = d
@@ -61,24 +63,24 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) =
Completion {..}
where
(complIdentifier, complExpandedType) = case decl of
- IdeValue name type' -> (runIdentT name, prettyTypeT type')
- IdeType name kind -> (runProperNameT name, toS (P.prettyPrintKind kind))
- IdeTypeSynonym name kind -> (runProperNameT name, prettyTypeT kind)
- IdeDataConstructor name _ type' -> (runProperNameT name, prettyTypeT type')
- IdeTypeClass name -> (runProperNameT name, "class")
- IdeValueOperator op ref precedence associativity typeP ->
- (runOpNameT op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP)
- IdeTypeOperator op ref precedence associativity kind ->
+ IdeDeclValue v -> (v ^. ideValueIdent . identT, v ^. ideValueType & prettyTypeT)
+ IdeDeclType t -> (t ^. ideTypeName . properNameT, t ^. ideTypeKind & P.prettyPrintKind & toS )
+ IdeDeclTypeSynonym s -> (s ^. ideSynonymName . properNameT, s ^. ideSynonymType & prettyTypeT)
+ IdeDeclDataConstructor d -> (d ^. ideDtorName . properNameT, d ^. ideDtorType & prettyTypeT)
+ IdeDeclTypeClass name -> (runProperNameT name, "class")
+ IdeDeclValueOperator (IdeValueOperator op ref precedence associativity typeP) ->
+ (runOpNameT op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP)
+ IdeDeclTypeOperator (IdeTypeOperator op ref precedence associativity kind) ->
(runOpNameT op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) (toS . P.prettyPrintKind) kind)
-
+
complModule = runModuleNameT m
complType = maybe complExpandedType prettyTypeT (annTypeAnnotation ann)
-
+
complLocation = annLocation ann
complDocumentation = Nothing
-
+
showFixity p a r o =
let asso = case a of
P.Infix -> "infix"
@@ -95,7 +97,7 @@ typeOperatorAliasT
:: P.Qualified (P.ProperName 'P.TypeName) -> Text
typeOperatorAliasT i =
toS (P.showQualified P.runProperName i)
-
+
encodeT :: (ToJSON a) => a -> Text
encodeT = toS . decodeUtf8 . encode
diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs
index 49f0a73..e9534e3 100644
--- a/src/Language/PureScript/Interactive.hs
+++ b/src/Language/PureScript/Interactive.hs
@@ -104,7 +104,7 @@ handleCommand _ _ (KindOf typ) = handleKindOf typ
handleCommand _ _ (BrowseModule moduleName) = handleBrowse moduleName
handleCommand _ _ (ShowInfo QueryLoaded) = handleShowLoadedModules
handleCommand _ _ (ShowInfo QueryImport) = handleShowImportedModules
-handleCommand _ _ QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug."
+handleCommand _ _ _ = P.internalError "handleCommand: unexpected command"
-- | Reset the application state
handleResetState
diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs
index f08f9fb..5a875c7 100644
--- a/src/Language/PureScript/Interactive/Completion.hs
+++ b/src/Language/PureScript/Interactive/Completion.hs
@@ -122,6 +122,7 @@ directiveArg _ Browse = [CtxModule]
directiveArg _ Quit = []
directiveArg _ Reset = []
directiveArg _ Help = []
+directiveArg _ Paste = []
directiveArg _ Show = map CtxFixed replQueryStrings
directiveArg _ Type = [CtxIdentifier]
directiveArg _ Kind = [CtxType]
diff --git a/src/Language/PureScript/Interactive/Directive.hs b/src/Language/PureScript/Interactive/Directive.hs
index f9d7c6c..8f204a3 100644
--- a/src/Language/PureScript/Interactive/Directive.hs
+++ b/src/Language/PureScript/Interactive/Directive.hs
@@ -30,6 +30,7 @@ directiveStrings =
, (Type , ["type"])
, (Kind , ["kind"])
, (Show , ["show"])
+ , (Paste , ["paste"])
]
-- |
@@ -82,6 +83,7 @@ hasArgument :: Directive -> Bool
hasArgument Help = False
hasArgument Quit = False
hasArgument Reset = False
+hasArgument Paste = False
hasArgument _ = True
-- |
@@ -97,4 +99,5 @@ help =
, (Kind, "<type>", "Show the kind of <type>")
, (Show, "import", "Show all imported modules")
, (Show, "loaded", "Show all loaded modules")
+ , (Paste, "paste", "Enter multiple lines, terminated by ^D")
]
diff --git a/src/Language/PureScript/Interactive/IO.hs b/src/Language/PureScript/Interactive/IO.hs
index e120ec3..17c4183 100644
--- a/src/Language/PureScript/Interactive/IO.hs
+++ b/src/Language/PureScript/Interactive/IO.hs
@@ -1,11 +1,11 @@
-module Language.PureScript.Interactive.IO where
+module Language.PureScript.Interactive.IO (findNodeProcess, getHistoryFilename) where
import Prelude.Compat
import Control.Monad (msum)
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
import System.Directory (createDirectoryIfMissing, getHomeDirectory, findExecutable)
-import System.FilePath (takeDirectory, (</>), isPathSeparator)
+import System.FilePath (takeDirectory, (</>))
mkdirp :: FilePath -> IO ()
mkdirp = createDirectoryIfMissing True . takeDirectory
@@ -32,10 +32,3 @@ getHistoryFilename = do
let filename = home </> ".purescript" </> "psci_history"
mkdirp filename
return filename
-
--- |
--- Expands tilde in path.
---
-expandTilde :: FilePath -> IO FilePath
-expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory
-expandTilde p = return p
diff --git a/src/Language/PureScript/Interactive/Message.hs b/src/Language/PureScript/Interactive/Message.hs
index 22ea272..97ef4cb 100644
--- a/src/Language/PureScript/Interactive/Message.hs
+++ b/src/Language/PureScript/Interactive/Message.hs
@@ -39,11 +39,15 @@ prologueMessage = unlines
supportModuleMessage :: String
supportModuleMessage = unlines
- [ "PSCi requires the purescript-psci-support package to be installed."
+ [ "PSCi requires the psci-support package to be installed."
, "You can install it using Bower as follows:"
, ""
, " bower i purescript-psci-support --save-dev"
, ""
+ , "Or using psc-package:"
+ , ""
+ , " psc-package install psci-support"
+ , ""
, "For help getting started, visit http://wiki.purescript.org/PSCi"
]
diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs
index b8a61db..3b53646 100644
--- a/src/Language/PureScript/Interactive/Module.hs
+++ b/src/Language/PureScript/Interactive/Module.hs
@@ -6,7 +6,7 @@ import Control.Monad
import qualified Language.PureScript as P
import Language.PureScript.Interactive.Types
import System.FilePath (pathSeparator)
-import System.IO.UTF8 (readUTF8File)
+import System.IO.UTF8 (readUTF8FileT)
-- * Support Module
@@ -25,7 +25,7 @@ supportModuleIsDefined = any ((== supportModuleName) . P.getModuleName)
--
loadModule :: FilePath -> IO (Either String [P.Module])
loadModule filename = do
- content <- readUTF8File filename
+ content <- readUTF8FileT filename
return $ either (Left . P.prettyPrintMultipleErrors P.defaultPPEOptions) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]
-- |
@@ -34,7 +34,7 @@ loadModule filename = do
loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)])
loadAllModules files = do
filesAndContent <- forM files $ \filename -> do
- content <- readUTF8File filename
+ content <- readUTF8FileT filename
return (filename, content)
return $ P.parseModulesFromFiles id filesAndContent
diff --git a/src/Language/PureScript/Interactive/Parser.hs b/src/Language/PureScript/Interactive/Parser.hs
index 86d6606..c4397f3 100644
--- a/src/Language/PureScript/Interactive/Parser.hs
+++ b/src/Language/PureScript/Interactive/Parser.hs
@@ -62,6 +62,7 @@ parseDirective cmd =
Help -> return ShowHelp
Quit -> return QuitPSCi
Reset -> return ResetState
+ Paste -> return PasteLines
Browse -> BrowseModule <$> parseRest P.moduleName arg
Show -> ShowInfo <$> parseReplQuery' (trim arg)
Type -> TypeOf <$> parseRest P.parseValue arg
diff --git a/src/Language/PureScript/Interactive/Types.hs b/src/Language/PureScript/Interactive/Types.hs
index f2449df..61dfe14 100644
--- a/src/Language/PureScript/Interactive/Types.hs
+++ b/src/Language/PureScript/Interactive/Types.hs
@@ -72,46 +72,28 @@ updateLets f st = st { psciLetBindings = f (psciLetBindings st) }
-- Valid Meta-commands for PSCI
--
data Command
- -- |
- -- A purescript expression
- --
+ -- | A purescript expression
= Expression P.Expr
- -- |
- -- Show the help (ie, list of directives)
- --
+ -- | Show the help (ie, list of directives)
| ShowHelp
- -- |
- -- Import a module from a loaded file
- --
+ -- | Import a module from a loaded file
| Import ImportedModule
- -- |
- -- Browse a module
- --
+ -- | Browse a module
| BrowseModule P.ModuleName
- -- |
- -- Exit PSCI
- --
+ -- | Exit PSCI
| QuitPSCi
- -- |
- -- Reset the state of the REPL
- --
+ -- | Reset the state of the REPL
| ResetState
- -- |
- -- Add some declarations to the current evaluation context.
- --
+ -- | Add some declarations to the current evaluation context
| Decls [P.Declaration]
- -- |
- -- Find the type of an expression
- --
+ -- | Find the type of an expression
| TypeOf P.Expr
- -- |
- -- Find the kind of an expression
- --
+ -- | Find the kind of an expression
| KindOf P.Type
- -- |
- -- Shows information about the current state of the REPL
- --
+ -- | Shows information about the current state of the REPL
| ShowInfo ReplQuery
+ -- | Paste multiple lines
+ | PasteLines
data ReplQuery
= QueryLoaded
@@ -142,4 +124,5 @@ data Directive
| Type
| Kind
| Show
+ | Paste
deriving (Eq, Show)
diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs
index fceea2a..7db7706 100644
--- a/src/Language/PureScript/Linter/Imports.hs
+++ b/src/Language/PureScript/Linter/Imports.hs
@@ -308,7 +308,7 @@ findUsedRefs env mni qn names =
typesRefs
= map (flip TypeRef (Just [])) typesWithoutDctors
++ map (\(ty, ds) -> TypeRef ty (Just ds)) (M.toList typesWithDctors)
- in classRefs ++ typeOpRefs ++ typesRefs ++ valueRefs ++ valueOpRefs
+ in sortBy compDecRef $ classRefs ++ typeOpRefs ++ typesRefs ++ valueRefs ++ valueOpRefs
where
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 99d4672..668231b 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -149,7 +149,7 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do
lint withPrim
((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do
[desugared] <- desugar externs [withPrim]
- runCheck' env $ typeCheckModule desugared
+ runCheck' (emptyCheckState env) $ typeCheckModule desugared
regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated
let mod' = Module ss coms moduleName regrouped exps
corefn = CF.moduleToCoreFn env' mod'
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index b7f530e..e786a50 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -29,6 +29,12 @@ typeName :: TokenParser (ProperName 'TypeName)
typeName = ProperName <$> tyname
-- |
+-- Parse a proper name for a data constructor.
+--
+dataConstructorName :: TokenParser (ProperName 'ConstructorName)
+dataConstructorName = ProperName <$> dconsname
+
+-- |
-- Parse a module name
--
moduleName :: TokenParser ModuleName
@@ -107,23 +113,26 @@ mark p = do
-- |
-- Check that the current identation level matches a predicate
--
-checkIndentation :: (P.Column -> P.Column -> Bool) -> P.Parsec s ParseState ()
-checkIndentation rel = do
+checkIndentation
+ :: (P.Column -> String)
+ -> (P.Column -> P.Column -> Bool)
+ -> P.Parsec s ParseState ()
+checkIndentation mkMsg rel = do
col <- P.sourceColumn <$> P.getPosition
current <- indentationLevel <$> P.getState
- guard (col `rel` current)
+ guard (col `rel` current) P.<?> mkMsg current
-- |
-- Check that the current indentation level is past the current mark
--
indented :: P.Parsec s ParseState ()
-indented = checkIndentation (>) P.<?> "indentation"
+indented = checkIndentation (("indentation past column " ++) . show) (>)
-- |
-- Check that the current indentation level is at the same indentation as the current mark
--
same :: P.Parsec s ParseState ()
-same = checkIndentation (==) P.<?> "no indentation"
+same = checkIndentation (("indentation at column " ++) . show) (==)
-- |
-- Read the comments from the the next token, without consuming it
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index e192eee..4b505b3 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -19,6 +19,7 @@ import Prelude hiding (lex)
import Data.Functor (($>))
import Data.Maybe (fromMaybe)
+import Data.Text (Text)
import Control.Applicative
import Control.Arrow ((+++))
@@ -71,7 +72,7 @@ parseDataDeclaration = do
tyArgs <- many (indented *> kindedIdent)
ctors <- P.option [] $ do
indented *> equals
- P.sepBy1 ((,) <$> properName <*> P.many (indented *> noWildcards parseTypeAtom)) pipe
+ P.sepBy1 ((,) <$> dataConstructorName <*> P.many (indented *> noWildcards parseTypeAtom)) pipe
return $ DataDeclaration dtype name tyArgs ctors
parseTypeDeclaration :: TokenParser Declaration
@@ -281,7 +282,7 @@ parseModulesFromFiles
:: forall m k
. MonadError MultipleErrors m
=> (k -> FilePath)
- -> [(k, String)]
+ -> [(k, Text)]
-> m [(k, Module)]
parseModulesFromFiles toFilePath input =
flip parU wrapError . inParallel . flip map input $ parseModuleFromFile toFilePath
@@ -298,11 +299,11 @@ parseModulesFromFiles toFilePath input =
-- | Parses a single module with FilePath for eventual parsing errors
parseModuleFromFile
:: (k -> FilePath)
- -> (k, String)
+ -> (k, Text)
-> Either P.ParseError (k, Module)
parseModuleFromFile toFilePath (k, content) = do
let filename = toFilePath k
- ts <- lex filename content
+ ts <- lex' filename content
m <- runTokenParser filename parseModule ts
pure (k, m)
@@ -360,7 +361,7 @@ parseVar :: TokenParser Expr
parseVar = Var <$> C.parseQualified C.parseIdent
parseConstructor :: TokenParser Expr
-parseConstructor = Constructor <$> C.parseQualified C.properName
+parseConstructor = Constructor <$> C.parseQualified C.dataConstructorName
parseCase :: TokenParser Expr
parseCase = Case <$> P.between (reserved "case") (C.indented *> reserved "of") (commaSep1 parseValue)
@@ -494,10 +495,10 @@ parseNumberLiteral = LiteralBinder . NumericLiteral <$> (sign <*> number)
<|> return id
parseNullaryConstructorBinder :: TokenParser Binder
-parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> pure []
+parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.dataConstructorName <*> pure []
parseConstructorBinder :: TokenParser Binder
-parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> many (C.indented *> parseBinderNoParens)
+parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.dataConstructorName <*> many (C.indented *> parseBinderNoParens)
parseObjectBinder:: TokenParser Binder
parseObjectBinder = LiteralBinder <$> parseObjectLiteral (C.indented *> parseIdentifierAndBinder)
diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs
index 2962fe1..286bb73 100644
--- a/src/Language/PureScript/Parser/Lexer.hs
+++ b/src/Language/PureScript/Parser/Lexer.hs
@@ -6,6 +6,7 @@ module Language.PureScript.Parser.Lexer
, Token()
, TokenParser()
, lex
+ , lex'
, anyToken
, token
, match
@@ -43,6 +44,7 @@ module Language.PureScript.Parser.Lexer
, lname'
, qualifier
, tyname
+ , dconsname
, uname
, uname'
, mname
@@ -68,6 +70,8 @@ import Control.Monad (void, guard)
import Data.Char (isSpace, isAscii, isSymbol, isAlphaNum)
import Data.Functor.Identity
+import Data.Text (Text)
+import qualified Data.Text as T
import Language.PureScript.Comments
import Language.PureScript.Parser.State
@@ -153,8 +157,13 @@ data PositionedToken = PositionedToken
instance Show PositionedToken where
show = prettyPrintToken . ptToken
+type Lexer u a = P.Parsec Text u a
+
lex :: FilePath -> String -> Either P.ParseError [PositionedToken]
-lex f s = updatePositions <$> P.parse parseTokens f s
+lex fp = lex' fp . T.pack
+
+lex' :: FilePath -> Text -> Either P.ParseError [PositionedToken]
+lex' f s = updatePositions <$> P.parse parseTokens f s
updatePositions :: [PositionedToken] -> [PositionedToken]
updatePositions [] = []
@@ -162,22 +171,22 @@ updatePositions (x:xs) = x : zipWith update (x:xs) xs
where
update PositionedToken { ptEndPos = pos } pt = pt { ptPrevEndPos = Just pos }
-parseTokens :: P.Parsec String u [PositionedToken]
+parseTokens :: Lexer u [PositionedToken]
parseTokens = whitespace *> P.many parsePositionedToken <* P.skipMany parseComment <* P.eof
-whitespace :: P.Parsec String u ()
+whitespace :: Lexer u ()
whitespace = P.skipMany (P.satisfy isSpace)
-parseComment :: P.Parsec String u Comment
+parseComment :: Lexer u Comment
parseComment = (BlockComment <$> blockComment <|> LineComment <$> lineComment) <* whitespace
where
- blockComment :: P.Parsec String u String
+ blockComment :: Lexer u String
blockComment = P.try $ P.string "{-" *> P.manyTill P.anyChar (P.try (P.string "-}"))
- lineComment :: P.Parsec String u String
+ lineComment :: Lexer u String
lineComment = P.try $ P.string "--" *> P.manyTill P.anyChar (P.try (void (P.char '\n') <|> P.eof))
-parsePositionedToken :: P.Parsec String u PositionedToken
+parsePositionedToken :: Lexer u PositionedToken
parsePositionedToken = P.try $ do
comments <- P.many parseComment
pos <- P.getPosition
@@ -186,7 +195,7 @@ parsePositionedToken = P.try $ do
whitespace
return $ PositionedToken pos pos' Nothing tok comments
-parseToken :: P.Parsec String u Token
+parseToken :: Lexer u Token
parseToken = P.choice
[ P.try $ P.string "<-" *> P.notFollowedBy symbolChar *> pure LArrow
, P.try $ P.string "←" *> P.notFollowedBy symbolChar *> pure LArrow
@@ -225,34 +234,34 @@ parseToken = P.choice
]
where
- parseLName :: P.Parsec String u String
+ parseLName :: Lexer u String
parseLName = (:) <$> identStart <*> P.many identLetter
- parseUName :: P.Parsec String u String
+ parseUName :: Lexer u String
parseUName = (:) <$> P.upper <*> P.many identLetter
- parseSymbol :: P.Parsec String u String
+ parseSymbol :: Lexer u String
parseSymbol = P.many1 symbolChar
- identStart :: P.Parsec String u Char
+ identStart :: Lexer u Char
identStart = P.lower <|> P.oneOf "_"
- identLetter :: P.Parsec String u Char
+ identLetter :: Lexer u Char
identLetter = P.alphaNum <|> P.oneOf "_'"
- symbolChar :: P.Parsec String u Char
+ symbolChar :: Lexer u Char
symbolChar = P.satisfy isSymbolChar
- parseCharLiteral :: P.Parsec String u Char
+ parseCharLiteral :: Lexer u Char
parseCharLiteral = PT.charLiteral tokenParser
- parseStringLiteral :: P.Parsec String u String
+ parseStringLiteral :: Lexer u String
parseStringLiteral = blockString <|> PT.stringLiteral tokenParser
where
delimiter = P.try (P.string "\"\"\"")
blockString = delimiter >> P.manyTill P.anyChar delimiter
- parseNumber :: P.Parsec String u (Either Integer Double)
+ parseNumber :: Lexer u (Either Integer Double)
parseNumber = (consumeLeadingZero >> P.parserZero) <|>
(Right <$> P.try (PT.float tokenParser) <|>
Left <$> P.try (PT.natural tokenParser))
@@ -266,7 +275,7 @@ parseToken = P.choice
-- |
-- We use Text.Parsec.Token to implement the string and number lexemes
--
-langDef :: PT.GenLanguageDef String u Identity
+langDef :: PT.GenLanguageDef Text u Identity
langDef = PT.LanguageDef
{ PT.reservedNames = []
, PT.reservedOpNames = []
@@ -284,7 +293,7 @@ langDef = PT.LanguageDef
-- |
-- A token parser based on the language definition
--
-tokenParser :: PT.GenTokenParser String u Identity
+tokenParser :: PT.GenTokenParser Text u Identity
tokenParser = PT.makeTokenParser langDef
type TokenParser a = P.Parsec [PositionedToken] ParseState a
@@ -452,6 +461,12 @@ tyname = token go P.<?> "type name"
go (UName s) = Just s
go _ = Nothing
+dconsname :: TokenParser String
+dconsname = token go P.<?> "data constructor name"
+ where
+ go (UName s) = Just s
+ go _ = Nothing
+
mname :: TokenParser String
mname = token go P.<?> "module name"
where
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
index 8583450..1233dc2 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -3,7 +3,9 @@
--
module Language.PureScript.Pretty.Types
( typeAsBox
+ , suggestedTypeAsBox
, prettyPrintType
+ , prettyPrintSuggestedType
, typeAtomAsBox
, prettyPrintTypeAtom
, prettyPrintRowWith
@@ -27,23 +29,6 @@ import Language.PureScript.Types
import Text.PrettyPrint.Boxes hiding ((<+>))
-typeLiterals :: Pattern () Type Box
-typeLiterals = mkPattern match
- where
- match TypeWildcard{} = Just $ text "_"
- match (TypeVar var) = Just $ text var
- match (TypeLevelString s) = Just . text $ show s
- match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row
- match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor
- match (TUnknown u) = Just $ text $ 't' : show u
- match (Skolem name s _ _) = Just $ text $ name ++ show s
- match REmpty = Just $ text "()"
- match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row
- match (BinaryNoParensType op l r) =
- Just $ typeAsBox l <> text " " <> typeAsBox op <> text " " <> typeAsBox r
- match (TypeOp op) = Just $ text $ showQualified runOpName op
- match _ = Nothing
-
constraintsAsBox :: [Constraint] -> Box -> Box
constraintsAsBox [con] ty = text "(" <> constraintAsBox con `before` (text ") => " <> ty)
constraintsAsBox xs ty = vcat left (zipWith (\i con -> text (if i == 0 then "( " else ", ") <> constraintAsBox con) [0 :: Int ..] xs) `before` (text ") => " <> ty)
@@ -120,12 +105,32 @@ explicitParens = mkPattern match
match (ParensInType ty) = Just ((), ty)
match _ = Nothing
-matchTypeAtom :: Pattern () Type Box
-matchTypeAtom = typeLiterals <+> fmap ((`before` (text ")")) . (text "(" <>)) matchType
-
-matchType :: Pattern () Type Box
-matchType = buildPrettyPrinter operators matchTypeAtom
+matchTypeAtom :: Bool -> Pattern () Type Box
+matchTypeAtom suggesting =
+ typeLiterals <+> fmap ((`before` (text ")")) . (text "(" <>)) (matchType suggesting)
where
+ typeLiterals :: Pattern () Type Box
+ typeLiterals = mkPattern match where
+ match TypeWildcard{} = Just $ text "_"
+ match (TypeVar var) = Just $ text var
+ match (TypeLevelString s) = Just . text $ show s
+ match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row
+ match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor
+ match (TUnknown u)
+ | suggesting = Just $ text "_"
+ | otherwise = Just $ text $ 't' : show u
+ match (Skolem name s _ _)
+ | suggesting = Just $ text name
+ | otherwise = Just $ text $ name ++ show s
+ match REmpty = Just $ text "()"
+ match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row
+ match (BinaryNoParensType op l r) =
+ Just $ typeAsBox l <> text " " <> typeAsBox op <> text " " <> typeAsBox r
+ match (TypeOp op) = Just $ text $ showQualified runOpName op
+ match _ = Nothing
+
+matchType :: Bool -> Pattern () Type Box
+matchType = buildPrettyPrinter operators . matchTypeAtom where
operators :: OperatorTable () Type Box
operators =
OperatorTable [ [ AssocL typeApp $ \f x -> keepSingleLinesOr (moveRight 2) f x ]
@@ -152,7 +157,7 @@ forall_ = mkPattern match
typeAtomAsBox :: Type -> Box
typeAtomAsBox
= fromMaybe (internalError "Incomplete pattern")
- . PA.pattern matchTypeAtom ()
+ . PA.pattern (matchTypeAtom False) ()
. insertPlaceholders
-- | Generate a pretty-printed string representing a Type, as it should appear inside parentheses
@@ -160,11 +165,21 @@ prettyPrintTypeAtom :: Type -> String
prettyPrintTypeAtom = render . typeAtomAsBox
typeAsBox :: Type -> Box
-typeAsBox
+typeAsBox = typeAsBoxImpl False
+
+suggestedTypeAsBox :: Type -> Box
+suggestedTypeAsBox = typeAsBoxImpl True
+
+typeAsBoxImpl :: Bool -> Type -> Box
+typeAsBoxImpl suggesting
= fromMaybe (internalError "Incomplete pattern")
- . PA.pattern matchType ()
+ . PA.pattern (matchType suggesting) ()
. insertPlaceholders
--- | Generate a pretty-printed string representing a Type
+-- | Generate a pretty-printed string representing a 'Type'
prettyPrintType :: Type -> String
-prettyPrintType = render . typeAsBox
+prettyPrintType = render . typeAsBoxImpl False
+
+-- | Generate a pretty-printed string representing a suggested 'Type'
+prettyPrintSuggestedType :: Type -> String
+prettyPrintSuggestedType = render . typeAsBoxImpl True
diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
index a833465..95dab22 100755
--- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
@@ -13,7 +13,7 @@ import Control.Monad (replicateM)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Supply.Class (MonadSupply)
-import Data.List (foldl', find, sortBy)
+import Data.List (foldl', find, sortBy, unzip5)
import Data.Maybe (fromMaybe)
import Data.Ord (comparing)
@@ -58,9 +58,14 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className [wrappedTy, unwr
| className == Qualified (Just dataNewtype) (ProperName "Newtype")
, Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy
, mn == fromMaybe mn mn'
- = do
- (inst, actualUnwrappedTy) <- deriveNewtype mn ds tyCon args unwrappedTy
- return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst)
+ = do (inst, actualUnwrappedTy) <- deriveNewtype mn ds tyCon args unwrappedTy
+ return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst)
+deriveInstance mn ds (TypeInstanceDeclaration nm deps className [actualTy, repTy] DerivedInstance)
+ | className == Qualified (Just dataGenericRep) (ProperName C.generic)
+ , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor actualTy
+ , mn == fromMaybe mn mn'
+ = do (inst, inferredRepTy) <- deriveGenericRep mn ds tyCon args repTy
+ return $ TypeInstanceDeclaration nm deps className [actualTy, inferredRepTy] (ExplicitInstance inst)
deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
= throwError . errorMessage $ CannotDerive className tys
deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@(_ : _) NewtypeInstance)
@@ -122,6 +127,9 @@ deriveNewtypeInstance className ds tys tyConNm dargs = do
dataGeneric :: ModuleName
dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]
+dataGenericRep :: ModuleName
+dataGenericRep = ModuleName [ ProperName "Data", ProperName "Generic", ProperName "Rep" ]
+
dataMaybe :: ModuleName
dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]
@@ -304,6 +312,187 @@ deriveGeneric mn ds tyConNm dargs = do
mkGenVar :: Ident -> Expr
mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic]))
+deriveGenericRep
+ :: forall m
+ . (MonadError MultipleErrors m, MonadSupply m)
+ => ModuleName
+ -> [Declaration]
+ -> ProperName 'TypeName
+ -> [Type]
+ -> Type
+ -> m ([Declaration], Type)
+deriveGenericRep mn ds tyConNm tyConArgs repTy = do
+ checkIsWildcard tyConNm repTy
+ go =<< findTypeDecl tyConNm ds
+ where
+ go :: Declaration -> m ([Declaration], Type)
+ go (DataDeclaration _ _ args dctors) = do
+ x <- freshIdent "x"
+ (reps, to, from) <- unzip3 <$> traverse makeInst dctors
+ let rep = toRepTy reps
+ inst | null reps =
+ -- If there are no cases, spin
+ [ ValueDeclaration (Ident "to") Public [] $ Right $
+ lamCase x [ CaseAlternative [NullBinder]
+ (Right (App toName (Var (Qualified Nothing x))))
+ ]
+ , ValueDeclaration (Ident "from") Public [] $ Right $
+ lamCase x [ CaseAlternative [NullBinder]
+ (Right (App fromName (Var (Qualified Nothing x))))
+ ]
+ ]
+ | otherwise =
+ [ ValueDeclaration (Ident "to") Public [] $ Right $
+ lamCase x (zipWith ($) (map underBinder (sumBinders (length dctors))) to)
+ , ValueDeclaration (Ident "from") Public [] $ Right $
+ lamCase x (zipWith ($) (map underExpr (sumExprs (length dctors))) from)
+ ]
+
+ subst = zipWith ((,) . fst) args tyConArgs
+ return (inst, replaceAllTypeVars subst rep)
+ go (PositionedDeclaration _ _ d) = go d
+ go _ = internalError "deriveGenericRep go: expected DataDeclaration"
+
+ select :: (a -> a) -> (a -> a) -> Int -> [a -> a]
+ select _ _ 0 = []
+ select _ _ 1 = [id]
+ select l r n = take (n - 1) (iterate (r .) l) ++ [compN (n - 1) r]
+
+ sumBinders :: Int -> [Binder -> Binder]
+ sumBinders = select (ConstructorBinder inl . pure) (ConstructorBinder inr . pure)
+
+ sumExprs :: Int -> [Expr -> Expr]
+ sumExprs = select (App (Constructor inl)) (App (Constructor inr))
+
+ compN :: Int -> (a -> a) -> a -> a
+ compN 0 _ = id
+ compN n f = f . compN (n - 1) f
+
+ makeInst
+ :: (ProperName 'ConstructorName, [Type])
+ -> m (Type, CaseAlternative, CaseAlternative)
+ makeInst (ctorName, args) = do
+ (ctorTy, matchProduct, ctorArgs, matchCtor, mkProduct) <- makeProduct args
+ return ( TypeApp (TypeApp (TypeConstructor constructor)
+ (TypeLevelString (runProperName ctorName)))
+ ctorTy
+ , CaseAlternative [ ConstructorBinder constructor [matchProduct] ]
+ (Right (foldl App (Constructor (Qualified (Just mn) ctorName)) ctorArgs))
+ , CaseAlternative [ ConstructorBinder (Qualified (Just mn) ctorName) matchCtor ]
+ (Right (constructor' mkProduct))
+ )
+
+ makeProduct
+ :: [Type]
+ -> m (Type, Binder, [Expr], [Binder], Expr)
+ makeProduct [] =
+ pure (noArgs, NullBinder, [], [], noArgs')
+ makeProduct args = do
+ (tys, bs1, es1, bs2, es2) <- unzip5 <$> traverse makeArg args
+ pure ( foldr1 (\f -> TypeApp (TypeApp (TypeConstructor productName) f)) tys
+ , foldr1 (\b1 b2 -> ConstructorBinder productName [b1, b2]) bs1
+ , es1
+ , bs2
+ , foldr1 (\e1 -> App (App (Constructor productName) e1)) es2
+ )
+
+ makeArg :: Type -> m (Type, Binder, Expr, Binder, Expr)
+ makeArg arg | Just rec <- objectType arg = do
+ let fields = decomposeRec rec
+ fieldNames <- traverse freshIdent (map fst fields)
+ pure ( TypeApp (TypeConstructor record)
+ (foldr1 (\f -> TypeApp (TypeApp (TypeConstructor productName) f))
+ (map (\(name, ty) ->
+ TypeApp (TypeApp (TypeConstructor field) (TypeLevelString name)) ty) fields))
+ , ConstructorBinder record
+ [ foldr1 (\b1 b2 -> ConstructorBinder productName [b1, b2])
+ (map (\ident -> ConstructorBinder field [VarBinder ident]) fieldNames)
+ ]
+ , Literal . ObjectLiteral $
+ zipWith (\(name, _) ident -> (name, Var (Qualified Nothing ident))) fields fieldNames
+ , LiteralBinder . ObjectLiteral $
+ zipWith (\(name, _) ident -> (name, VarBinder ident)) fields fieldNames
+ , record' $
+ foldr1 (\e1 -> App (App (Constructor productName) e1))
+ (map (field' . Var . Qualified Nothing) fieldNames)
+ )
+ makeArg arg = do
+ argName <- freshIdent "arg"
+ pure ( TypeApp (TypeConstructor argument) arg
+ , ConstructorBinder argument [ VarBinder argName ]
+ , Var (Qualified Nothing argName)
+ , VarBinder argName
+ , argument' (Var (Qualified Nothing argName))
+ )
+
+ underBinder :: (Binder -> Binder) -> CaseAlternative -> CaseAlternative
+ underBinder f (CaseAlternative bs e) = CaseAlternative (map f bs) e
+
+ underExpr :: (Expr -> Expr) -> CaseAlternative -> CaseAlternative
+ underExpr f (CaseAlternative b (Right e)) = CaseAlternative b (Right (f e))
+ underExpr _ _ = internalError "underExpr: expected Right"
+
+ toRepTy :: [Type] -> Type
+ toRepTy [] = noCtors
+ toRepTy [only] = only
+ toRepTy ctors = foldr1 (\f -> TypeApp (TypeApp sumCtor f)) ctors
+
+ toName :: Expr
+ toName = Var (Qualified (Just dataGenericRep) (Ident "to"))
+
+ fromName :: Expr
+ fromName = Var (Qualified (Just dataGenericRep) (Ident "from"))
+
+ noCtors :: Type
+ noCtors = TypeConstructor (Qualified (Just dataGenericRep) (ProperName "NoConstructors"))
+
+ noArgs :: Type
+ noArgs = TypeConstructor (Qualified (Just dataGenericRep) (ProperName "NoArguments"))
+
+ noArgs' :: Expr
+ noArgs' = Constructor (Qualified (Just dataGenericRep) (ProperName "NoArguments"))
+
+ sumCtor :: Type
+ sumCtor = TypeConstructor (Qualified (Just dataGenericRep) (ProperName "Sum"))
+
+ inl :: Qualified (ProperName 'ConstructorName)
+ inl = Qualified (Just dataGenericRep) (ProperName "Inl")
+
+ inr :: Qualified (ProperName 'ConstructorName)
+ inr = Qualified (Just dataGenericRep) (ProperName "Inr")
+
+ productName :: Qualified (ProperName ty)
+ productName = Qualified (Just dataGenericRep) (ProperName "Product")
+
+ constructor :: Qualified (ProperName ty)
+ constructor = Qualified (Just dataGenericRep) (ProperName "Constructor")
+
+ constructor' :: Expr -> Expr
+ constructor' = App (Constructor constructor)
+
+ argument :: Qualified (ProperName ty)
+ argument = Qualified (Just dataGenericRep) (ProperName "Argument")
+
+ argument' :: Expr -> Expr
+ argument' = App (Constructor argument)
+
+ record :: Qualified (ProperName ty)
+ record = Qualified (Just dataGenericRep) (ProperName "Rec")
+
+ record' :: Expr -> Expr
+ record' = App (Constructor record)
+
+ field :: Qualified (ProperName ty)
+ field = Qualified (Just dataGenericRep) (ProperName "Field")
+
+ field' :: Expr -> Expr
+ field' = App (Constructor field)
+
+checkIsWildcard :: MonadError MultipleErrors m => ProperName 'TypeName -> Type -> m ()
+checkIsWildcard _ (TypeWildcard _) = return ()
+checkIsWildcard tyConNm _ =
+ throwError . errorMessage $ ExpectedWildcard tyConNm
+
deriveEq ::
forall m. (MonadError MultipleErrors m, MonadSupply m)
=> ModuleName
@@ -451,7 +640,7 @@ deriveNewtype
-> Type
-> m ([Declaration], Type)
deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do
- checkIsWildcard unwrappedTy
+ checkIsWildcard tyConNm unwrappedTy
go =<< findTypeDecl tyConNm ds
where
go :: Declaration -> m ([Declaration], Type)
@@ -477,12 +666,6 @@ deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do
go (PositionedDeclaration _ _ d) = go d
go _ = internalError "deriveNewtype go: expected DataDeclaration"
- checkIsWildcard :: Type -> m ()
- checkIsWildcard (TypeWildcard _) =
- return ()
- checkIsWildcard _ =
- throwError . errorMessage $ NonWildcardNewtypeInstance tyConNm
-
findTypeDecl
:: (MonadError MultipleErrors m)
=> ProperName 'TypeName
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 62e4559..6ffca1f 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -11,7 +11,7 @@ module Language.PureScript.TypeChecker
import Prelude.Compat
-import Control.Monad (when, unless, void, forM, forM_)
+import Control.Monad (when, unless, void, forM)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.State.Class (MonadState(..), modify)
import Control.Monad.Supply.Class (MonadSupply)
@@ -279,7 +279,6 @@ typeCheckAll moduleName _ = traverse go
return d
go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do
traverse_ (checkTypeClassInstance moduleName) tys
- forM_ deps $ traverse_ (checkTypeClassInstance moduleName) . constraintArgs
checkOrphanInstance dictName className tys
_ <- traverseTypeInstanceBody checkInstanceMembers body
let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps)
@@ -313,6 +312,7 @@ typeCheckAll moduleName _ = traverse go
where
checkType :: Type -> Bool
checkType (TypeVar _) = False
+ checkType (TypeLevelString _) = False
checkType (TypeConstructor (Qualified (Just mn'') _)) = moduleName == mn''
checkType (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in checkOrphanInstance"
checkType (TypeApp t1 _) = checkType t1
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
index 7b03c70..01f9fab 100644
--- a/src/Language/PureScript/TypeChecker/Entailment.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -5,8 +5,10 @@
--
module Language.PureScript.TypeChecker.Entailment
( InstanceContext
+ , SolverOptions(..)
, replaceTypeClassDictionaries
, newDictionaries
+ , entails
) where
import Prelude.Compat
@@ -56,7 +58,7 @@ replaceTypeClassDictionaries
. (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)
=> Bool
-> Expr
- -> m (Expr, [(Ident, Constraint)])
+ -> m (Expr, [(Ident, InstanceContext, Constraint)])
replaceTypeClassDictionaries shouldGeneralize expr = flip evalStateT M.empty $ do
-- Loop, deferring any unsolved constraints, until there are no more
-- constraints which can be solved, then make a generalization pass.
@@ -70,18 +72,18 @@ replaceTypeClassDictionaries shouldGeneralize expr = flip evalStateT M.empty $ d
-- This pass solves constraints where possible, deferring constraints if not.
deferPass :: Expr -> StateT InstanceContext m (Expr, Any)
deferPass = fmap (second fst) . runWriterT . f where
- f :: Expr -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr
+ f :: Expr -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr
(_, f, _) = everywhereOnValuesTopDownM return (go True) return
-- This pass generalizes any remaining constraints
- generalizePass :: Expr -> StateT InstanceContext m (Expr, [(Ident, Constraint)])
+ generalizePass :: Expr -> StateT InstanceContext m (Expr, [(Ident, InstanceContext, Constraint)])
generalizePass = fmap (second snd) . runWriterT . f where
- f :: Expr -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr
+ f :: Expr -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr
(_, f, _) = everywhereOnValuesTopDownM return (go False) return
- go :: Bool -> Expr -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr
- go deferErrors dict@(TypeClassDictionary _ _ hints) =
- rethrow (addHints hints) $ entails shouldGeneralize deferErrors dict
+ go :: Bool -> Expr -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr
+ go deferErrors (TypeClassDictionary constraint context hints) =
+ rethrow (addHints hints) $ entails (SolverOptions shouldGeneralize deferErrors) constraint context hints
go _ other = return other
-- | Three options for how we can handle a constraint, depending on the mode we're in.
@@ -93,18 +95,29 @@ data EntailsResult a
| Deferred
-- ^ We couldn't solve this constraint right now, so it has been deferred
--- |
--- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
+-- | Options for the constraint solver
+data SolverOptions = SolverOptions
+ { solverShouldGeneralize :: Bool
+ -- ^ Should the solver be allowed to generalize over unsolved constraints?
+ , solverDeferErrors :: Bool
+ -- ^ Should the solver be allowed to defer errors by skipping constraints?
+ }
+
+-- | 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
:: forall m
. (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)
- => Bool
- -> Bool
- -> Expr
- -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr
-entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hints) =
+ => SolverOptions
+ -- ^ Solver options
+ -> Constraint
+ -- ^ The constraint to solve
+ -> InstanceContext
+ -- ^ The contexts in which to solve the constraint
+ -> [ErrorMessageHint]
+ -- ^ Error message hints to apply to any instance errors
+ -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr
+entails SolverOptions{..} constraint context hints =
solve constraint
where
forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope]
@@ -123,10 +136,10 @@ entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hin
valUndefined :: Expr
valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))
- solve :: Constraint -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr
+ solve :: Constraint -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr
solve con = go 0 con
where
- go :: Int -> Constraint -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr
+ go :: Int -> Constraint -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr
go work (Constraint className' tys' _) | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'
go work con'@(Constraint className' tys' conInfo) = WriterT . StateT . (withErrorMessageHint (ErrorSolvingConstraint con') .) . runStateT . runWriterT $ do
-- We might have unified types by solving other constraints, so we need to
@@ -137,8 +150,10 @@ entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hin
inferred <- lift get
-- We need information about functional dependencies, so we have to look up the class
-- name in the environment:
- let findClass = fromMaybe (internalError "entails: type class not found in environment") . M.lookup className'
- TypeClassData{ typeClassDependencies } <- lift . lift $ gets (findClass . typeClasses . checkEnv)
+ classesInScope <- lift . lift $ gets (typeClasses . checkEnv)
+ TypeClassData{ typeClassDependencies } <- case M.lookup className' classesInScope of
+ Nothing -> throwError . errorMessage $ UnknownClass className'
+ Just tcd -> pure tcd
let instances =
[ (substs, tcd)
| tcd <- forClassName (combineContexts context inferred) className' tys''
@@ -179,7 +194,7 @@ entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hin
let newContext = mkContext newDicts
modify (combineContexts newContext)
-- Mark this constraint for generalization
- tell (mempty, [(ident, unsolved)])
+ tell (mempty, [(ident, context, unsolved)])
return (Var qident)
Deferred ->
-- Constraint was deferred, just return the dictionary unchanged,
@@ -219,10 +234,10 @@ entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hin
unique :: [Type] -> [(a, TypeClassDictionaryInScope)] -> m (EntailsResult a)
unique tyArgs []
- | deferErrors = return Deferred
+ | solverDeferErrors = return Deferred
-- We need a special case for nullary type classes, since we want
-- to generalize over Partial constraints.
- | shouldGeneralize && (null tyArgs || any canBeGeneralized tyArgs) = return (Unsolved (Constraint className' tyArgs conInfo))
+ | solverShouldGeneralize && (null tyArgs || any canBeGeneralized tyArgs) = return (Unsolved (Constraint className' tyArgs conInfo))
| otherwise = throwError . errorMessage $ NoInstanceFound (Constraint className' tyArgs conInfo)
unique _ [(a, dict)] = return $ Solved a dict
unique tyArgs tcds
@@ -233,7 +248,6 @@ entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hin
canBeGeneralized :: Type -> Bool
canBeGeneralized TUnknown{} = True
- canBeGeneralized Skolem{} = True
canBeGeneralized _ = False
-- |
@@ -251,7 +265,7 @@ entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hin
-- Create dictionaries for subgoals which still need to be solved by calling go recursively
-- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
-- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
- solveSubgoals :: Matching Type -> Maybe [Constraint] -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) (Maybe [Expr])
+ solveSubgoals :: Matching Type -> Maybe [Constraint] -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) (Maybe [Expr])
solveSubgoals _ Nothing = return Nothing
solveSubgoals subst (Just subgoals) =
Just <$> traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars (M.toList subst)))) subgoals
@@ -268,7 +282,6 @@ entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hin
App (Accessor (C.__superclass_ ++ showQualified runProperName superclassName ++ "_" ++ show index)
dict)
valUndefined
-entails _ _ _ = internalError "entails: expected TypeClassDictionary"
-- Check if an instance matches our list of types, allowing for types
-- to be solved via functional dependencies. If the types match, we return a
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 554a56c..79e71fb 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -257,11 +257,11 @@ modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })
-- | Run a computation in the typechecking monad, starting with an empty @Environment@
runCheck :: (Functor m) => StateT CheckState m a -> m (a, Environment)
-runCheck = runCheck' initEnvironment
+runCheck = runCheck' (emptyCheckState initEnvironment)
-- | Run a computation in the typechecking monad, failing with an error, or succeeding with a return value and the final @Environment@.
-runCheck' :: (Functor m) => Environment -> StateT CheckState m a -> m (a, Environment)
-runCheck' env check = second checkEnv <$> runStateT check (emptyCheckState env)
+runCheck' :: (Functor m) => CheckState -> StateT CheckState m a -> m (a, Environment)
+runCheck' st check = second checkEnv <$> runStateT check st
-- | Make an assertion, failing with an error message
guardWith :: (MonadError e m) => e -> Bool -> m ()
diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs
index 0db3767..2838da1 100644
--- a/src/Language/PureScript/TypeChecker/Subsumption.hs
+++ b/src/Language/PureScript/TypeChecker/Subsumption.hs
@@ -1,6 +1,8 @@
--- |
--- Subsumption checking
---
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- | Subsumption checking
module Language.PureScript.TypeChecker.Subsumption
( subsumes
) where
@@ -25,72 +27,120 @@ import Language.PureScript.TypeChecker.Skolems
import Language.PureScript.TypeChecker.Unify
import Language.PureScript.Types
+-- | Subsumption can operate in two modes:
+--
+-- * Elaboration mode, in which we try to insert type class dictionaries
+-- * No-elaboration mode, in which we do not insert dictionaries
+--
+-- Some subsumption rules apply in both modes, and others are specific to
+-- certain modes.
+--
+-- The subsumption algorithm follows the structure of the types in question,
+-- and we can switch into no-elaboration mode when we move under a type
+-- constructor where we can no longer insert dictionaries, e.g. into the fields
+-- of a record.
+data Mode = Elaborate | NoElaborate
+
+-- | Value-level proxies for the two modes
+data ModeSing (mode :: Mode) where
+ SElaborate :: ModeSing 'Elaborate
+ SNoElaborate :: ModeSing 'NoElaborate
+
+-- | This type family tracks what evidence we return from 'subsumes' for each
+-- mode.
+type family Coercion (mode :: Mode) where
+ -- When elaborating, we generate a coercion
+ Coercion 'Elaborate = Expr -> Expr
+ -- When we're not elaborating, we don't generate coercions
+ Coercion 'NoElaborate = ()
+
+-- | The default coercion for each mode.
+defaultCoercion :: ModeSing mode -> Coercion mode
+defaultCoercion SElaborate = id
+defaultCoercion SNoElaborate = ()
+
-- | Check that one type subsumes another, rethrowing errors to provide a better error message
-subsumes :: (MonadError MultipleErrors m, MonadState CheckState m) => Maybe Expr -> Type -> Type -> m (Maybe Expr)
-subsumes val ty1 ty2 = withErrorMessageHint (ErrorInSubsumption ty1 ty2) $ subsumes' val ty1 ty2
+subsumes
+ :: (MonadError MultipleErrors m, MonadState CheckState m)
+ => Type
+ -> Type
+ -> m (Expr -> Expr)
+subsumes ty1 ty2 =
+ withErrorMessageHint (ErrorInSubsumption ty1 ty2) $
+ subsumes' SElaborate ty1 ty2
-- | Check that one type subsumes another
-subsumes' :: (MonadError MultipleErrors m, MonadState CheckState m) =>
- Maybe Expr ->
- Type ->
- Type ->
- m (Maybe Expr)
-subsumes' val (ForAll ident ty1 _) ty2 = do
+subsumes'
+ :: (MonadError MultipleErrors m, MonadState CheckState m)
+ => ModeSing mode
+ -> Type
+ -> Type
+ -> m (Coercion mode)
+subsumes' mode (ForAll ident ty1 _) ty2 = do
replaced <- replaceVarWithUnknown ident ty1
- subsumes val replaced ty2
-subsumes' val ty1 (ForAll ident ty2 sco) =
+ subsumes' mode replaced ty2
+subsumes' mode ty1 (ForAll ident ty2 sco) =
case sco of
Just sco' -> do
sko <- newSkolemConstant
let sk = skolemize ident sko sco' Nothing ty2
- subsumes val ty1 sk
+ subsumes' mode ty1 sk
Nothing -> internalError "subsumes: unspecified skolem scope"
-subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do
- _ <- subsumes Nothing arg2 arg1
- _ <- subsumes Nothing ret1 ret2
- return val
-subsumes' val (KindedType ty1 _) ty2 =
- subsumes val ty1 ty2
-subsumes' val ty1 (KindedType ty2 _) =
- subsumes val ty1 ty2
-subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do
+subsumes' mode (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do
+ subsumes' SNoElaborate arg2 arg1
+ subsumes' SNoElaborate ret1 ret2
+ -- Nothing was elaborated, return the default coercion
+ return (defaultCoercion mode)
+subsumes' mode (KindedType ty1 _) ty2 =
+ subsumes' mode ty1 ty2
+subsumes' mode ty1 (KindedType ty2 _) =
+ subsumes' mode ty1 ty2
+-- Only check subsumption for constrained types when elaborating.
+-- Otherwise fall back to unification.
+subsumes' SElaborate (ConstrainedType constraints ty1) ty2 = do
dicts <- getTypeClassDictionaries
hints <- gets checkHints
- subsumes' (Just $ foldl App val (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) ty1 ty2
-subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyRecord && f2 == tyRecord = do
- let
- (ts1, r1') = rowToList r1
- (ts2, r2') = rowToList r2
- ts1' = sortBy (comparing fst) ts1
- ts2' = sortBy (comparing fst) ts2
- -- For { ts1 | r1 } to subsume { ts2 | r2 } when r1 is empty (= we're working with a closed row),
- -- every property in ts2 must appear in ts1. If not, then the candidate expression is missing a required property.
- -- Conversely, when r2 is empty, every property in ts1 must appear in ts2, or else the expression has
- -- an additional property which is not allowed.
- when (r1' == REmpty)
- (for_ (firstMissingProp ts2' ts1') (throwError . errorMessage . PropertyIsMissing . fst))
- when (r2' == REmpty)
- (for_ (firstMissingProp ts1' ts2') (throwError . errorMessage . AdditionalProperty . fst))
- go ts1' ts2' r1' r2'
- return val
+ elaborate <- subsumes' SElaborate ty1 ty2
+ let addDicts val = foldl App val (map (\cs -> TypeClassDictionary cs dicts hints) constraints)
+ return (elaborate . addDicts)
+subsumes' mode (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyRecord && f2 == tyRecord = do
+ let
+ (ts1, r1') = rowToList r1
+ (ts2, r2') = rowToList r2
+ ts1' = sortBy (comparing fst) ts1
+ ts2' = sortBy (comparing fst) ts2
+ -- For { ts1 | r1 } to subsume { ts2 | r2 } when r1 is empty (= we're working with a closed row),
+ -- every property in ts2 must appear in ts1. If not, then the candidate expression is missing a required property.
+ -- Conversely, when r2 is empty, every property in ts1 must appear in ts2, or else the expression has
+ -- an additional property which is not allowed.
+ when (r1' == REmpty)
+ (for_ (firstMissingProp ts2' ts1') (throwError . errorMessage . PropertyIsMissing . fst))
+ when (r2' == REmpty)
+ (for_ (firstMissingProp ts1' ts2') (throwError . errorMessage . AdditionalProperty . fst))
+ go ts1' ts2' r1' r2'
+ -- Nothing was elaborated, return the default coercion
+ return (defaultCoercion mode)
where
- go [] ts2 r1' r2' = unifyTypes r1' (rowFromList (ts2, r2'))
- go ts1 [] r1' r2' = unifyTypes r2' (rowFromList (ts1, r1'))
- go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1' r2'
- | p1 == p2 = do _ <- subsumes Nothing ty1 ty2
- go ts1 ts2 r1' r2'
- | p1 < p2 = do rest <- freshType
- -- What happens next is a bit of a hack.
- -- TODO: in the new type checker, object properties will probably be restricted to being monotypes
- -- in which case, this branch of the subsumes function should not even be necessary.
- unifyTypes r2' (RCons p1 ty1 rest)
- go ts1 ((p2, ty2) : ts2) r1' rest
- | otherwise = do rest <- freshType
- unifyTypes r1' (RCons p2 ty2 rest)
- go ((p1, ty1) : ts1) ts2 rest r2'
- -- Find the first property that's in the first list (of tuples) but not in the second
- firstMissingProp t1 t2 = fst <$> uncons (minusBy' (comparing fst) t1 t2)
-subsumes' val ty1 ty2@(TypeApp obj _) | obj == tyRecord = subsumes val ty2 ty1
-subsumes' val ty1 ty2 = do
+ go [] ts2 r1' r2' = unifyTypes r1' (rowFromList (ts2, r2'))
+ go ts1 [] r1' r2' = unifyTypes r2' (rowFromList (ts1, r1'))
+ go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1' r2'
+ | p1 == p2 = do subsumes' SNoElaborate ty1 ty2
+ go ts1 ts2 r1' r2'
+ | p1 < p2 = do rest <- freshType
+ -- What happens next is a bit of a hack.
+ -- TODO: in the new type checker, object properties will probably be restricted to being monotypes
+ -- in which case, this branch of the subsumes function should not even be necessary.
+ unifyTypes r2' (RCons p1 ty1 rest)
+ go ts1 ((p2, ty2) : ts2) r1' rest
+ | otherwise = do rest <- freshType
+ unifyTypes r1' (RCons p2 ty2 rest)
+ go ((p1, ty1) : ts1) ts2 rest r2'
+
+ -- Find the first property that's in the first list (of tuples) but not in the second
+ firstMissingProp t1 t2 = fst <$> uncons (minusBy' (comparing fst) t1 t2)
+subsumes' mode ty1 ty2@(TypeApp obj _) | obj == tyRecord =
+ subsumes' mode ty2 ty1
+subsumes' mode ty1 ty2 = do
unifyTypes ty1 ty2
- return val
+ -- Nothing was elaborated, return the default coercion
+ return (defaultCoercion mode)
diff --git a/src/Language/PureScript/TypeChecker/TypeSearch.hs b/src/Language/PureScript/TypeChecker/TypeSearch.hs
new file mode 100644
index 0000000..c84c360
--- /dev/null
+++ b/src/Language/PureScript/TypeChecker/TypeSearch.hs
@@ -0,0 +1,94 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Language.PureScript.TypeChecker.TypeSearch
+ ( typeSearch
+ ) where
+
+import Protolude
+
+import Control.Monad.Writer
+import qualified Data.Map as Map
+import qualified Language.PureScript.TypeChecker.Entailment as Entailment
+
+import qualified Language.PureScript.TypeChecker.Monad as TC
+import Language.PureScript.TypeChecker.Subsumption
+import Language.PureScript.TypeChecker.Unify as P
+
+import Control.Monad.Supply as P
+import Language.PureScript.AST as P
+import Language.PureScript.Environment as P
+import Language.PureScript.Errors as P
+import Language.PureScript.Names as P
+import Language.PureScript.TypeChecker.Skolems as Skolem
+import Language.PureScript.TypeChecker.Synonyms as P
+import Language.PureScript.Types as P
+
+checkInEnvironment
+ :: Environment
+ -> TC.CheckState
+ -> StateT TC.CheckState (SupplyT (WriterT b (Except P.MultipleErrors))) a
+ -> Maybe (a, Environment)
+checkInEnvironment env st =
+ either (const Nothing) Just
+ . runExcept
+ . evalWriterT
+ . P.evalSupplyT 0
+ . TC.runCheck' (st { TC.checkEnv = env })
+
+evalWriterT :: Monad m => WriterT b m r -> m r
+evalWriterT m = liftM fst (runWriterT m)
+
+checkSubsume
+ :: Maybe [(P.Ident, Entailment.InstanceContext, P.Constraint)]
+ -- ^ Additional constraints we need to satisfy
+ -> P.Environment
+ -- ^ The Environment which contains the relevant definitions and typeclasses
+ -> TC.CheckState
+ -- ^ The typechecker state
+ -> P.Type
+ -- ^ The user supplied type
+ -> P.Type
+ -- ^ The type supplied by the environment
+ -> Maybe ((P.Expr, [(P.Ident, Entailment.InstanceContext, P.Constraint)]), P.Environment)
+checkSubsume unsolved env st userT envT = checkInEnvironment env st $ do
+ let initializeSkolems =
+ Skolem.introduceSkolemScope
+ <=< P.replaceAllTypeSynonyms
+ <=< P.replaceTypeWildcards
+
+ userT' <- initializeSkolems userT
+ envT' <- initializeSkolems envT
+
+ let dummyExpression = P.Var (P.Qualified Nothing (P.Ident "x"))
+
+ elab <- subsumes envT' userT'
+ subst <- gets TC.checkSubstitution
+ let expP = P.overTypes (P.substituteType subst) (elab dummyExpression)
+
+ -- Now check that any unsolved constraints have not become impossible
+ (traverse_ . traverse_) (\(_, context, constraint) -> do
+ let constraint' = P.mapConstraintArgs (map (P.substituteType subst)) constraint
+ flip evalStateT Map.empty . evalWriterT $
+ Entailment.entails
+ (Entailment.SolverOptions
+ { solverShouldGeneralize = True
+ , solverDeferErrors = False
+ }) constraint' context []) unsolved
+
+ -- Finally, check any constraints which were found during elaboration
+ Entailment.replaceTypeClassDictionaries (isJust unsolved) expP
+
+typeSearch
+ :: Maybe [(P.Ident, Entailment.InstanceContext, P.Constraint)]
+ -- ^ Additional constraints we need to satisfy
+ -> P.Environment
+ -- ^ The Environment which contains the relevant definitions and typeclasses
+ -> TC.CheckState
+ -- ^ The typechecker state
+ -> P.Type
+ -- ^ The type we are looking for
+ -> Map (P.Qualified P.Ident) P.Type
+typeSearch unsolved env st type' =
+ Map.mapMaybe (\(x, _, _) -> checkSubsume unsolved env st type' x $> x) (P.names env)
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 3135148..5989c26 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}
@@ -27,13 +28,16 @@ module Language.PureScript.TypeChecker.Types
import Prelude.Compat
+import Control.Arrow (first, second, (***))
import Control.Monad
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.State.Class (MonadState(..), gets)
import Control.Monad.Supply.Class (MonadSupply)
import Control.Monad.Writer.Class (MonadWriter(..))
+import Data.Bifunctor (bimap)
import Data.Either (lefts, rights)
+import Data.Functor (($>))
import Data.List (transpose, nub, (\\), partition, delete)
import Data.Maybe (fromMaybe)
import qualified Data.Map as M
@@ -53,9 +57,11 @@ import Language.PureScript.TypeChecker.Rows
import Language.PureScript.TypeChecker.Skolems
import Language.PureScript.TypeChecker.Subsumption
import Language.PureScript.TypeChecker.Synonyms
+import Language.PureScript.TypeChecker.TypeSearch
import Language.PureScript.TypeChecker.Unify
import Language.PureScript.Types
+
data BindingGroupType
= RecursiveBindingGroup
| NonRecursiveBindingGroup
@@ -70,13 +76,13 @@ typesOf
-> [(Ident, Expr)]
-> m [(Ident, (Expr, Type))]
typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
- (tys, w) <- withoutWarnings . capturingSubstitution tidyUp $ do
+ tys <- capturingSubstitution tidyUp $ do
(untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup (Just moduleName) vals
- ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict
- ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict
- return (map (\x -> (False, x)) ds1 ++ map (\x -> (True, x)) ds2)
+ ds1 <- parU typed $ \e -> withoutWarnings $ checkTypedBindingGroupElement moduleName e dict
+ ds2 <- forM untyped $ \e -> withoutWarnings $ typeForBindingGroupElement e dict untypedDict
+ return (map (False, ) ds1 ++ map (True, ) ds2)
- inferred <- forM tys $ \(shouldGeneralize, (ident, (val, ty))) -> do
+ inferred <- forM tys $ \(shouldGeneralize, ((ident, (val, ty)), _)) -> do
-- Replace type class dictionary placeholders with actual dictionaries
(val', unsolved) <- replaceTypeClassDictionaries shouldGeneralize val
-- Generalize and constrain the type
@@ -96,7 +102,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
$ CannotGeneralizeRecursiveFunction ident generalized
-- Make sure any unsolved type constraints only use type variables which appear
-- unknown in the inferred type.
- forM_ unsolved $ \(_, con) -> do
+ forM_ unsolved $ \(_, _, con) -> do
-- We need information about functional dependencies, since we allow
-- ambiguous types to be inferred if they can be solved by some functional
-- dependency.
@@ -104,33 +110,56 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
TypeClassData{ typeClassDependencies } <- gets (findClass . typeClasses . checkEnv)
let solved = foldMap (S.fromList . fdDetermined) typeClassDependencies
let constraintTypeVars = nub . foldMap (unknownsInType . fst) . filter ((`notElem` solved) . snd) $ zip (constraintArgs con) [0..]
- when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $
- throwError . onErrorMessages (replaceTypes currentSubst) . errorMessage $ NoInstanceFound con
+ when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $ do
+ throwError . onErrorMessages (replaceTypes currentSubst) . errorMessage $ AmbiguousTypeVariables generalized con
-- Check skolem variables did not escape their scope
skolemEscapeCheck val'
-- Check rows do not contain duplicate labels
checkDuplicateLabels val'
- return (ident, (foldr (Abs . Left . fst) val' unsolved, generalized))
+ return ((ident, (foldr (Abs . Left . (\(x, _, _) -> x)) val' unsolved, generalized)), unsolved)
-- Show warnings here, since types in wildcards might have been solved during
-- instance resolution (by functional dependencies).
- finalSubst <- gets checkSubstitution
- escalateWarningWhen isHoleError . tell . onErrorMessages (replaceTypes finalSubst) $ w
+ finalState <- get
+ forM_ tys $ \(shouldGeneralize, ((_, (_, _)), w)) -> do
+ let replaceTypes' = replaceTypes (checkSubstitution finalState)
+ runTypeSearch' = runTypeSearch (guard shouldGeneralize $> foldMap snd inferred) finalState
+ (escalateWarningWhen isHoleError . tell . onErrorMessages (runTypeSearch' . replaceTypes')) w
- return inferred
+ return (map fst inferred)
where
+ replaceTypes
+ :: Substitution
+ -> ErrorMessage
+ -> ErrorMessage
replaceTypes subst = onTypesInErrorMessage (substituteType subst)
+ -- | Run type search to complete any typed hole error messages
+ runTypeSearch
+ :: Maybe [(Ident, InstanceContext, Constraint)]
+ -- ^ Any unsolved constraints which we need to continue to satisfy
+ -> CheckState
+ -- ^ The final type checker state
+ -> ErrorMessage
+ -> ErrorMessage
+ runTypeSearch cons st = \case
+ ErrorMessage hints (HoleInferredType x ty y (TSBefore env)) ->
+ let subst = checkSubstitution st
+ searchResult = (fmap . fmap) (substituteType subst)
+ (M.toList (typeSearch cons env st (substituteType subst ty)))
+ in ErrorMessage hints (HoleInferredType x ty y (TSAfter searchResult))
+ other -> other
+
-- | Generalize type vars using forall and add inferred constraints
generalize unsolved = varIfUnknown . constrain unsolved
-- | Add any unsolved constraints
constrain [] = id
- constrain cs = ConstrainedType (map snd cs)
+ constrain cs = ConstrainedType (map (\(_, _, x) -> x) cs)
-- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
- tidyUp ts sub = map (\(b, (i, (val, ty))) -> (b, (i, (overTypes (substituteType sub) val, substituteType sub ty)))) ts
+ tidyUp ts sub = map (second (first (second (overTypes (substituteType sub) *** substituteType sub)))) ts
isHoleError :: ErrorMessage -> Bool
isHoleError (ErrorMessage _ HoleInferredType{}) = True
@@ -199,19 +228,12 @@ typeForBindingGroupElement (ident, val) dict untypedDict = do
-- | Check if a value contains a type annotation
isTyped :: (Ident, Expr) -> Either (Ident, Expr) (Ident, (Expr, Type, Bool))
isTyped (name, TypedValue checkType value ty) = Right (name, (value, ty, checkType))
+isTyped (name, PositionedValue pos c value) =
+ bimap (second (PositionedValue pos c))
+ (second (\(e, t, b) -> (PositionedValue pos c e, t, b)))
+ (isTyped (name, value))
isTyped (name, value) = Left (name, value)
--- |
--- Map a function over type annotations appearing inside a value
---
-overTypes :: (Type -> Type) -> Expr -> Expr
-overTypes f = let (_, f', _) = everywhereOnValues id g id in f'
- where
- g :: Expr -> Expr
- g (TypedValue checkTy val t) = TypedValue checkTy val (f t)
- g (TypeClassDictionary c sco hints) = TypeClassDictionary (mapConstraintArgs (map f) c) sco hints
- g other = other
-
-- | Check the kind of a type, failing if it is not of kind *.
checkTypeKind ::
(MonadError MultipleErrors m) =>
@@ -339,7 +361,8 @@ infer' (TypedValue checkType val ty) = do
infer' (Hole name) = do
ty <- freshType
ctx <- getLocalContext
- tell . errorMessage $ HoleInferredType name ty ctx
+ env <- getEnv
+ tell . errorMessage $ HoleInferredType name ty ctx (TSBefore env)
return $ TypedValue True (Hole name) ty
infer' (PositionedValue pos c val) = warnAndRethrowWithPositionTC pos $ do
TypedValue t v ty <- infer' val
@@ -568,18 +591,14 @@ check' (Abs (Right _) _) _ = internalError "Binder was not desugared"
check' (App f arg) ret = do
f'@(TypedValue _ _ ft) <- infer f
(retTy, app) <- checkFunctionApplication f' ft arg
- v' <- subsumes (Just app) retTy ret
- case v' of
- Nothing -> internalError "check: unable to check the subsumes relation."
- Just app' -> return $ TypedValue True app' ret
+ elaborate <- subsumes retTy ret
+ return $ TypedValue True (elaborate app) ret
check' v@(Var var) ty = do
checkVisibility var
repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable $ var
ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
- v' <- subsumes (Just v) repl ty'
- case v' of
- Nothing -> internalError "check: unable to check the subsumes relation."
- Just v'' -> return $ TypedValue True v'' ty'
+ elaborate <- subsumes repl ty'
+ return $ TypedValue True (elaborate v) ty'
check' (DeferredDictionary className tys) _ = do
{-
-- Here, we replace a placeholder for a superclass dictionary with a regular
@@ -596,12 +615,11 @@ check' (TypedValue checkType val ty1) ty2 = do
checkTypeKind ty1 kind
ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty1
ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2
- val' <- subsumes (Just val) ty1' ty2'
- case val' of
- Nothing -> internalError "check: unable to check the subsumes relation."
- Just _ -> do
- val''' <- if checkType then withScopedTypeVars moduleName args (check val ty2') else return val
- return $ TypedValue checkType val''' ty2'
+ _ <- subsumes ty1' ty2'
+ val' <- if checkType
+ then withScopedTypeVars moduleName args (check val ty2')
+ else return val
+ return $ TypedValue checkType val' ty2'
check' (Case vals binders) ret = do
(vals', ts) <- instantiateForBinders vals binders
binders' <- checkBinders ts ret binders
@@ -638,10 +656,8 @@ check' v@(Constructor c) ty = do
Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c
Just (_, _, ty1, _) -> do
repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
- mv <- subsumes (Just v) repl ty
- case mv of
- Nothing -> internalError "check: unable to check the subsumes relation."
- Just v' -> return $ TypedValue True v' ty
+ elaborate <- subsumes repl ty
+ return $ TypedValue True (elaborate v) ty
check' (Let ds val) ty = do
(ds', val') <- inferLetBinding [] ds val (`check` ty)
return $ TypedValue True (Let ds' val') ty
@@ -654,10 +670,8 @@ check' (PositionedValue pos c val) ty = warnAndRethrowWithPositionTC pos $ do
return $ TypedValue t (PositionedValue pos c v) ty'
check' val ty = do
TypedValue _ val' ty' <- infer val
- mt <- subsumes (Just val') ty' ty
- case mt of
- Nothing -> internalError "check: unable to check the subsumes relation."
- Just v' -> return $ TypedValue True v' ty
+ elaborate <- subsumes ty' ty
+ return $ TypedValue True (elaborate val') ty
-- |
-- Check the type of a collection of named record fields
diff --git a/src/System/IO/UTF8.hs b/src/System/IO/UTF8.hs
index a69dded..ec5088e 100644
--- a/src/System/IO/UTF8.hs
+++ b/src/System/IO/UTF8.hs
@@ -4,11 +4,21 @@ import Prelude.Compat
import qualified Data.ByteString as BS
import qualified Data.ByteString.UTF8 as UTF8
+import Data.Text (Text)
+import qualified Data.Text.Encoding as TE
+
+readUTF8FileT :: FilePath -> IO Text
+readUTF8FileT inFile =
+ fmap TE.decodeUtf8 (BS.readFile inFile)
+
+writeUTF8FileT :: FilePath -> Text -> IO ()
+writeUTF8FileT inFile text =
+ BS.writeFile inFile (TE.encodeUtf8 text)
readUTF8File :: FilePath -> IO String
-readUTF8File inFile = do
+readUTF8File inFile =
fmap UTF8.toString (BS.readFile inFile)
writeUTF8File :: FilePath -> String -> IO ()
-writeUTF8File inFile text = do
+writeUTF8File inFile text =
BS.writeFile inFile (UTF8.fromString text)
diff --git a/stack.yaml b/stack.yaml
index b0e1501..f800d9d 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,12 +1,3 @@
-resolver: lts-6.13
+resolver: lts-6.10
packages:
- '.'
-extra-deps:
-# - aeson-1.0.0.0
-- http-client-0.5.1
-- http-client-tls-0.3.0
-- pipes-http-1.0.4
-# - semigroups-0.18.2
-# flags:
-# semigroups:
-# bytestring-builder: false
diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs
index cc705f8..3b4cfc2 100644
--- a/tests/Language/PureScript/Ide/FilterSpec.hs
+++ b/tests/Language/PureScript/Ide/FilterSpec.hs
@@ -9,7 +9,7 @@ import qualified Language.PureScript as P
import Test.Hspec
value :: Text -> IdeDeclarationAnn
-value s = IdeDeclarationAnn emptyAnn (IdeValue (P.Ident (toS s)) P.REmpty)
+value s = IdeDeclarationAnn emptyAnn (IdeDeclValue (IdeValue (P.Ident (toS s)) P.REmpty))
moduleA, moduleB :: Module
moduleA = (P.moduleNameFromString "Module.A", [value "function1"])
diff --git a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs
index 1d7abbb..61021cc 100644
--- a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs
+++ b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs
@@ -6,12 +6,12 @@ module Language.PureScript.Ide.Imports.IntegrationSpec where
import Protolude
import qualified Data.Text as T
-import qualified Data.Text.IO as TIO
import qualified Language.PureScript.Ide.Integration as Integration
import Test.Hspec
import System.Directory
import System.FilePath
+import System.IO.UTF8 (readUTF8FileT)
setup :: IO ()
setup = void (Integration.reset *> Integration.loadAll)
@@ -27,7 +27,7 @@ withSupportFiles test = do
outputFileShouldBe :: [Text] -> IO ()
outputFileShouldBe expectation = do
outFp <- (</> "src" </> "ImportsSpecOut.tmp") <$> Integration.projectDirectory
- outRes <- TIO.readFile outFp
+ outRes <- readUTF8FileT outFp
shouldBe (T.lines outRes) expectation
spec :: Spec
@@ -57,10 +57,10 @@ spec = beforeAll_ setup . describe "Adding imports" $ do
outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (class ATypeClass)"])
it "adds an explicit unqualified import (dataconstructor)" $ do
withSupportFiles (Integration.addImport "MyJust")
- outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyMaybe(MyJust))"])
+ outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyMaybe(..))"])
it "adds an explicit unqualified import (newtype)" $ do
withSupportFiles (Integration.addImport "MyNewtype")
- outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyNewtype(MyNewtype))"])
+ outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyNewtype(..))"])
it "adds an explicit unqualified import (typeclass member function)" $ do
withSupportFiles (Integration.addImport "typeClassFun")
outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (typeClassFun)"])
diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs
index 7cea546..bba7441 100644
--- a/tests/Language/PureScript/Ide/ImportsSpec.hs
+++ b/tests/Language/PureScript/Ide/ImportsSpec.hs
@@ -68,11 +68,13 @@ spec = do
describe "import commands" $ do
let simpleFileImports = let (_, _, i, _) = splitSimpleFile in i
addValueImport i mn is =
- prettyPrintImportSection (addExplicitImport' (IdeValue (P.Ident i) wildcard) mn is)
+ prettyPrintImportSection (addExplicitImport' (IdeDeclValue (IdeValue (P.Ident i) wildcard)) mn is)
addOpImport op mn is =
- prettyPrintImportSection (addExplicitImport' (IdeValueOperator op (P.Qualified Nothing (Left (P.Ident ""))) 2 P.Infix Nothing) mn is)
+ prettyPrintImportSection (addExplicitImport' (IdeDeclValueOperator (IdeValueOperator op (P.Qualified Nothing (Left (P.Ident ""))) 2 P.Infix Nothing)) mn is)
addDtorImport i t mn is =
- prettyPrintImportSection (addExplicitImport' (IdeDataConstructor (P.ProperName i) t wildcard) mn is)
+ prettyPrintImportSection (addExplicitImport' (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName i) t wildcard)) mn is)
+ addTypeImport i mn is =
+ prettyPrintImportSection (addExplicitImport' (IdeDeclType (IdeType (P.ProperName i) P.Star)) mn is)
it "adds an implicit unqualified import" $
shouldBe
(addImplicitImport' simpleFileImports (P.moduleNameFromString "Data.Map"))
@@ -100,20 +102,26 @@ spec = do
shouldBe
(addOpImport (P.OpName "<~>") (P.moduleNameFromString "Data.Array") explicitImports)
[ "import Prelude"
- , "import Data.Array ((<~>), tail)"
+ , "import Data.Array (tail, (<~>))"
]
+ it "adds a type with constructors without automatically adding an open import of said constructors " $
+ shouldBe
+ (addTypeImport "Maybe" (P.moduleNameFromString "Data.Maybe") simpleFileImports)
+ [ "import Prelude"
+ , "import Data.Maybe (Maybe)"
+ ]
it "adds the type for a given DataConstructor" $
shouldBe
(addDtorImport "Just" (P.ProperName "Maybe") (P.moduleNameFromString "Data.Maybe") simpleFileImports)
[ "import Prelude"
- , "import Data.Maybe (Maybe(Just))"
+ , "import Data.Maybe (Maybe(..))"
]
it "adds a dataconstructor to an existing type import" $ do
let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe)"])
shouldBe
(addDtorImport "Just" (P.ProperName "Maybe") (P.moduleNameFromString "Data.Maybe") typeImports)
[ "import Prelude"
- , "import Data.Maybe (Maybe(Just))"
+ , "import Data.Maybe (Maybe(..))"
]
it "doesn't add a dataconstructor to an existing type import with open dtors" $ do
let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe(..))"])
@@ -128,3 +136,38 @@ spec = do
[ "import Prelude"
, "import Data.Array (tail)"
]
+
+ describe "explicit import sorting" $ do
+ -- given some basic import skeleton
+ let Right (_, _, baseImports, _) = sliceImportSection $ withImports ["import Control.Monad (ap)"]
+ moduleName = (P.moduleNameFromString "Control.Monad")
+ addImport imports import' = addExplicitImport' import' moduleName imports
+ valueImport ident = (IdeDeclValue (IdeValue (P.Ident ident) wildcard))
+ typeImport name = (IdeDeclType (IdeType (P.ProperName name) P.Star))
+ classImport name = (IdeDeclTypeClass (P.ProperName name))
+ dtorImport name typeName = (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName name) (P.ProperName typeName) wildcard))
+ -- expect any list of provided identifiers, when imported, to come out as specified
+ expectSorted imports expected = shouldBe
+ (ordNub $ map
+ (prettyPrintImportSection . foldl addImport baseImports)
+ (permutations imports))
+ [expected]
+ it "sorts class" $
+ expectSorted (map classImport ["Applicative", "Bind"])
+ ["import Prelude", "import Control.Monad (class Applicative, class Bind, ap)"]
+ it "sorts value" $
+ expectSorted (map valueImport ["unless", "where"])
+ ["import Prelude", "import Control.Monad (ap, unless, where)"]
+ it "sorts type, value" $
+ expectSorted
+ ((map valueImport ["unless", "where"]) ++ (map typeImport ["Foo", "Bar"]))
+ ["import Prelude", "import Control.Monad (Bar, Foo, ap, unless, where)"]
+ it "sorts class, type, value" $
+ expectSorted
+ ((map valueImport ["unless", "where"]) ++ (map typeImport ["Foo", "Bar"]) ++ (map classImport ["Applicative", "Bind"]))
+ ["import Prelude", "import Control.Monad (class Applicative, class Bind, Bar, Foo, ap, unless, where)"]
+ it "sorts types with constructors, using open imports for the constructors" $
+ expectSorted
+ -- the imported names don't actually have to exist!
+ (map (uncurry dtorImport) [("Just", "Maybe"), ("Nothing", "Maybe"), ("SomeOtherConstructor", "SomeDataType")])
+ ["import Prelude", "import Control.Monad (Maybe(..), SomeDataType(..), ap)"]
diff --git a/tests/Language/PureScript/Ide/MatcherSpec.hs b/tests/Language/PureScript/Ide/MatcherSpec.hs
index 6a8b2df..f7a7f45 100644
--- a/tests/Language/PureScript/Ide/MatcherSpec.hs
+++ b/tests/Language/PureScript/Ide/MatcherSpec.hs
@@ -13,7 +13,7 @@ import Language.PureScript.Ide.Util
import Test.Hspec
value :: Text -> IdeDeclarationAnn
-value s = withEmptyAnn (IdeValue (P.Ident (toS s)) P.REmpty)
+value s = withEmptyAnn (IdeDeclValue (IdeValue (P.Ident (toS s)) P.REmpty))
firstResult, secondResult, fiult :: Match IdeDeclarationAnn
firstResult = Match (P.moduleNameFromString "Match", value "firstResult")
diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs
index f0e03c4..f273938 100644
--- a/tests/Language/PureScript/Ide/ReexportsSpec.hs
+++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs
@@ -18,11 +18,11 @@ d :: IdeDeclaration -> IdeDeclarationAnn
d = IdeDeclarationAnn emptyAnn
valueA, typeA, classA, dtorA1, dtorA2 :: IdeDeclarationAnn
-valueA = d (IdeValue (P.Ident "valueA") P.REmpty)
-typeA = d (IdeType (P.ProperName "TypeA") P.Star)
-classA = d (IdeTypeClass (P.ProperName "ClassA"))
-dtorA1 = d (IdeDataConstructor (P.ProperName "DtorA1") (P.ProperName "TypeA") P.REmpty)
-dtorA2 = d (IdeDataConstructor (P.ProperName "DtorA2") (P.ProperName "TypeA") P.REmpty)
+valueA = d (IdeDeclValue (IdeValue (P.Ident "valueA") P.REmpty))
+typeA = d (IdeDeclType (IdeType(P.ProperName "TypeA") P.Star))
+classA = d (IdeDeclTypeClass (P.ProperName "ClassA"))
+dtorA1 = d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "DtorA1") (P.ProperName "TypeA") P.REmpty))
+dtorA2 = d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "DtorA2") (P.ProperName "TypeA") P.REmpty))
env :: Map P.ModuleName [IdeDeclarationAnn]
env = Map.fromList
diff --git a/tests/Language/PureScript/Ide/StateSpec.hs b/tests/Language/PureScript/Ide/StateSpec.hs
index 87b50d2..2779662 100644
--- a/tests/Language/PureScript/Ide/StateSpec.hs
+++ b/tests/Language/PureScript/Ide/StateSpec.hs
@@ -11,20 +11,20 @@ import qualified Data.Map as Map
valueOperator :: Maybe P.Type -> IdeDeclarationAnn
valueOperator =
- d . IdeValueOperator (P.OpName "<$>") (P.Qualified (Just (mn "Test")) (Left (P.Ident "function"))) 2 P.Infix
+ d . IdeDeclValueOperator . IdeValueOperator (P.OpName "<$>") (P.Qualified (Just (mn "Test")) (Left (P.Ident "function"))) 2 P.Infix
ctorOperator :: Maybe P.Type -> IdeDeclarationAnn
ctorOperator =
- d . IdeValueOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (Right (P.ProperName "Cons"))) 2 P.Infix
+ d . IdeDeclValueOperator . IdeValueOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (Right (P.ProperName "Cons"))) 2 P.Infix
typeOperator :: Maybe P.Kind -> IdeDeclarationAnn
typeOperator =
- d . IdeTypeOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (P.ProperName "List")) 2 P.Infix
+ d . IdeDeclTypeOperator . IdeTypeOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (P.ProperName "List")) 2 P.Infix
testModule :: Module
-testModule = (mn "Test", [ d (IdeValue (P.Ident "function") P.REmpty)
- , d (IdeDataConstructor (P.ProperName "Cons") (P.ProperName "List") (P.REmpty))
- , d (IdeType (P.ProperName "List") P.Star)
+testModule = (mn "Test", [ d (IdeDeclValue (IdeValue (P.Ident "function") P.REmpty))
+ , d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "Cons") (P.ProperName "List") (P.REmpty)))
+ , d (IdeDeclType (IdeType (P.ProperName "List") P.Star))
, valueOperator Nothing
, ctorOperator Nothing
, typeOperator Nothing
diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs
index 019b428..a11babe 100644
--- a/tests/TestCompiler.hs
+++ b/tests/TestCompiler.hs
@@ -31,6 +31,7 @@ import Data.List (sort, stripPrefix, intercalate, groupBy, sortBy, minimumBy)
import Data.Maybe (mapMaybe)
import Data.Time.Clock (UTCTime())
import Data.Tuple (swap)
+import qualified Data.Text as T
import qualified Data.Map as M
@@ -71,7 +72,7 @@ spec = do
supportPurs <- supportFiles "purs"
supportPursFiles <- readInput supportPurs
supportExterns <- runExceptT $ do
- modules <- ExceptT . return $ P.parseModulesFromFiles id supportPursFiles
+ modules <- ExceptT . return $ P.parseModulesFromFiles id (map (fmap T.pack) supportPursFiles)
foreigns <- inferForeignModules modules
externs <- ExceptT . fmap fst . runTest $ P.make (makeActions foreigns) (map snd modules)
return (zip (map snd modules) externs)
@@ -194,7 +195,7 @@ compile
-> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors)
compile supportExterns inputFiles check = silence $ runTest $ do
fs <- liftIO $ readInput inputFiles
- ms <- P.parseModulesFromFiles id fs
+ ms <- P.parseModulesFromFiles id (map (fmap T.pack) fs)
foreigns <- inferForeignModules ms
liftIO (check (map snd ms))
let actions = makeActions foreigns
diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs
index f1a2522..6c8e099 100644
--- a/tests/TestUtils.hs
+++ b/tests/TestUtils.hs
@@ -53,16 +53,24 @@ updateSupportCode = do
--
supportModules :: [String]
supportModules =
- [ "Control.Applicative"
+ [ "Control.Alt"
+ , "Control.Alternative"
+ , "Control.Applicative"
, "Control.Apply"
, "Control.Bind"
, "Control.Category"
+ , "Control.Comonad"
+ , "Control.Extend"
+ , "Control.Lazy"
+ , "Control.Monad"
+ , "Control.Monad.Eff"
, "Control.Monad.Eff.Class"
, "Control.Monad.Eff.Console"
, "Control.Monad.Eff.Unsafe"
- , "Control.Monad.Eff"
, "Control.Monad.ST"
- , "Control.Monad"
+ , "Control.MonadPlus"
+ , "Control.MonadZero"
+ , "Control.Plus"
, "Control.Semigroupoid"
, "Data.Boolean"
, "Data.BooleanAlgebra"
@@ -71,14 +79,27 @@ supportModules =
, "Data.Eq"
, "Data.EuclideanRing"
, "Data.Field"
- , "Data.Function.Uncurried"
, "Data.Function"
+ , "Data.Function.Uncurried"
, "Data.Functor"
+ , "Data.Functor.Invariant"
+ , "Data.Generic.Rep"
+ , "Data.Generic.Rep.Monoid"
+ , "Data.Generic.Rep.Eq"
+ , "Data.Generic.Rep.Ord"
+ , "Data.Generic.Rep.Semigroup"
, "Data.HeytingAlgebra"
+ , "Data.Monoid"
+ , "Data.Monoid.Additive"
+ , "Data.Monoid.Conj"
+ , "Data.Monoid.Disj"
+ , "Data.Monoid.Dual"
+ , "Data.Monoid.Endo"
+ , "Data.Monoid.Multiplicative"
, "Data.NaturalTransformation"
, "Data.Newtype"
- , "Data.Ord.Unsafe"
, "Data.Ord"
+ , "Data.Ord.Unsafe"
, "Data.Ordering"
, "Data.Ring"
, "Data.Semigroup"
@@ -90,6 +111,7 @@ supportModules =
, "Partial.Unsafe"
, "Prelude"
, "Test.Assert"
+ , "Test.Main"
]
pushd :: forall a. FilePath -> IO a -> IO a
diff --git a/tests/support/bower.json b/tests/support/bower.json
index 7bbaebd..d2f01dd 100644
--- a/tests/support/bower.json
+++ b/tests/support/bower.json
@@ -8,6 +8,7 @@
"purescript-prelude": "1.1.0",
"purescript-st": "1.0.0-rc.1",
"purescript-partial": "1.1.2",
- "purescript-newtype": "0.1.0"
+ "purescript-newtype": "0.1.0",
+ "purescript-generics-rep": "2.0.0"
}
}