summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2016-08-01 00:29:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-08-01 00:29:00 (GMT)
commit4d61f80cdcce39749da53bdcab7d71e406710222 (patch)
tree1c29e1b5ca295927c7df13affffa927d9176ff55
parent72ab68866f2cbf61810e650b8c4025cca1eab66c (diff)
version 0.9.30.9.3
-rw-r--r--CONTRIBUTORS.md1
-rw-r--r--examples/passing/2252.purs15
-rw-r--r--purescript.cabal9
-rw-r--r--src/Language/PureScript/AST/Binders.hs2
-rw-r--r--src/Language/PureScript/AST/Declarations.hs168
-rw-r--r--src/Language/PureScript/AST/Literals.hs2
-rw-r--r--src/Language/PureScript/AST/Operators.hs4
-rw-r--r--src/Language/PureScript/AST/SourcePos.hs4
-rw-r--r--src/Language/PureScript/AST/Traversals.hs2
-rw-r--r--src/Language/PureScript/Bundle.hs6
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs17
-rw-r--r--src/Language/PureScript/CodeGen/JS/AST.hs6
-rw-r--r--src/Language/PureScript/CodeGen/JS/Common.hs2
-rw-r--r--src/Language/PureScript/Comments.hs2
-rw-r--r--src/Language/PureScript/CoreFn/Binders.hs2
-rw-r--r--src/Language/PureScript/CoreFn/Expr.hs6
-rw-r--r--src/Language/PureScript/CoreFn/Meta.hs4
-rw-r--r--src/Language/PureScript/CoreFn/Module.hs2
-rw-r--r--src/Language/PureScript/Docs/AsMarkdown.hs2
-rw-r--r--src/Language/PureScript/Docs/Convert.hs2
-rw-r--r--src/Language/PureScript/Environment.hs15
-rw-r--r--src/Language/PureScript/Errors.hs222
-rw-r--r--src/Language/PureScript/Externs.hs14
-rw-r--r--src/Language/PureScript/Ide/Command.hs1
-rw-r--r--src/Language/PureScript/Ide/Externs.hs1
-rw-r--r--src/Language/PureScript/Ide/Imports.hs1
-rw-r--r--src/Language/PureScript/Ide/Pursuit.hs4
-rw-r--r--src/Language/PureScript/Ide/Rebuild.hs1
-rw-r--r--src/Language/PureScript/Ide/SourceFile.hs1
-rw-r--r--src/Language/PureScript/Ide/State.hs1
-rw-r--r--src/Language/PureScript/Ide/Types.hs1
-rw-r--r--src/Language/PureScript/Ide/Util.hs2
-rw-r--r--src/Language/PureScript/Interactive.hs2
-rw-r--r--src/Language/PureScript/Interactive/Completion.hs2
-rw-r--r--src/Language/PureScript/Interactive/Printer.hs13
-rw-r--r--src/Language/PureScript/Kinds.hs2
-rw-r--r--src/Language/PureScript/Make.hs7
-rw-r--r--src/Language/PureScript/Names.hs10
-rw-r--r--src/Language/PureScript/Parser/Lexer.hs2
-rw-r--r--src/Language/PureScript/Pretty/Values.hs2
-rw-r--r--src/Language/PureScript/Publish.hs4
-rw-r--r--src/Language/PureScript/Sugar/Names/Env.hs8
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs4
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs3
-rw-r--r--src/Language/PureScript/TypeChecker.hs10
-rw-r--r--src/Language/PureScript/TypeChecker/Entailment.hs40
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs4
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs95
-rw-r--r--src/Language/PureScript/TypeChecker/Subsumption.hs7
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs126
-rw-r--r--src/Language/PureScript/TypeChecker/Unify.hs14
-rw-r--r--src/Language/PureScript/TypeClassDictionaries.hs4
-rw-r--r--src/Language/PureScript/Types.hs8
-rw-r--r--stack.yaml2
-rw-r--r--tests/Language/PureScript/Ide/ImportsSpec.hs2
-rw-r--r--tests/Language/PureScript/Ide/Integration.hs2
-rw-r--r--tests/TestPscPublish.hs2
57 files changed, 497 insertions, 400 deletions
diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md
index d6ec3ec..51c3506 100644
--- a/CONTRIBUTORS.md
+++ b/CONTRIBUTORS.md
@@ -27,6 +27,7 @@ This file lists the contributors to the PureScript compiler project, and the ter
- [@faineance](https://github.com/faineance) My existing contributions and all future contributions until further notice are Copyright faineance, 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).
- [@garyb](https://github.com/garyb) (Gary Burgess) My existing contributions and all future contributions until further notice are Copyright Gary Burgess, 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).
- [@hdgarrood](https://github.com/hdgarrood) (Harry Garrood) My existing contributions and all future contributions until further notice are Copyright Harry Garrood, 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).
+- [@ilovezfs](https://github.com/ilovezfs) - My existing contributions and all future contributions until further notice are Copyright ilovezfs, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license
- [@izgzhen](https://github.com/izgzhen) (Zhen Zhang) My existing contributions and all future contributions until further notice are Copyright Zhen Zhang, 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).
- [@jacereda](https://github.com/jacereda) (Jorge Acereda) My existing contributions and all future contributions until further notice are Copyright Jorge Acereda, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@japesinator](https://github.com/japesinator) (JP Smith) My existing contributions and all future contributions until further notice are Copyright JP Smith, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
diff --git a/examples/passing/2252.purs b/examples/passing/2252.purs
new file mode 100644
index 0000000..a69c517
--- /dev/null
+++ b/examples/passing/2252.purs
@@ -0,0 +1,15 @@
+module Main where
+
+import Control.Monad.Eff.Console (log)
+
+data T a = T
+
+ti :: T Int
+ti = T
+
+t :: forall a. T a
+t = T
+
+xs = [ti, t, t]
+
+main = log "Done"
diff --git a/purescript.cabal b/purescript.cabal
index 904a85b..14c70e8 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.9.2
+version: 0.9.3
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -116,6 +116,7 @@ library
fsnotify >= 0.2.1,
Glob >= 0.7 && < 0.8,
haskeline >= 0.7.0.0,
+ http-client >= 0.4.30 && <0.5,
http-types -any,
language-javascript == 0.6.*,
lifted-base >= 0.2.3 && < 0.2.4,
@@ -128,7 +129,7 @@ library
pipes >= 4.0.0 && < 4.3.0,
pipes-http -any,
process >= 1.2.0 && < 1.5,
- protolude >= 0.1.5,
+ protolude >= 0.1.6,
regex-tdfa -any,
safe >= 0.3.9 && < 0.4,
semigroups >= 0.16.2 && < 0.19,
@@ -449,7 +450,7 @@ executable psc-ide-server
mtl -any,
network -any,
optparse-applicative >= 0.12.1,
- protolude >= 0.1.5,
+ protolude >= 0.1.6,
stm -any,
text -any,
transformers -any,
@@ -491,7 +492,7 @@ test-suite tests
optparse-applicative -any,
parsec -any,
process -any,
- protolude >= 0.1.5,
+ protolude >= 0.1.6,
silently -any,
stm -any,
text -any,
diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs
index 756c726..c7c7d12 100644
--- a/src/Language/PureScript/AST/Binders.hs
+++ b/src/Language/PureScript/AST/Binders.hs
@@ -61,7 +61,7 @@ data Binder
-- A binder with a type annotation
--
| TypedBinder Type Binder
- deriving (Show, Read, Eq)
+ deriving (Show, Eq)
-- |
-- Collect all names introduced in binders in an expression
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index a53e759..a9ba39e 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -22,6 +22,148 @@ import Language.PureScript.Kinds
import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Comments
import Language.PureScript.Environment
+import qualified Language.PureScript.Bundle as Bundle
+
+import qualified Text.Parsec as P
+
+-- | A map of locally-bound names in scope.
+type Context = [(Ident, Type)]
+
+-- | A type of error messages
+data SimpleErrorMessage
+ = ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)
+ | ErrorParsingModule P.ParseError
+ | MissingFFIModule ModuleName
+ | MultipleFFIModules ModuleName [FilePath]
+ | UnnecessaryFFIModule ModuleName FilePath
+ | MissingFFIImplementations ModuleName [Ident]
+ | UnusedFFIImplementations ModuleName [Ident]
+ | InvalidFFIIdentifier ModuleName String
+ | CannotGetFileInfo FilePath
+ | CannotReadFile FilePath
+ | CannotWriteFile FilePath
+ | InfiniteType Type
+ | InfiniteKind Kind
+ | MultipleValueOpFixities (OpName 'ValueOpName)
+ | MultipleTypeOpFixities (OpName 'TypeOpName)
+ | OrphanTypeDeclaration Ident
+ | RedefinedModule ModuleName [SourceSpan]
+ | RedefinedIdent Ident
+ | OverlappingNamesInLet
+ | UnknownName (Qualified Name)
+ | UnknownImport ModuleName Name
+ | UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName)
+ | UnknownExport Name
+ | UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName)
+ | ScopeConflict Name [ModuleName]
+ | ScopeShadowing Name (Maybe ModuleName) [ModuleName]
+ | DeclConflict Name Name
+ | ExportConflict (Qualified Name) (Qualified Name)
+ | DuplicateModuleName ModuleName
+ | DuplicateTypeArgument String
+ | InvalidDoBind
+ | InvalidDoLet
+ | CycleInDeclaration Ident
+ | CycleInTypeSynonym (Maybe (ProperName 'TypeName))
+ | CycleInModules [ModuleName]
+ | NameIsUndefined Ident
+ | UndefinedTypeVariable (ProperName 'TypeName)
+ | PartiallyAppliedSynonym (Qualified (ProperName 'TypeName))
+ | EscapedSkolem (Maybe Expr)
+ | TypesDoNotUnify Type Type
+ | KindsDoNotUnify Kind Kind
+ | ConstrainedTypeUnified Type Type
+ | OverlappingInstances (Qualified (ProperName 'ClassName)) [Type] [Qualified Ident]
+ | NoInstanceFound Constraint
+ | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type]
+ | CannotDerive (Qualified (ProperName 'ClassName)) [Type]
+ | CannotFindDerivingType (ProperName 'TypeName)
+ | DuplicateLabel String (Maybe Expr)
+ | DuplicateValueDeclaration Ident
+ | ArgListLengthsDiffer Ident
+ | OverlappingArgNames (Maybe Ident)
+ | MissingClassMember Ident
+ | ExtraneousClassMember Ident (Qualified (ProperName 'ClassName))
+ | ExpectedType Type Kind
+ | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName))
+ | ExprDoesNotHaveType Expr Type
+ | PropertyIsMissing String
+ | AdditionalProperty String
+ | CannotApplyFunction Type Expr
+ | TypeSynonymInstance
+ | OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type]
+ | InvalidNewtype (ProperName 'TypeName)
+ | InvalidInstanceHead Type
+ | TransitiveExportError DeclarationRef [DeclarationRef]
+ | TransitiveDctorExportError DeclarationRef (ProperName 'ConstructorName)
+ | ShadowedName Ident
+ | ShadowedTypeVar String
+ | UnusedTypeVar String
+ | WildcardInferredType Type Context
+ | HoleInferredType String Type Context
+ | MissingTypeDeclaration Ident Type
+ | OverlappingPattern [[Binder]] Bool
+ | IncompleteExhaustivityCheck
+ | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName)
+ | ImportHidingModule ModuleName
+ | UnusedImport ModuleName
+ | UnusedExplicitImport ModuleName [String] (Maybe ModuleName) [DeclarationRef]
+ | UnusedDctorImport (ProperName 'TypeName)
+ | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName]
+ | DuplicateSelectiveImport ModuleName
+ | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)
+ | DuplicateImportRef Name
+ | DuplicateExportRef Name
+ | IntOutOfRange Integer String Integer Integer
+ | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef]
+ | ImplicitImport ModuleName [DeclarationRef]
+ | HidingImport ModuleName [DeclarationRef]
+ | CaseBinderLengthDiffers Int [Binder]
+ | IncorrectAnonymousArgument
+ | InvalidOperatorInBinder (Qualified (OpName 'ValueOpName)) (Qualified Ident)
+ | DeprecatedRequirePath
+ | CannotGeneralizeRecursiveFunction Ident Type
+ deriving (Show)
+
+-- | Error message hints, providing more detailed information about failure.
+data ErrorMessageHint
+ = ErrorUnifyingTypes Type Type
+ | ErrorInExpression Expr
+ | ErrorInModule ModuleName
+ | ErrorInInstance (Qualified (ProperName 'ClassName)) [Type]
+ | ErrorInSubsumption Type Type
+ | ErrorCheckingAccessor Expr String
+ | ErrorCheckingType Expr Type
+ | ErrorCheckingKind Type
+ | ErrorCheckingGuard
+ | ErrorInferringType Expr
+ | ErrorInApplication Expr Type Expr
+ | ErrorInDataConstructor (ProperName 'ConstructorName)
+ | ErrorInTypeConstructor (ProperName 'TypeName)
+ | ErrorInBindingGroup [Ident]
+ | ErrorInDataBindingGroup
+ | ErrorInTypeSynonym (ProperName 'TypeName)
+ | ErrorInValueDeclaration Ident
+ | ErrorInTypeDeclaration Ident
+ | ErrorInForeignImport Ident
+ | ErrorSolvingConstraint Constraint
+ | PositionedError SourceSpan
+ deriving (Show)
+
+-- | Categories of hints
+data HintCategory
+ = ExprHint
+ | KindHint
+ | CheckHint
+ | PositionHint
+ | SolverHint
+ | OtherHint
+ deriving (Show, Eq)
+
+data ErrorMessage = ErrorMessage
+ [ErrorMessageHint]
+ SimpleErrorMessage
+ deriving (Show)
-- |
-- A module declaration, consisting of comments about the module, a module name,
@@ -29,7 +171,7 @@ import Language.PureScript.Environment
-- explicitly exported. If the export list is Nothing, everything is exported.
--
data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef])
- deriving (Show, Read)
+ deriving (Show)
-- | Return a module's name.
getModuleName :: Module -> ModuleName
@@ -88,7 +230,7 @@ data DeclarationRef
-- A declaration reference with source position information
--
| PositionedDeclarationRef SourceSpan [Comment] DeclarationRef
- deriving (Show, Read)
+ deriving (Show)
instance Eq DeclarationRef where
(TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors'
@@ -149,7 +291,7 @@ data ImportDeclarationType
-- An import with a list of references to hide: `import M hiding (foo)`
--
| Hiding [DeclarationRef]
- deriving (Eq, Show, Read)
+ deriving (Eq, Show)
isImplicit :: ImportDeclarationType -> Bool
isImplicit Implicit = True
@@ -216,15 +358,15 @@ data Declaration
-- A declaration with source position information
--
| PositionedDeclaration SourceSpan [Comment] Declaration
- deriving (Show, Read)
+ deriving (Show)
data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'ConstructorName))) (OpName 'ValueOpName)
- deriving (Eq, Ord, Show, Read)
+ deriving (Eq, Ord, Show)
data TypeFixity = TypeFixity Fixity (Qualified (ProperName 'TypeName)) (OpName 'TypeOpName)
- deriving (Eq, Ord, Show, Read)
+ deriving (Eq, Ord, Show)
-pattern ValueFixityDeclaration :: Fixity -> Qualified (Either Ident (ProperName 'ConstructorName)) -> OpName 'ValueOpName -> Declaration
+pattern ValueFixityDeclaration :: Fixity -> Qualified (Either Ident (ProperName 'ConstructorName)) -> OpName 'ValueOpName -> Declaration
pattern ValueFixityDeclaration fixity name op = FixityDeclaration (Left (ValueFixity fixity name op))
pattern TypeFixityDeclaration :: Fixity -> Qualified (ProperName 'TypeName) -> OpName 'TypeOpName -> Declaration
@@ -236,7 +378,7 @@ data TypeInstanceBody
= DerivedInstance
-- | This is a regular (explicit) instance
| ExplicitInstance [Declaration]
- deriving (Show, Read)
+ deriving (Show)
mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody
mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)
@@ -421,7 +563,9 @@ data Expr
-- at superclass implementations when searching for a dictionary, the type class name and
-- instance type, and the type class dictionaries in scope.
--
- | TypeClassDictionary Constraint (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))
+ | TypeClassDictionary Constraint
+ (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))
+ [ErrorMessageHint]
-- |
-- A typeclass dictionary accessor, the implementation is left unspecified until CoreFn desugaring.
--
@@ -442,7 +586,7 @@ data Expr
-- A value with source position information
--
| PositionedValue SourceSpan [Comment] Expr
- deriving (Show, Read)
+ deriving (Show)
-- |
-- An alternative in a case statement
@@ -456,7 +600,7 @@ data CaseAlternative = CaseAlternative
-- The result expression or a collect of guarded expressions
--
, caseAlternativeResult :: Either [(Guard, Expr)] Expr
- } deriving (Show, Read)
+ } deriving (Show)
-- |
-- A statement in a do-notation block
@@ -478,7 +622,7 @@ data DoNotationElement
-- A do notation element with source position information
--
| PositionedDoNotationElement SourceSpan [Comment] DoNotationElement
- deriving (Show, Read)
+ deriving (Show)
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef)
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType)
diff --git a/src/Language/PureScript/AST/Literals.hs b/src/Language/PureScript/AST/Literals.hs
index fae56ee..01da91d 100644
--- a/src/Language/PureScript/AST/Literals.hs
+++ b/src/Language/PureScript/AST/Literals.hs
@@ -34,4 +34,4 @@ data Literal a
-- An object literal
--
| ObjectLiteral [(String, a)]
- deriving (Eq, Ord, Show, Read, Functor)
+ deriving (Eq, Ord, Show, Functor)
diff --git a/src/Language/PureScript/AST/Operators.hs b/src/Language/PureScript/AST/Operators.hs
index 5ba0e15..0b8e536 100644
--- a/src/Language/PureScript/AST/Operators.hs
+++ b/src/Language/PureScript/AST/Operators.hs
@@ -21,7 +21,7 @@ type Precedence = Integer
-- Associativity for infix operators
--
data Associativity = Infixl | Infixr | Infix
- deriving (Show, Read, Eq, Ord)
+ deriving (Show, Eq, Ord)
showAssoc :: Associativity -> String
showAssoc Infixl = "infixl"
@@ -44,7 +44,7 @@ instance A.FromJSON Associativity where
-- Fixity data for infix operators
--
data Fixity = Fixity Associativity Precedence
- deriving (Show, Read, Eq, Ord)
+ deriving (Show, Eq, Ord)
instance A.ToJSON Fixity where
toJSON (Fixity associativity precedence) =
diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs
index 328c955..266a94e 100644
--- a/src/Language/PureScript/AST/SourcePos.hs
+++ b/src/Language/PureScript/AST/SourcePos.hs
@@ -22,7 +22,7 @@ data SourcePos = SourcePos
-- Column number
--
, sourcePosColumn :: Int
- } deriving (Show, Read, Eq, Ord)
+ } deriving (Show, Eq, Ord)
displaySourcePos :: SourcePos -> String
displaySourcePos sp =
@@ -50,7 +50,7 @@ data SourceSpan = SourceSpan
-- End of the span
--
, spanEnd :: SourcePos
- } deriving (Show, Read, Eq, Ord)
+ } deriving (Show, Eq, Ord)
displayStartEndPos :: SourceSpan -> String
displayStartEndPos sp =
diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs
index 801883a..7a851fb 100644
--- a/src/Language/PureScript/AST/Traversals.hs
+++ b/src/Language/PureScript/AST/Traversals.hs
@@ -582,7 +582,7 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con
forDecls (TypeDeclaration _ ty) = f ty
forDecls _ = mempty
- forValues (TypeClassDictionary c _) = mconcat (map f (constraintArgs c))
+ forValues (TypeClassDictionary c _ _) = mconcat (map f (constraintArgs c))
forValues (SuperClassDictionary _ tys) = mconcat (map f tys)
forValues (TypedValue _ _ ty) = f ty
forValues _ = mempty
diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs
index bdc6d90..1d94066 100644
--- a/src/Language/PureScript/Bundle.hs
+++ b/src/Language/PureScript/Bundle.hs
@@ -43,20 +43,20 @@ data ErrorMessage
| UnableToParseModule String
| UnsupportedExport
| ErrorInModule ModuleIdentifier ErrorMessage
- deriving (Show, Read)
+ deriving (Show)
-- | Modules are either "regular modules" (i.e. those generated by psc) or foreign modules.
data ModuleType
= Regular
| Foreign
- deriving (Show, Read, Eq, Ord)
+ deriving (Show, Eq, Ord)
showModuleType :: ModuleType -> String
showModuleType Regular = "Regular"
showModuleType Foreign = "Foreign"
-- | A module is identified by its module name and its type.
-data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Read, Eq, Ord)
+data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Eq, Ord)
moduleName :: ModuleIdentifier -> String
moduleName (ModuleIdentifier name _) = name
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index dfc1301..ba682c1 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -27,7 +27,9 @@ import Language.PureScript.CodeGen.JS.Common as Common
import Language.PureScript.CodeGen.JS.Optimizer
import Language.PureScript.CoreFn
import Language.PureScript.Crash
-import Language.PureScript.Errors
+import Language.PureScript.Errors (ErrorMessageHint(..), SimpleErrorMessage(..),
+ MultipleErrors(..), rethrow,
+ errorMessage, rethrowWithPosition, addHint)
import Language.PureScript.Names
import Language.PureScript.Options
import Language.PureScript.Traversals (sndM)
@@ -280,15 +282,18 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
extendObj obj sts = do
newObj <- freshName
key <- freshName
+ evaluatedObj <- freshName
let
jsKey = JSVar Nothing key
jsNewObj = JSVar Nothing newObj
- block = JSBlock Nothing (objAssign:copy:extend ++ [JSReturn Nothing jsNewObj])
+ jsEvaluatedObj = JSVar Nothing evaluatedObj
+ block = JSBlock Nothing (evaluate:objAssign:copy:extend ++ [JSReturn Nothing jsNewObj])
+ evaluate = JSVariableIntroduction Nothing evaluatedObj (Just obj)
objAssign = JSVariableIntroduction Nothing newObj (Just $ JSObjectLiteral Nothing [])
- copy = JSForIn Nothing key obj $ JSBlock Nothing [JSIfElse Nothing cond assign Nothing]
- cond = JSApp Nothing (JSAccessor Nothing "hasOwnProperty" obj) [jsKey]
- assign = JSBlock Nothing [JSAssignment Nothing (JSIndexer Nothing jsKey jsNewObj) (JSIndexer Nothing jsKey obj)]
- stToAssign (s, js) = JSAssignment Nothing (JSAccessor Nothing s jsNewObj) js
+ copy = JSForIn Nothing key jsEvaluatedObj $ JSBlock Nothing [JSIfElse Nothing cond assign Nothing]
+ cond = JSApp Nothing (JSAccessor Nothing "hasOwnProperty" jsEvaluatedObj) [jsKey]
+ assign = JSBlock Nothing [JSAssignment Nothing (JSIndexer Nothing jsKey jsNewObj) (JSIndexer Nothing jsKey jsEvaluatedObj)]
+ stToAssign (s, js) = JSAssignment Nothing (accessorString s jsNewObj) js
extend = map stToAssign sts
return $ JSApp Nothing (JSFunction Nothing Nothing [] block) []
diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs
index abc722e..b6e1b8a 100644
--- a/src/Language/PureScript/CodeGen/JS/AST.hs
+++ b/src/Language/PureScript/CodeGen/JS/AST.hs
@@ -35,7 +35,7 @@ data UnaryOperator
-- Constructor
--
| JSNew
- deriving (Show, Read, Eq)
+ deriving (Show, Eq)
-- |
-- Built-in binary operators
@@ -117,7 +117,7 @@ data BinaryOperator
-- Bitwise right shift with zero-fill
--
| ZeroFillShiftRight
- deriving (Show, Read, Eq)
+ deriving (Show, Eq)
-- |
-- Data type for simplified Javascript expressions
@@ -238,7 +238,7 @@ data JS
-- |
-- Commented Javascript
--
- | JSComment (Maybe SourceSpan) [Comment] JS deriving (Show, Read, Eq)
+ | JSComment (Maybe SourceSpan) [Comment] JS deriving (Show, Eq)
withSourceSpan :: SourceSpan -> JS -> JS
withSourceSpan withSpan = go
diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs
index 45b5391..f0d180c 100644
--- a/src/Language/PureScript/CodeGen/JS/Common.hs
+++ b/src/Language/PureScript/CodeGen/JS/Common.hs
@@ -35,7 +35,7 @@ identToJs (GenIdent _ _) = internalError "GenIdent in identToJs"
-- Test if a string is a valid JS identifier without escaping.
--
identNeedsEscaping :: String -> Bool
-identNeedsEscaping s = s /= identToJs (Ident s)
+identNeedsEscaping s = s /= identToJs (Ident s) || null s
-- |
-- Attempts to find a human-readable name for a symbol, if none has been specified returns the
diff --git a/src/Language/PureScript/Comments.hs b/src/Language/PureScript/Comments.hs
index 3bc00ce..15356eb 100644
--- a/src/Language/PureScript/Comments.hs
+++ b/src/Language/PureScript/Comments.hs
@@ -12,6 +12,6 @@ import Data.Aeson.TH
data Comment
= LineComment String
| BlockComment String
- deriving (Show, Read, Eq, Ord)
+ deriving (Show, Eq, Ord)
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Comment)
diff --git a/src/Language/PureScript/CoreFn/Binders.hs b/src/Language/PureScript/CoreFn/Binders.hs
index 5ef7061..acff617 100644
--- a/src/Language/PureScript/CoreFn/Binders.hs
+++ b/src/Language/PureScript/CoreFn/Binders.hs
@@ -31,7 +31,7 @@ data Binder a
-- |
-- A binder which binds its input to an identifier
--
- | NamedBinder a Ident (Binder a) deriving (Show, Read, Functor)
+ | NamedBinder a Ident (Binder a) deriving (Show, Functor)
extractBinderAnn :: Binder a -> a
diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs
index 4d7ae02..43479a7 100644
--- a/src/Language/PureScript/CoreFn/Expr.hs
+++ b/src/Language/PureScript/CoreFn/Expr.hs
@@ -51,7 +51,7 @@ data Expr a
-- A let binding
--
| Let a [Bind a] (Expr a)
- deriving (Show, Read, Functor)
+ deriving (Show, Functor)
-- |
-- A let or module binding.
@@ -64,7 +64,7 @@ data Bind a
-- |
-- Mutually recursive binding group for several values
--
- | Rec [((a, Ident), Expr a)] deriving (Show, Read, Functor)
+ | Rec [((a, Ident), Expr a)] deriving (Show, Functor)
-- |
-- A guard is just a boolean-valued expression that appears alongside a set of binders
@@ -83,7 +83,7 @@ data CaseAlternative a = CaseAlternative
-- The result expression or a collect of guarded expressions
--
, caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)
- } deriving (Show, Read)
+ } deriving (Show)
instance Functor CaseAlternative where
diff --git a/src/Language/PureScript/CoreFn/Meta.hs b/src/Language/PureScript/CoreFn/Meta.hs
index 220d474..88cbe7f 100644
--- a/src/Language/PureScript/CoreFn/Meta.hs
+++ b/src/Language/PureScript/CoreFn/Meta.hs
@@ -26,7 +26,7 @@ data Meta
-- |
-- The contained reference is for a foreign member
--
- | IsForeign deriving (Show, Read, Eq)
+ | IsForeign deriving (Show, Eq)
-- |
-- Data constructor metadata
@@ -39,4 +39,4 @@ data ConstructorType
-- |
-- The constructor is for a type with multiple construcors
--
- | SumType deriving (Show, Read, Eq)
+ | SumType deriving (Show, Eq)
diff --git a/src/Language/PureScript/CoreFn/Module.hs b/src/Language/PureScript/CoreFn/Module.hs
index 52f4f90..56fe0f7 100644
--- a/src/Language/PureScript/CoreFn/Module.hs
+++ b/src/Language/PureScript/CoreFn/Module.hs
@@ -17,6 +17,6 @@ data Module a = Module
, moduleExports :: [Ident]
, moduleForeign :: [ForeignDecl]
, moduleDecls :: [Bind a]
- } deriving (Show, Read)
+ } deriving (Show)
type ForeignDecl = (Ident, Type)
diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs
index 4a07663..1022e4c 100644
--- a/src/Language/PureScript/Docs/AsMarkdown.hs
+++ b/src/Language/PureScript/Docs/AsMarkdown.hs
@@ -110,7 +110,7 @@ childToString f decl@ChildDeclaration{..} =
data First
= First
| NotFirst
- deriving (Show, Read, Eq, Ord)
+ deriving (Show, Eq, Ord)
type Docs = Writer [String] ()
diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs
index a5f9c34..9eee086 100644
--- a/src/Language/PureScript/Docs/Convert.hs
+++ b/src/Language/PureScript/Docs/Convert.hs
@@ -158,7 +158,7 @@ insertValueTypes env m =
either (err . ("failed to parse Ident: " ++)) id . runParser P.parseIdent
lookupName name =
- let key = (modName m, name)
+ let key = P.Qualified (Just (modName m)) name
in case Map.lookup key (P.names env) of
Just (ty, _, _) ->
ty
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index c8c6b0a..d67f771 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -25,7 +25,7 @@ data Environment = Environment {
-- |
-- Value names currently in scope
--
- names :: M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)
+ names :: M.Map (Qualified Ident) (Type, NameKind, NameVisibility)
-- |
-- Type names currently in scope
--
@@ -46,7 +46,7 @@ data Environment = Environment {
-- Type classes
--
, typeClasses :: M.Map (Qualified (ProperName 'ClassName)) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])
- } deriving (Show, Read)
+ } deriving (Show)
-- |
-- The initial environment with no values and only the default javascript types defined
@@ -65,7 +65,7 @@ data NameVisibility
-- |
-- The name is defined in the another binding group, or has been made visible by a function binder
--
- | Defined deriving (Show, Read, Eq)
+ | Defined deriving (Show, Eq)
-- |
-- A flag for whether a name is for an private or public value - only public values will be
@@ -85,7 +85,7 @@ data NameKind
-- A name for member introduced by foreign import
--
| External
- deriving (Show, Read, Eq)
+ deriving (Show, Eq)
-- |
-- The kinds of a type
@@ -111,7 +111,7 @@ data TypeKind
-- A scoped type variable
--
| ScopedTypeVar
- deriving (Show, Read, Eq)
+ deriving (Show, Eq)
-- |
-- The type ('data' or 'newtype') of a data type declaration
@@ -125,7 +125,7 @@ data DataDeclType
-- A newtype constructor
--
| Newtype
- deriving (Show, Read, Eq, Ord)
+ deriving (Show, Eq, Ord)
showDataDeclType :: DataDeclType -> String
showDataDeclType Data = "data"
@@ -273,7 +273,6 @@ isNewtypeConstructor e ctor = case lookupConstructor e ctor of
-- Finds information about values from the current environment.
--
lookupValue :: Environment -> Qualified Ident -> Maybe (Type, NameKind, NameVisibility)
-lookupValue env (Qualified (Just mn) ident) = (mn, ident) `M.lookup` names env
-lookupValue _ _ = Nothing
+lookupValue env ident = ident `M.lookup` names env
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''TypeKind)
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index f19827f..b0c2d0f 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -1,7 +1,10 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
-module Language.PureScript.Errors where
+module Language.PureScript.Errors
+ ( module Language.PureScript.AST
+ , module Language.PureScript.Errors
+ ) where
import Prelude.Compat
@@ -14,6 +17,7 @@ import Control.Monad.Writer
import Data.Char (isSpace)
import Data.Either (lefts, rights)
import Data.Foldable (fold)
+import Data.Functor.Identity (Identity(..))
import Data.List (intercalate, transpose, nub, nubBy, sortBy, partition)
import Data.Maybe (maybeToList, fromMaybe, mapMaybe)
import Data.Ord (comparing)
@@ -21,7 +25,6 @@ import qualified Data.Map as M
import Language.PureScript.AST
import Language.PureScript.Crash
-import Language.PureScript.Kinds
import Language.PureScript.Names
import Language.PureScript.Pretty
import Language.PureScript.Traversals
@@ -37,137 +40,6 @@ import qualified Text.Parsec.Error as PE
import qualified Text.PrettyPrint.Boxes as Box
import Text.Parsec.Error (Message(..))
--- | A type of error messages
-data SimpleErrorMessage
- = ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)
- | ErrorParsingModule P.ParseError
- | MissingFFIModule ModuleName
- | MultipleFFIModules ModuleName [FilePath]
- | UnnecessaryFFIModule ModuleName FilePath
- | MissingFFIImplementations ModuleName [Ident]
- | UnusedFFIImplementations ModuleName [Ident]
- | InvalidFFIIdentifier ModuleName String
- | CannotGetFileInfo FilePath
- | CannotReadFile FilePath
- | CannotWriteFile FilePath
- | InfiniteType Type
- | InfiniteKind Kind
- | MultipleValueOpFixities (OpName 'ValueOpName)
- | MultipleTypeOpFixities (OpName 'TypeOpName)
- | OrphanTypeDeclaration Ident
- | RedefinedModule ModuleName [SourceSpan]
- | RedefinedIdent Ident
- | OverlappingNamesInLet
- | UnknownName (Qualified Name)
- | UnknownImport ModuleName Name
- | UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName)
- | UnknownExport Name
- | UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName)
- | ScopeConflict Name [ModuleName]
- | ScopeShadowing Name (Maybe ModuleName) [ModuleName]
- | DeclConflict Name Name
- | ExportConflict (Qualified Name) (Qualified Name)
- | DuplicateModuleName ModuleName
- | DuplicateTypeArgument String
- | InvalidDoBind
- | InvalidDoLet
- | CycleInDeclaration Ident
- | CycleInTypeSynonym (Maybe (ProperName 'TypeName))
- | CycleInModules [ModuleName]
- | NameIsUndefined Ident
- | UndefinedTypeVariable (ProperName 'TypeName)
- | PartiallyAppliedSynonym (Qualified (ProperName 'TypeName))
- | EscapedSkolem (Maybe Expr)
- | TypesDoNotUnify Type Type
- | KindsDoNotUnify Kind Kind
- | ConstrainedTypeUnified Type Type
- | OverlappingInstances (Qualified (ProperName 'ClassName)) [Type] [Qualified Ident]
- | NoInstanceFound Constraint
- | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type]
- | CannotDerive (Qualified (ProperName 'ClassName)) [Type]
- | CannotFindDerivingType (ProperName 'TypeName)
- | DuplicateLabel String (Maybe Expr)
- | DuplicateValueDeclaration Ident
- | ArgListLengthsDiffer Ident
- | OverlappingArgNames (Maybe Ident)
- | MissingClassMember Ident
- | ExtraneousClassMember Ident (Qualified (ProperName 'ClassName))
- | ExpectedType Type Kind
- | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName))
- | ExprDoesNotHaveType Expr Type
- | PropertyIsMissing String
- | AdditionalProperty String
- | CannotApplyFunction Type Expr
- | TypeSynonymInstance
- | OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type]
- | InvalidNewtype (ProperName 'TypeName)
- | InvalidInstanceHead Type
- | TransitiveExportError DeclarationRef [DeclarationRef]
- | TransitiveDctorExportError DeclarationRef (ProperName 'ConstructorName)
- | ShadowedName Ident
- | ShadowedTypeVar String
- | UnusedTypeVar String
- | WildcardInferredType Type
- | HoleInferredType String Type [(Ident, Type)]
- | MissingTypeDeclaration Ident Type
- | OverlappingPattern [[Binder]] Bool
- | IncompleteExhaustivityCheck
- | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName)
- | ImportHidingModule ModuleName
- | UnusedImport ModuleName
- | UnusedExplicitImport ModuleName [String] (Maybe ModuleName) [DeclarationRef]
- | UnusedDctorImport (ProperName 'TypeName)
- | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName]
- | DuplicateSelectiveImport ModuleName
- | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)
- | DuplicateImportRef Name
- | DuplicateExportRef Name
- | IntOutOfRange Integer String Integer Integer
- | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef]
- | ImplicitImport ModuleName [DeclarationRef]
- | HidingImport ModuleName [DeclarationRef]
- | CaseBinderLengthDiffers Int [Binder]
- | IncorrectAnonymousArgument
- | InvalidOperatorInBinder (Qualified (OpName 'ValueOpName)) (Qualified Ident)
- | DeprecatedRequirePath
- | CannotGeneralizeRecursiveFunction Ident Type
- deriving (Show)
-
--- | Error message hints, providing more detailed information about failure.
-data ErrorMessageHint
- = ErrorUnifyingTypes Type Type
- | ErrorInExpression Expr
- | ErrorInModule ModuleName
- | ErrorInInstance (Qualified (ProperName 'ClassName)) [Type]
- | ErrorInSubsumption Type Type
- | ErrorCheckingAccessor Expr String
- | ErrorCheckingType Expr Type
- | ErrorCheckingKind Type
- | ErrorCheckingGuard
- | ErrorInferringType Expr
- | ErrorInApplication Expr Type Expr
- | ErrorInDataConstructor (ProperName 'ConstructorName)
- | ErrorInTypeConstructor (ProperName 'TypeName)
- | ErrorInBindingGroup [Ident]
- | ErrorInDataBindingGroup
- | ErrorInTypeSynonym (ProperName 'TypeName)
- | ErrorInValueDeclaration Ident
- | ErrorInTypeDeclaration Ident
- | ErrorInForeignImport Ident
- | PositionedError SourceSpan
- deriving Show
-
--- | Categories of hints
-data HintCategory
- = ExprHint
- | KindHint
- | CheckHint
- | PositionHint
- | OtherHint
- deriving (Show, Eq)
-
-data ErrorMessage = ErrorMessage [ErrorMessageHint] SimpleErrorMessage deriving (Show)
-
newtype ErrorSuggestion = ErrorSuggestion String
-- | Get the source span for an error
@@ -321,7 +193,11 @@ onErrorMessages f = MultipleErrors . map f . runMultipleErrors
-- | Add a hint to an error message
addHint :: ErrorMessageHint -> MultipleErrors -> MultipleErrors
-addHint hint = onErrorMessages $ \(ErrorMessage hints se) -> ErrorMessage (hint : hints) se
+addHint hint = addHints [hint]
+
+-- | Add hints to an error message
+addHints :: [ErrorMessageHint] -> MultipleErrors -> MultipleErrors
+addHints hints = onErrorMessages $ \(ErrorMessage hints' se) -> ErrorMessage (hints ++ hints') se
-- | A map from rigid type variable name/unknown variable pairs to new variables.
data TypeMap = TypeMap
@@ -368,7 +244,10 @@ replaceUnknowns = everywhereOnTypesM replaceTypes
Just (_, s', _) -> return (Skolem name s' sko ss)
replaceTypes other = return other
-onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage
+onTypesInErrorMessage :: (Type -> Type) -> ErrorMessage -> ErrorMessage
+onTypesInErrorMessage f = runIdentity . onTypesInErrorMessageM (Identity . f)
+
+onTypesInErrorMessageM :: Applicative m => (Type -> m Type) -> ErrorMessage -> m ErrorMessage
onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gHint hints <*> gSimple simple
where
gSimple (InfiniteType t) = InfiniteType <$> f t
@@ -383,11 +262,10 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse
gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts
gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k
gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts
- gSimple (WildcardInferredType ty) = WildcardInferredType <$> f ty
- gSimple (HoleInferredType name ty env) = HoleInferredType name <$> f ty <*> traverse (sndM f) env
+ 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 (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty
gSimple (CannotGeneralizeRecursiveFunction nm ty) = CannotGeneralizeRecursiveFunction nm <$> f ty
-
gSimple other = pure other
gHint (ErrorInSubsumption t1 t2) = ErrorInSubsumption <$> f t1 <*> f t2
@@ -396,6 +274,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse
gHint (ErrorCheckingKind t) = ErrorCheckingKind <$> f t
gHint (ErrorInApplication e1 t1 e2) = ErrorInApplication e1 <$> f t1 <*> pure e2
gHint (ErrorInInstance cl ts) = ErrorInInstance cl <$> traverse f ts
+ gHint (ErrorSolvingConstraint con) = ErrorSolvingConstraint <$> overConstraintArgs (traverse f) con
gHint other = pure other
wikiUri :: ErrorMessage -> String
@@ -413,7 +292,7 @@ errorSuggestion err = case err of
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
+ WildcardInferredType ty _ -> suggest $ prettyPrintType ty
_ -> Nothing
where
@@ -845,24 +724,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
paras [ line "hiding imports cannot be used to hide modules."
, line $ "An attempt was made to hide the import of " ++ markCode (runModuleName name)
]
- renderSimpleErrorMessage (WildcardInferredType ty) =
- paras [ line "Wildcard type definition has the inferred type "
- , markCodeBox $ indent $ typeAsBox ty
- ]
- renderSimpleErrorMessage (HoleInferredType name ty env) =
+ renderSimpleErrorMessage (WildcardInferredType ty ctx) =
+ 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
- ] ++ if null env then [] else envInfo
- where
- envInfo :: [Box.Box]
- envInfo = [ line "in the following context:"
- , indent $ paras
- [ Box.hcat Box.left [ Box.text (showIdent ident <> " :: ")
- , markCodeBox $ typeAsBox ty'
- ]
- | (ident, ty') <- take 5 env
- ]
- ]
+ ] ++ 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."
@@ -1062,11 +931,31 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
paras [ detail
, line $ "in foreign import " ++ markCode (showIdent nm)
]
+ renderHint (ErrorSolvingConstraint (Constraint nm ts _)) detail =
+ paras [ detail
+ , line "while solving type class constriant"
+ , markCodeBox $ indent $ Box.hsep 1 Box.left
+ [ line (showQualified runProperName nm)
+ , Box.vcat Box.left (map typeAtomAsBox ts)
+ ]
+ ]
renderHint (PositionedError srcSpan) detail =
paras [ line $ "at " ++ displaySourceSpan srcSpan
, detail
]
+ renderContext :: Context -> [Box.Box]
+ renderContext [] = []
+ renderContext ctx =
+ [ line "in the following context:"
+ , indent $ paras
+ [ Box.hcat Box.left [ Box.text (showIdent ident <> " :: ")
+ , markCodeBox $ typeAsBox ty'
+ ]
+ | (ident, ty') <- take 5 ctx
+ ]
+ ]
+
printName :: Qualified Name -> String
printName qn = nameType (disqualify qn) ++ " " ++ markCode (runName qn)
@@ -1139,6 +1028,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
where
isUnifyHint ErrorUnifyingTypes{} = True
isUnifyHint _ = False
+ stripRedudantHints NoInstanceFound{} = stripFirst isSolverHint
+ where
+ isSolverHint ErrorSolvingConstraint{} = True
+ isSolverHint _ = False
stripRedudantHints _ = id
stripFirst :: (ErrorMessageHint -> Bool) -> [ErrorMessageHint] -> [ErrorMessageHint]
@@ -1150,15 +1043,16 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
stripFirst _ [] = []
hintCategory :: ErrorMessageHint -> HintCategory
- hintCategory ErrorCheckingType{} = ExprHint
- hintCategory ErrorInferringType{} = ExprHint
- hintCategory ErrorInExpression{} = ExprHint
- hintCategory ErrorUnifyingTypes{} = CheckHint
- hintCategory ErrorInSubsumption{} = CheckHint
- hintCategory ErrorInApplication{} = CheckHint
- hintCategory ErrorCheckingKind{} = CheckHint
- hintCategory PositionedError{} = PositionHint
- hintCategory _ = OtherHint
+ hintCategory ErrorCheckingType{} = ExprHint
+ hintCategory ErrorInferringType{} = ExprHint
+ hintCategory ErrorInExpression{} = ExprHint
+ hintCategory ErrorUnifyingTypes{} = CheckHint
+ hintCategory ErrorInSubsumption{} = CheckHint
+ hintCategory ErrorInApplication{} = CheckHint
+ hintCategory ErrorCheckingKind{} = CheckHint
+ hintCategory ErrorSolvingConstraint{} = SolverHint
+ hintCategory PositionedError{} = PositionHint
+ hintCategory _ = OtherHint
-- Pretty print and export declaration
prettyPrintExport :: DeclarationRef -> String
diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs
index e6a850c..f1b2f83 100644
--- a/src/Language/PureScript/Externs.hs
+++ b/src/Language/PureScript/Externs.hs
@@ -50,7 +50,7 @@ data ExternsFile = ExternsFile
, efTypeFixities :: [ExternsTypeFixity]
-- | List of type and value declaration
, efDeclarations :: [ExternsDeclaration]
- } deriving (Show, Read)
+ } deriving (Show)
-- | A module import in an externs file
data ExternsImport = ExternsImport
@@ -61,7 +61,7 @@ data ExternsImport = ExternsImport
, eiImportType :: ImportDeclarationType
-- | The imported-as name, for qualified imports
, eiImportedAs :: Maybe ModuleName
- } deriving (Show, Read)
+ } deriving (Show)
-- | A fixity declaration in an externs file
data ExternsFixity = ExternsFixity
@@ -74,7 +74,7 @@ data ExternsFixity = ExternsFixity
, efOperator :: OpName 'ValueOpName
-- | The value the operator is an alias for
, efAlias :: Qualified (Either Ident (ProperName 'ConstructorName))
- } deriving (Show, Read)
+ } deriving (Show)
-- | A type fixity declaration in an externs file
data ExternsTypeFixity = ExternsTypeFixity
@@ -87,7 +87,7 @@ data ExternsTypeFixity = ExternsTypeFixity
, efTypeOperator :: OpName 'TypeOpName
-- | The value the operator is an alias for
, efTypeAlias :: Qualified (ProperName 'TypeName)
- } deriving (Show, Read)
+ } deriving (Show)
-- | A type or value declaration appearing in an externs file
data ExternsDeclaration =
@@ -130,7 +130,7 @@ data ExternsDeclaration =
, edInstanceTypes :: [Type]
, edInstanceConstraints :: Maybe [Constraint]
}
- deriving (Show, Read)
+ deriving (Show)
-- | Convert an externs file back into a module
applyExternsFileToEnvironment :: ExternsFile -> Environment -> Environment
@@ -140,7 +140,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar
applyDecl env (EDType pn kind tyKind) = env { types = M.insert (qual pn) (kind, tyKind) (types env) }
applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) }
applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) }
- applyDecl env (EDValue ident ty) = env { names = M.insert (efModuleName, ident) (ty, External, Defined) (names env) }
+ applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (Just efModuleName) ident) (ty, External, Defined) (names env) }
applyDecl env (EDClass pn args members cs) = env { typeClasses = M.insert (qual pn) (args, members, cs) (typeClasses env) }
applyDecl env (EDInstance className ident tys cs) = env { typeClassDictionaries = updateMap (updateMap (M.insert (qual ident) dict) className) (Just efModuleName) (typeClassDictionaries env) }
where
@@ -201,7 +201,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}
]
_ -> internalError "toExternsDeclaration: Invalid input"
toExternsDeclaration (ValueRef ident)
- | Just (ty, _, _) <- (mn, ident) `M.lookup` names env
+ | Just (ty, _, _) <- Qualified (Just mn) ident `M.lookup` names env
= [ EDValue ident ty ]
toExternsDeclaration (TypeClassRef className)
| Just (args, members, implies) <- Qualified (Just mn) className `M.lookup` typeClasses env
diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs
index 31a20a2..0d6e48c 100644
--- a/src/Language/PureScript/Ide/Command.hs
+++ b/src/Language/PureScript/Ide/Command.hs
@@ -24,7 +24,6 @@ import Language.PureScript.Ide.CaseSplit
import Language.PureScript.Ide.Filter
import Language.PureScript.Ide.Matcher
import Language.PureScript.Ide.Types
-import System.FilePath
data Command
= Load [P.ModuleName]
diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs
index 37f0319..0e83745 100644
--- a/src/Language/PureScript/Ide/Externs.hs
+++ b/src/Language/PureScript/Ide/Externs.hs
@@ -33,7 +33,6 @@ import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
import qualified Language.PureScript as P
-import System.FilePath
readExternFile :: (MonadIO m, MonadError PscIdeError m) =>
FilePath -> m P.ExternsFile
diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs
index e26796e..8c64aa1 100644
--- a/src/Language/PureScript/Ide/Imports.hs
+++ b/src/Language/PureScript/Ide/Imports.hs
@@ -40,7 +40,6 @@ import Language.PureScript.Ide.Filter
import Language.PureScript.Ide.State
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
-import System.FilePath
data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName)
deriving (Eq, Show)
diff --git a/src/Language/PureScript/Ide/Pursuit.hs b/src/Language/PureScript/Ide/Pursuit.hs
index 9032a34..962f573 100644
--- a/src/Language/PureScript/Ide/Pursuit.hs
+++ b/src/Language/PureScript/Ide/Pursuit.hs
@@ -19,7 +19,7 @@ module Language.PureScript.Ide.Pursuit
, findPackagesForModuleIdent
) where
-import Protolude
+import Protolude hiding (fromStrict)
import qualified Control.Exception as E
import Data.Aeson
@@ -36,7 +36,7 @@ import qualified Pipes.Prelude as P
queryPursuit :: Text -> IO ByteString
queryPursuit q = do
let qClean = T.dropWhileEnd (== '.') q
- req' <- parseUrl "http://pursuit.purescript.org/search"
+ req' <- parseRequest "http://pursuit.purescript.org/search"
let req = req'
{ queryString= "q=" <> (fromString . T.unpack) qClean
, requestHeaders=[(hAccept, "application/json")]
diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs
index 9dad7a6..f543dbb 100644
--- a/src/Language/PureScript/Ide/Rebuild.hs
+++ b/src/Language/PureScript/Ide/Rebuild.hs
@@ -22,7 +22,6 @@ import Language.PureScript.Ide.State
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
import System.IO.UTF8 (readUTF8File)
-import System.FilePath
-- | Given a filepath performs the following steps:
--
diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs
index 6e9ba0c..ccca612 100644
--- a/src/Language/PureScript/Ide/SourceFile.hs
+++ b/src/Language/PureScript/Ide/SourceFile.hs
@@ -26,7 +26,6 @@ import qualified Language.PureScript as P
import Language.PureScript.Ide.Error
import Language.PureScript.Ide.Util
import Language.PureScript.Ide.Types
-import System.FilePath
import System.IO.UTF8 (readUTF8File)
parseModule
diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs
index 4621d39..55b2255 100644
--- a/src/Language/PureScript/Ide/State.hs
+++ b/src/Language/PureScript/Ide/State.hs
@@ -44,7 +44,6 @@ import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
import qualified Language.PureScript as P
import System.Clock
-import System.FilePath
-- | Resets all State inside psc-ide
resetIdeState :: Ide m => m ()
diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs
index 6bcfc7e..c8c3758 100644
--- a/src/Language/PureScript/Ide/Types.hs
+++ b/src/Language/PureScript/Ide/Types.hs
@@ -25,7 +25,6 @@ import Data.Map.Lazy as M
import qualified Language.PureScript.Errors.JSON as P
import qualified Language.PureScript as P
import Language.PureScript.Ide.Conversions
-import System.FilePath
import Text.Parsec as Parsec
import Text.Parsec.Text
diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs
index 4e4c235..548e1f4 100644
--- a/src/Language/PureScript/Ide/Util.hs
+++ b/src/Language/PureScript/Ide/Util.hs
@@ -27,7 +27,7 @@ module Language.PureScript.Ide.Util
, module Language.PureScript.Ide.Conversions
) where
-import Protolude
+import Protolude hiding (decodeUtf8, encodeUtf8)
import Data.Aeson
import qualified Data.Text as T
import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)
diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs
index f39f90e..49f0a73 100644
--- a/src/Language/PureScript/Interactive.hs
+++ b/src/Language/PureScript/Interactive.hs
@@ -234,7 +234,7 @@ handleTypeOf val = do
case e of
Left errs -> printErrors errs
Right (_, env') ->
- case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of
+ case M.lookup (P.mkQualified (P.Ident "it") (P.ModuleName [P.ProperName "$PSCI"])) (P.names env') of
Just (ty, _, _) -> liftIO . putStrLn . P.prettyPrintType $ ty
Nothing -> liftIO $ putStrLn "Could not find type"
diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs
index 135ea6b..c332f05 100644
--- a/src/Language/PureScript/Interactive/Completion.hs
+++ b/src/Language/PureScript/Interactive/Completion.hs
@@ -91,7 +91,7 @@ data CompletionContext
| CtxIdentifier
| CtxType
| CtxFixed String
- deriving (Show, Read)
+ deriving (Show)
-- |
-- Decide what kind of completion we need based on input. This function expects
diff --git a/src/Language/PureScript/Interactive/Printer.hs b/src/Language/PureScript/Interactive/Printer.hs
index 6147405..9f33522 100644
--- a/src/Language/PureScript/Interactive/Printer.hs
+++ b/src/Language/PureScript/Interactive/Printer.hs
@@ -19,9 +19,10 @@ import qualified Text.PrettyPrint.Boxes as Box
printModuleSignatures :: P.ModuleName -> P.Environment -> String
printModuleSignatures moduleName (P.Environment {..}) =
-- get relevant components of a module from environment
- let moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) names
- moduleTypeClasses = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) typeClasses
- moduleTypes = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) types
+ let moduleNamesIdent = byModuleName names
+ moduleTypeClasses = byModuleName typeClasses
+ moduleTypes = byModuleName types
+ byModuleName = filter ((== Just moduleName) . P.getQual) . M.keys
in
-- print each component
@@ -33,8 +34,10 @@ printModuleSignatures moduleName (P.Environment {..}) =
where printModule's showF = Box.vsep 1 Box.left . showF
- findNameType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility))
- findNameType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)
+ findNameType :: M.Map (P.Qualified P.Ident) (P.Type, P.NameKind, P.NameVisibility)
+ -> P.Qualified P.Ident
+ -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility))
+ findNameType envNames m = (P.disqualify m, M.lookup m envNames)
showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box
showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType
diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs
index 139dd58..519584e 100644
--- a/src/Language/PureScript/Kinds.hs
+++ b/src/Language/PureScript/Kinds.hs
@@ -20,7 +20,7 @@ data Kind
| FunKind Kind Kind
-- | Type-level strings
| Symbol
- deriving (Show, Read, Eq, Ord)
+ deriving (Show, Eq, Ord)
$(A.deriveJSON A.defaultOptions ''Kind)
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index d4dc6e3..b4f928a 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -36,6 +36,7 @@ import Control.Monad.Trans.Except
import Control.Monad.Writer.Class (MonadWriter(..))
import Data.Aeson (encode, decode)
+import Data.ByteString.Builder (toLazyByteString, stringUtf8)
import Data.Either (partitionEithers)
import Data.Foldable (for_)
import Data.List (foldl', sort)
@@ -85,7 +86,7 @@ import qualified Text.Parsec as Parsec
-- | Progress messages from the make process
data ProgressMessage
= CompilingModule ModuleName
- deriving (Show, Read, Eq, Ord)
+ deriving (Show, Eq, Ord)
-- | Render a progress message
renderProgressMessage :: ProgressMessage -> String
@@ -129,7 +130,7 @@ data RebuildPolicy
-- | Never rebuild this module
= RebuildNever
-- | Always rebuild this module
- | RebuildAlways deriving (Show, Read, Eq, Ord)
+ | RebuildAlways deriving (Show, Eq, Ord)
-- | Rebuild a single module
rebuildModule :: forall m. (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
@@ -252,7 +253,7 @@ make ma@MakeActions{..} ms = do
decodeExterns :: Externs -> Maybe ExternsFile
decodeExterns bs = do
- externs <- decode (fromString bs)
+ externs <- decode (toLazyByteString (stringUtf8 bs))
guard $ efVersion externs == showVersion Paths.version
return externs
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index 0f99ca9..6df8185 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -64,7 +64,7 @@ data Ident
-- A generated name for an identifier
--
| GenIdent (Maybe String) Integer
- deriving (Show, Read, Eq, Ord)
+ deriving (Show, Eq, Ord)
runIdent :: Ident -> String
runIdent (Ident i) = i
@@ -84,7 +84,7 @@ freshIdent' = GenIdent Nothing <$> fresh
-- Operator alias names.
--
newtype OpName (a :: OpNameType) = OpName { runOpName :: String }
- deriving (Show, Read, Eq, Ord)
+ deriving (Show, Eq, Ord)
instance ToJSON (OpName a) where
toJSON = toJSON . runOpName
@@ -104,7 +104,7 @@ data OpNameType = ValueOpName | TypeOpName
-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.
--
newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: String }
- deriving (Show, Read, Eq, Ord)
+ deriving (Show, Eq, Ord)
instance ToJSON (ProperName a) where
toJSON = toJSON . runProperName
@@ -129,7 +129,7 @@ coerceProperName = ProperName . runProperName
-- Module names
--
newtype ModuleName = ModuleName [ProperName 'Namespace]
- deriving (Show, Read, Eq, Ord)
+ deriving (Show, Eq, Ord)
runModuleName :: ModuleName -> String
runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns)
@@ -146,7 +146,7 @@ moduleNameFromString = ModuleName . splitProperNames
-- A qualified name, i.e. a name with an optional module name
--
data Qualified a = Qualified (Maybe ModuleName) a
- deriving (Show, Read, Eq, Ord, Functor)
+ deriving (Show, Eq, Ord, Functor)
showQualified :: (a -> String) -> Qualified a -> String
showQualified f (Qualified Nothing a) = f a
diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs
index b76e6eb..4944861 100644
--- a/src/Language/PureScript/Parser/Lexer.hs
+++ b/src/Language/PureScript/Parser/Lexer.hs
@@ -104,7 +104,7 @@ data Token
| StringLiteral String
| Number (Either Integer Double)
| HoleLit String
- deriving (Show, Read, Eq, Ord)
+ deriving (Show, Eq, Ord)
prettyPrintToken :: Token -> String
prettyPrintToken LParen = "("
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index 93365cf..6a8ea61 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -60,7 +60,7 @@ prettyPrintValue d (Let ds val) =
(text "in " <> prettyPrintValue (d - 1) val)
prettyPrintValue d (Do els) =
text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els)
-prettyPrintValue _ (TypeClassDictionary (Constraint name tys _) _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys
+prettyPrintValue _ (TypeClassDictionary (Constraint name tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys
prettyPrintValue _ (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name)
prettyPrintValue _ (TypeClassDictionaryAccessor className ident) =
text "#dict-accessor " <> text (runProperName (disqualify className)) <> text "." <> text (showIdent ident) <> text ">"
diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs
index d2bfc8c..d1ce4b5 100644
--- a/src/Language/PureScript/Publish.hs
+++ b/src/Language/PureScript/Publish.hs
@@ -169,7 +169,7 @@ getModulesAndBookmarks = do
Left err ->
userError (CompileError err)
-data TreeStatus = Clean | Dirty deriving (Show, Read, Eq, Ord, Enum)
+data TreeStatus = Clean | Dirty deriving (Show, Eq, Ord, Enum)
getGitWorkingTreeStatus :: PrepareM TreeStatus
getGitWorkingTreeStatus = do
@@ -273,7 +273,7 @@ data DependencyStatus
| ResolvedVersion String
-- ^ Resolved to a version. The String argument is the resolution tag (eg,
-- "v0.1.0").
- deriving (Show, Read, Eq)
+ deriving (Show, Eq)
-- Go through all bower dependencies which contain purescript code, and
-- extract their versions.
diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs
index de29d11..36c5700 100644
--- a/src/Language/PureScript/Sugar/Names/Env.hs
+++ b/src/Language/PureScript/Sugar/Names/Env.hs
@@ -49,7 +49,7 @@ data ImportRecord a =
, importSourceModule :: ModuleName
, importProvenance :: ImportProvenance
}
- deriving (Eq, Ord, Show, Read)
+ deriving (Eq, Ord, Show)
-- |
-- Used to track how an import was introduced into scope. This allows us to
@@ -61,7 +61,7 @@ data ImportProvenance
| FromExplicit
| Local
| Prim
- deriving (Eq, Ord, Show, Read)
+ deriving (Eq, Ord, Show)
type ImportMap a = M.Map (Qualified a) [ImportRecord a]
@@ -104,7 +104,7 @@ data Imports = Imports
-- The "as" names of modules that have been imported qualified.
--
, importedQualModules :: S.Set ModuleName
- } deriving (Show, Read)
+ } deriving (Show)
nullImports :: Imports
nullImports = Imports M.empty M.empty M.empty M.empty M.empty M.empty S.empty S.empty
@@ -155,7 +155,7 @@ data Exports = Exports
-- from.
--
, exportedValueOps :: M.Map (OpName 'ValueOpName) ModuleName
- } deriving (Show, Read)
+ } deriving (Show)
-- |
-- An empty 'Exports' value.
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index 9f38455..10d09d2 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -329,9 +329,9 @@ updateTypes goType = (goDecl, goExpr, goBinder)
goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr)
goExpr _ e@(PositionedValue pos _ _) = return (Just pos, e)
- goExpr pos (TypeClassDictionary (Constraint name tys info) dicts) = do
+ goExpr pos (TypeClassDictionary (Constraint name tys info) dicts hints) = do
tys' <- traverse (goType' pos) tys
- return (pos, TypeClassDictionary (Constraint name tys' info) dicts)
+ return (pos, TypeClassDictionary (Constraint name tys' info) dicts hints)
goExpr pos (SuperClassDictionary cls tys) = do
tys' <- traverse (goType' pos) tys
return (pos, SuperClassDictionary cls tys')
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 44ff0d1..7262224 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -11,9 +11,8 @@ module Language.PureScript.Sugar.TypeClasses
import Prelude.Compat
import Language.PureScript.Crash
-import Language.PureScript.AST hiding (isExported)
import Language.PureScript.Environment
-import Language.PureScript.Errors
+import Language.PureScript.Errors hiding (isExported)
import Language.PureScript.Kinds
import Language.PureScript.Names
import Language.PureScript.Externs
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 95ffb95..bfadcdd 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -91,7 +91,7 @@ valueIsNotDefined
-> m ()
valueIsNotDefined moduleName name = do
env <- getEnv
- case M.lookup (moduleName, name) (names env) of
+ case M.lookup (Qualified (Just moduleName) name) (names env) of
Just _ -> throwError . errorMessage $ RedefinedIdent name
Nothing -> return ()
@@ -104,7 +104,7 @@ addValue
-> m ()
addValue moduleName name ty nameKind = do
env <- getEnv
- putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) })
+ putEnv (env { names = M.insert (Qualified (Just moduleName) name) (ty, nameKind, Defined) (names env) })
addTypeClass
:: (MonadState CheckState m)
@@ -259,9 +259,9 @@ typeCheckAll moduleName _ = traverse go
env <- getEnv
kind <- kindOf ty
guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star
- case M.lookup (moduleName, name) (names env) of
+ case M.lookup (Qualified (Just moduleName) name) (names env) of
Just _ -> throwError . errorMessage $ RedefinedIdent name
- Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) })
+ Nothing -> putEnv (env { names = M.insert (Qualified (Just moduleName) name) (ty, External, Defined) (names env) })
return d
go d@FixityDeclaration{} = return d
go d@ImportDeclaration{} = return d
@@ -360,7 +360,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) =
Just (_, _, ty, _) -> checkExport dr extract ty
return ()
checkMemberExport extract dr@(ValueRef name) = do
- ty <- lookupVariable mn (Qualified (Just mn) name)
+ ty <- lookupVariable (Qualified (Just mn) name)
checkExport dr extract ty
checkMemberExport _ _ = return ()
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
index 73d696e..c15d628 100644
--- a/src/Language/PureScript/TypeChecker/Entailment.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -2,7 +2,7 @@
-- Type class entailment
--
module Language.PureScript.TypeChecker.Entailment
- ( Context
+ ( InstanceContext
, replaceTypeClassDictionaries
) where
@@ -22,24 +22,25 @@ import Language.PureScript.AST
import Language.PureScript.Crash
import Language.PureScript.Errors
import Language.PureScript.Names
+import Language.PureScript.TypeChecker.Monad (CheckState, withErrorMessageHint)
import Language.PureScript.TypeChecker.Unify
import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Types
import qualified Language.PureScript.Constants as C
--- | The 'Context' tracks those constraints which can be satisfied.
-type Context = M.Map (Maybe ModuleName)
- (M.Map (Qualified (ProperName 'ClassName))
- (M.Map (Qualified Ident)
- TypeClassDictionaryInScope))
+-- | The 'InstanceContext' tracks those constraints which can be satisfied.
+type InstanceContext = M.Map (Maybe ModuleName)
+ (M.Map (Qualified (ProperName 'ClassName))
+ (M.Map (Qualified Ident)
+ TypeClassDictionaryInScope))
-- | Merge two type class contexts
-combineContexts :: Context -> Context -> Context
+combineContexts :: InstanceContext -> InstanceContext -> InstanceContext
combineContexts = M.unionWith (M.unionWith M.union)
-- | Replace type class dictionary placeholders with inferred type class dictionaries
replaceTypeClassDictionaries
- :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)
+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)
=> Bool
-> ModuleName
-> Expr
@@ -48,7 +49,8 @@ replaceTypeClassDictionaries shouldGeneralize mn =
let (_, f, _) = everywhereOnValuesTopDownM return (WriterT . go) return
in flip evalStateT M.empty . runWriterT . f
where
- go (TypeClassDictionary constraint dicts) = entails shouldGeneralize mn dicts constraint
+ go (TypeClassDictionary constraint dicts hints) =
+ rethrow (addHints hints) $ entails shouldGeneralize mn dicts constraint
go other = return (other, [])
-- |
@@ -57,15 +59,15 @@ replaceTypeClassDictionaries shouldGeneralize mn =
--
entails
:: forall m
- . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)
+ . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)
=> Bool
-> ModuleName
- -> Context
+ -> InstanceContext
-> Constraint
- -> StateT Context m (Expr, [(Ident, Constraint)])
+ -> StateT InstanceContext m (Expr, [(Ident, Constraint)])
entails shouldGeneralize moduleName context = solve
where
- forClassName :: Context -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope]
+ forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope]
forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys))
forClassName _ _ _ = internalError "forClassName: expected qualified class name"
@@ -75,15 +77,15 @@ entails shouldGeneralize moduleName context = solve
ctorModules (TypeApp ty _) = ctorModules ty
ctorModules _ = Nothing
- findDicts :: Context -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope]
+ findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope]
findDicts ctx cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup ctx
- solve :: Constraint -> StateT Context m (Expr, [(Ident, Constraint)])
- solve con = do
+ solve :: Constraint -> StateT InstanceContext m (Expr, [(Ident, Constraint)])
+ solve con = StateT . (withErrorMessageHint (ErrorSolvingConstraint con) .) . runStateT $ do
(dict, unsolved) <- go 0 con
return (dictionaryValueToValue dict, unsolved)
where
- go :: Int -> Constraint -> StateT Context m (DictionaryValue, [(Ident, Constraint)])
+ go :: Int -> Constraint -> StateT InstanceContext m (DictionaryValue, [(Ident, Constraint)])
go work (Constraint className' tys' _) | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'
go work con'@(Constraint className' tys' _) = do
-- Get the inferred constraint context so far, and merge it with the global context
@@ -106,7 +108,7 @@ entails shouldGeneralize moduleName context = solve
-- Generate a fresh name for the unsolved constraint's new dictionary
ident <- freshIdent ("dict" ++ runProperName pn)
let qident = Qualified Nothing ident
- -- Store the new dictionary in the Context so that we can solve this goal in
+ -- Store the new dictionary in the InstanceContext so that we can solve this goal in
-- future.
let newDict = TypeClassDictionaryInScope qident [] unsolvedClassName unsolvedTys Nothing
newContext = M.singleton Nothing (M.singleton unsolvedClassName (M.singleton qident newDict))
@@ -143,7 +145,7 @@ entails shouldGeneralize moduleName context = solve
-- 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 :: [(String, Type)] -> Maybe [Constraint] -> StateT Context m (Maybe [DictionaryValue], [(Ident, Constraint)])
+ solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> StateT InstanceContext m (Maybe [DictionaryValue], [(Ident, Constraint)])
solveSubgoals _ Nothing = return (Nothing, [])
solveSubgoals subst (Just subgoals) = do
zipped <- traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars subst))) subgoals
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index ea5d598..3d35684 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -107,7 +107,7 @@ kindOfWithScopedVars ::
Type ->
m (Kind, [(String, Kind)])
kindOfWithScopedVars ty =
- rethrow (addHint (ErrorCheckingKind ty)) $
+ withErrorMessageHint (ErrorCheckingKind ty) $
fmap tidyUp . liftUnify $ infer ty
where
tidyUp ((k, args), sub) = ( starIfUnknown (substituteKind sub k)
@@ -200,7 +200,7 @@ infer
:: (MonadError MultipleErrors m, MonadState CheckState m)
=> Type
-> m (Kind, [(String, Kind)])
-infer ty = rethrow (addHint (ErrorCheckingKind ty)) $ infer' ty
+infer ty = withErrorMessageHint (ErrorCheckingKind ty) $ infer' ty
infer'
:: forall m
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 0635f0a..b229ca3 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -35,18 +35,30 @@ emptySubstitution = Substitution M.empty M.empty
-- | State required for type checking
data CheckState = CheckState
- { checkEnv :: Environment -- ^ The current @Environment@
- , checkNextType :: Int -- ^ The next type unification variable
- , checkNextKind :: Int -- ^ The next kind unification variable
- , checkNextSkolem :: Int -- ^ The next skolem variable
- , checkNextSkolemScope :: Int -- ^ The next skolem scope constant
- , checkCurrentModule :: Maybe ModuleName -- ^ The current module
- , checkSubstitution :: Substitution -- ^ The current substitution
+ { checkEnv :: Environment
+ -- ^ The current @Environment@
+ , checkNextType :: Int
+ -- ^ The next type unification variable
+ , checkNextKind :: Int
+ -- ^ The next kind unification variable
+ , checkNextSkolem :: Int
+ -- ^ The next skolem variable
+ , checkNextSkolemScope :: Int
+ -- ^ The next skolem scope constant
+ , checkCurrentModule :: Maybe ModuleName
+ -- ^ The current module
+ , checkSubstitution :: Substitution
+ -- ^ The current substitution
+ , checkHints :: [ErrorMessageHint]
+ -- ^ The current error message hint stack.
+ -- This goes into state, rather than using 'rethrow',
+ -- since this way, we can provide good error messages
+ -- during instance resolution.
}
-- | Create an empty @CheckState@
emptyCheckState :: Environment -> CheckState
-emptyCheckState env = CheckState env 0 0 0 0 Nothing emptySubstitution
+emptyCheckState env = CheckState env 0 0 0 0 Nothing emptySubstitution []
-- | Unification variables
type Unknown = Int
@@ -54,7 +66,7 @@ type Unknown = Int
-- | Temporarily bind a collection of names to values
bindNames
:: MonadState CheckState m
- => M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)
+ => M.Map (Qualified Ident) (Type, NameKind, NameVisibility)
-> m a
-> m a
bindNames newNames action = do
@@ -91,6 +103,33 @@ withScopedTypeVars mn ks ma = do
tell . errorMessage $ ShadowedTypeVar name
bindTypes (M.fromList (map (\(name, k) -> (Qualified (Just mn) (ProperName name), (k, ScopedTypeVar))) ks)) ma
+withErrorMessageHint
+ :: (MonadState CheckState m, MonadError MultipleErrors m)
+ => ErrorMessageHint
+ -> m a
+ -> m a
+withErrorMessageHint hint action = do
+ orig <- get
+ modify $ \st -> st { checkHints = hint : checkHints st }
+ -- Need to use 'rethrow' anyway, since we have to handle regular errors
+ a <- rethrow (addHint hint) action
+ modify $ \st -> st { checkHints = checkHints orig }
+ return a
+
+rethrowWithPositionTC
+ :: (MonadState CheckState m, MonadError MultipleErrors m)
+ => SourceSpan
+ -> m a
+ -> m a
+rethrowWithPositionTC pos = withErrorMessageHint (PositionedError pos)
+
+warnAndRethrowWithPositionTC
+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => SourceSpan
+ -> m a
+ -> m a
+warnAndRethrowWithPositionTC pos = rethrowWithPositionTC pos . warnWithPosition pos
+
-- | Temporarily make a collection of type class dictionaries available
withTypeClassDictionaries
:: MonadState CheckState m
@@ -121,12 +160,11 @@ lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDict
-- | Temporarily bind a collection of names to local variables
bindLocalVariables
:: (MonadState CheckState m)
- => ModuleName
- -> [(Ident, Type, NameVisibility)]
+ => [(Ident, Type, NameVisibility)]
-> m a
-> m a
-bindLocalVariables moduleName bindings =
- bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> ((moduleName, name), (ty, Private, visibility)))
+bindLocalVariables bindings =
+ bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> (Qualified Nothing name, (ty, Private, visibility)))
-- | Temporarily bind a collection of names to local type variables
bindLocalTypeVariables
@@ -157,35 +195,32 @@ preservingNames action = do
-- | Lookup the type of a value by name in the @Environment@
lookupVariable
:: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)
- => ModuleName
- -> Qualified Ident
+ => Qualified Ident
-> m Type
-lookupVariable currentModule (Qualified moduleName var) = do
+lookupVariable qual = do
env <- getEnv
- case M.lookup (fromMaybe currentModule moduleName, var) (names env) of
- Nothing -> throwError . errorMessage $ NameIsUndefined var
+ case M.lookup qual (names env) of
+ Nothing -> throwError . errorMessage $ NameIsUndefined (disqualify qual)
Just (ty, _, _) -> return ty
-- | Lookup the visibility of a value by name in the @Environment@
getVisibility
:: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)
- => ModuleName
- -> Qualified Ident
+ => Qualified Ident
-> m NameVisibility
-getVisibility currentModule (Qualified moduleName var) = do
+getVisibility qual = do
env <- getEnv
- case M.lookup (fromMaybe currentModule moduleName, var) (names env) of
- Nothing -> throwError . errorMessage $ NameIsUndefined var
+ case M.lookup qual (names env) of
+ Nothing -> throwError . errorMessage $ NameIsUndefined (disqualify qual)
Just (_, _, vis) -> return vis
-- | Assert that a name is visible
checkVisibility
:: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)
- => ModuleName
- -> Qualified Ident
+ => Qualified Ident
-> m ()
-checkVisibility currentModule name@(Qualified _ var) = do
- vis <- getVisibility currentModule name
+checkVisibility name@(Qualified _ var) = do
+ vis <- getVisibility name
case vis of
Undefined -> throwError . errorMessage $ CycleInDeclaration var
_ -> return ()
@@ -206,6 +241,12 @@ lookupTypeVariable currentModule (Qualified moduleName name) = do
getEnv :: (MonadState CheckState m) => m Environment
getEnv = checkEnv <$> get
+-- | Get locally-bound names in context, to create an error message.
+getLocalContext :: MonadState CheckState m => m Context
+getLocalContext = do
+ env <- getEnv
+ return [ (ident, ty') | ((Qualified Nothing ident@Ident{}), (ty', _, Defined)) <- M.toList (names env) ]
+
-- | Update the @Environment@
putEnv :: (MonadState CheckState m) => Environment -> m ()
putEnv env = modify (\s -> s { checkEnv = env })
diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs
index b7cd9de..148ca45 100644
--- a/src/Language/PureScript/TypeChecker/Subsumption.hs
+++ b/src/Language/PureScript/TypeChecker/Subsumption.hs
@@ -8,7 +8,7 @@ module Language.PureScript.TypeChecker.Subsumption
import Prelude.Compat
import Control.Monad.Error.Class (MonadError(..))
-import Control.Monad.State.Class (MonadState(..))
+import Control.Monad.State.Class (MonadState(..), gets)
import Data.List (sortBy)
import Data.Ord (comparing)
@@ -24,7 +24,7 @@ import Language.PureScript.Types
-- | 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 = rethrow (addHint (ErrorInSubsumption ty1 ty2)) $ subsumes' val ty1 ty2
+subsumes val ty1 ty2 = withErrorMessageHint (ErrorInSubsumption ty1 ty2) $ subsumes' val ty1 ty2
-- | Check tahat one type subsumes another
subsumes' :: (MonadError MultipleErrors m, MonadState CheckState m) =>
@@ -52,7 +52,8 @@ subsumes' val ty1 (KindedType ty2 _) =
subsumes val ty1 ty2
subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do
dicts <- getTypeClassDictionaries
- subsumes' (Just $ foldl App val (map (flip TypeClassDictionary dicts) constraints)) ty1 ty2
+ 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
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index e405537..0804db3 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -26,7 +26,6 @@ module Language.PureScript.TypeChecker.Types
import Prelude.Compat
-import Control.Arrow (second)
import Control.Monad
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.State.Class (MonadState(..), gets)
@@ -71,7 +70,7 @@ typesOf ::
m [(Ident, (Expr, Type))]
typesOf bindingGroupType moduleName vals = do
tys <- fmap tidyUp . escalateWarningWhen isHoleError . liftUnifyWarnings replace $ do
- (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals
+ (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)
@@ -117,26 +116,21 @@ typesOf bindingGroupType moduleName vals = do
tidyUp (ts, sub) = map (\(b, (i, (val, ty))) -> (b, (i, (overTypes (substituteType sub) val, substituteType sub ty)))) ts
-- Replace all the wildcards types with their inferred types
- replace sub (ErrorMessage hints (WildcardInferredType ty)) =
- ErrorMessage hints . WildcardInferredType $ substituteType sub ty
- replace sub (ErrorMessage hints (HoleInferredType name ty env)) =
- ErrorMessage hints $ HoleInferredType name (substituteType sub ty)
- (map (second (substituteType sub)) env)
- replace _ em = em
+ replace sub = onTypesInErrorMessage (substituteType sub)
isHoleError :: ErrorMessage -> Bool
isHoleError (ErrorMessage _ HoleInferredType{}) = True
isHoleError _ = False
-type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)
+type TypeData = M.Map (Qualified Ident) (Type, NameKind, NameVisibility)
type UntypedData = [(Ident, Type)]
-typeDictionaryForBindingGroup ::
- (MonadState CheckState m) =>
- ModuleName ->
- [(Ident, Expr)] ->
- m ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData)
+typeDictionaryForBindingGroup
+ :: (MonadState CheckState m)
+ => Maybe ModuleName
+ -> [(Ident, Expr)]
+ -> m ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData)
typeDictionaryForBindingGroup moduleName vals = do
let
-- Map each declaration to a name/value pair, with an optional type, if the declaration is typed
@@ -154,15 +148,15 @@ typeDictionaryForBindingGroup moduleName vals = do
-- Make a map of names to the unification variables of untyped declarations
untypedDict = zip (map fst untyped) untypedNames
-- Create the dictionary of all name/type pairs, which will be added to the environment during type checking
- dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, Private, Undefined))) $ typedDict ++ untypedDict)
+ dict = M.fromList (map (\(ident, ty) -> ((Qualified moduleName ident), (ty, Private, Undefined))) $ typedDict ++ untypedDict)
return (untyped, typed, dict, untypedDict)
-checkTypedBindingGroupElement ::
- (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- ModuleName ->
- (Ident, (Expr, Type, Bool)) ->
- TypeData ->
- m (Ident, (Expr, Type))
+checkTypedBindingGroupElement
+ :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => ModuleName
+ -> (Ident, (Expr, Type, Bool))
+ -> TypeData
+ -> m (Ident, (Expr, Type))
checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do
-- Replace type wildcards
ty' <- replaceTypeWildcards ty
@@ -176,12 +170,12 @@ checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do
else return (TypedValue False val' ty'')
return (ident, (val'', ty''))
-typeForBindingGroupElement ::
- (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- (Ident, Expr) ->
- TypeData ->
- UntypedData ->
- m (Ident, (Expr, Type))
+typeForBindingGroupElement
+ :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => (Ident, Expr)
+ -> TypeData
+ -> UntypedData
+ -> m (Ident, (Expr, Type))
typeForBindingGroupElement (ident, val) dict untypedDict = do
-- Infer the type with the new names in scope
TypedValue _ val' ty <- bindNames dict $ infer val
@@ -201,7 +195,7 @@ 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) = TypeClassDictionary (mapConstraintArgs (map f) c) sco
+ 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 *.
@@ -227,7 +221,8 @@ instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do
instantiatePolyTypeWithUnknowns val ty'
instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do
dicts <- getTypeClassDictionaries
- instantiatePolyTypeWithUnknowns (foldl App val (map (flip TypeClassDictionary dicts) constraints)) ty
+ hints <- gets checkHints
+ instantiatePolyTypeWithUnknowns (foldl App val (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) ty
instantiatePolyTypeWithUnknowns val ty = return (val, ty)
-- | Infer a type for a value, rethrowing any error to provide a more useful error message
@@ -235,7 +230,7 @@ infer ::
(MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
Expr ->
m Expr
-infer val = rethrow (addHint (ErrorInferringType val)) $ infer' val
+infer val = withErrorMessageHint (ErrorInferringType val) $ infer' val
-- | Infer a type for a value
infer' ::
@@ -250,8 +245,11 @@ infer' v@(Literal (BooleanLiteral _)) = return $ TypedValue True v tyBoolean
infer' (Literal (ArrayLiteral vals)) = do
ts <- traverse infer vals
els <- freshType
- forM_ ts $ \(TypedValue _ _ t) -> unifyTypes els t
- return $ TypedValue True (Literal (ArrayLiteral ts)) (TypeApp tyArray els)
+ ts' <- forM ts $ \(TypedValue ch val t) -> do
+ (val', t') <- instantiatePolyTypeWithUnknowns val t
+ unifyTypes els t'
+ return (TypedValue ch val' t')
+ return $ TypedValue True (Literal (ArrayLiteral ts')) (TypeApp tyArray els)
infer' (Literal (ObjectLiteral ps)) = do
ensureNoDuplicateProperties ps
ts <- traverse (infer . snd) ps
@@ -267,15 +265,14 @@ infer' (ObjectUpdate o ps) = do
let oldTy = TypeApp tyRecord $ rowFromList (oldTys, row)
o' <- TypedValue True <$> check o oldTy <*> pure oldTy
return $ TypedValue True (ObjectUpdate o' newVals) $ TypeApp tyRecord $ rowFromList (newTys, row)
-infer' (Accessor prop val) = rethrow (addHint (ErrorCheckingAccessor val prop)) $ do
+infer' (Accessor prop val) = withErrorMessageHint (ErrorCheckingAccessor val prop) $ do
field <- freshType
rest <- freshType
typed <- check val (TypeApp tyRecord (RCons prop field rest))
return $ TypedValue True (Accessor prop typed) field
infer' (Abs (Left arg) ret) = do
ty <- freshType
- Just moduleName <- checkCurrentModule <$> get
- withBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do
+ withBindingGroupVisible $ bindLocalVariables [(arg, ty, Defined)] $ do
body@(TypedValue _ _ bodyTy) <- infer' ret
return $ TypedValue True (Abs (Left arg) body) $ function ty bodyTy
infer' (Abs (Right _) _) = internalError "Binder was not desugared"
@@ -284,13 +281,13 @@ infer' (App f arg) = do
(ret, app) <- checkFunctionApplication f' ft arg Nothing
return $ TypedValue True app ret
infer' (Var var) = do
- Just moduleName <- checkCurrentModule <$> get
- checkVisibility moduleName var
- ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards <=< lookupVariable moduleName $ var
+ checkVisibility var
+ ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards <=< lookupVariable $ var
case ty of
ConstrainedType constraints ty' -> do
dicts <- getTypeClassDictionaries
- return $ TypedValue True (foldl App (Var var) (map (flip TypeClassDictionary dicts) constraints)) ty'
+ hints <- gets checkHints
+ return $ TypedValue True (foldl App (Var var) (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) ty'
_ -> return $ TypedValue True (Var var) ty
infer' v@(Constructor c) = do
env <- getEnv
@@ -316,7 +313,8 @@ infer' (Let ds val) = do
return $ TypedValue True (Let ds' val') valTy
infer' (SuperClassDictionary className tys) = do
dicts <- getTypeClassDictionaries
- return $ TypeClassDictionary (Constraint className tys Nothing) dicts
+ hints <- gets checkHints
+ return $ TypeClassDictionary (Constraint className tys Nothing) dicts hints
infer' (TypedValue checkType val ty) = do
Just moduleName <- checkCurrentModule <$> get
(kind, args) <- kindOfWithScopedVars ty
@@ -326,12 +324,10 @@ infer' (TypedValue checkType val ty) = do
return $ TypedValue True val' ty'
infer' (Hole name) = do
ty <- freshType
- env <- M.toList . names <$> getEnv
- Just moduleName <- checkCurrentModule <$> get
- let ctx = [ (ident, ty') | ((mn, ident@Ident{}), (ty', _, Defined)) <- env, mn == moduleName ]
+ ctx <- getLocalContext
tell . errorMessage $ HoleInferredType name ty ctx
return $ TypedValue True (Hole name) ty
-infer' (PositionedValue pos c val) = warnAndRethrowWithPosition pos $ do
+infer' (PositionedValue pos c val) = warnAndRethrowWithPositionTC pos $ do
TypedValue t v ty <- infer' val
return $ TypedValue t (PositionedValue pos c v) ty
infer' v = internalError $ "Invalid argument to infer: " ++ show v
@@ -348,27 +344,26 @@ inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue
Just moduleName <- checkCurrentModule <$> get
(kind, args) <- kindOfWithScopedVars ty
checkTypeKind ty kind
- let dict = M.singleton (moduleName, ident) (ty, nameKind, Undefined)
+ let dict = M.singleton (Qualified Nothing ident) (ty, nameKind, Undefined)
ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
TypedValue _ val' ty'' <- if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return tv
- bindNames (M.singleton (moduleName, ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right (TypedValue checkType val' ty''))]) rest ret j
+ bindNames (M.singleton (Qualified Nothing ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right (TypedValue checkType val' ty''))]) rest ret j
inferLetBinding seen (ValueDeclaration ident nameKind [] (Right val) : rest) ret j = do
valTy <- freshType
- Just moduleName <- checkCurrentModule <$> get
- let dict = M.singleton (moduleName, ident) (valTy, nameKind, Undefined)
+ let dict = M.singleton (Qualified Nothing ident) (valTy, nameKind, Undefined)
TypedValue _ val' valTy' <- bindNames dict $ infer val
unifyTypes valTy valTy'
- bindNames (M.singleton (moduleName, ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right val')]) rest ret j
+ bindNames (M.singleton (Qualified Nothing ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right val')]) rest ret j
inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
Just moduleName <- checkCurrentModule <$> get
- (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)
+ (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup Nothing (map (\(i, _, v) -> (i, v)) ds)
ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict
ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict
let ds' = [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2']
bindNames dict $ do
makeBindingGroupVisible
inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j
-inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = warnAndRethrowWithPosition pos $ do
+inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = warnAndRethrowWithPositionTC pos $ do
(d' : ds', val') <- inferLetBinding seen (d : ds) ret j
return (PositionedDeclaration pos com d' : ds', val')
inferLetBinding _ _ _ _ = internalError "Invalid argument to inferLetBinding"
@@ -426,7 +421,7 @@ inferBinder val (NamedBinder name binder) = do
m <- inferBinder val binder
return $ M.insert name val m
inferBinder val (PositionedBinder pos _ binder) =
- warnAndRethrowWithPosition pos $ inferBinder val binder
+ warnAndRethrowWithPositionTC pos $ inferBinder val binder
-- TODO: When adding support for polymorphic types, check subsumption here,
-- change the definition of `binderRequiresMonotype`,
-- and use `kindOfWithScopedVars`.
@@ -480,14 +475,13 @@ checkBinders _ _ [] = return []
checkBinders nvals ret (CaseAlternative binders result : bs) = do
guardWith (errorMessage $ OverlappingArgNames Nothing) $
let ns = concatMap binderNames binders in length (nub ns) == length ns
- Just moduleName <- checkCurrentModule <$> get
m1 <- M.unions <$> zipWithM inferBinder nvals binders
- r <- bindLocalVariables moduleName [ (name, ty, Defined) | (name, ty) <- M.toList m1 ] $
+ r <- bindLocalVariables [ (name, ty, Defined) | (name, ty) <- M.toList m1 ] $
CaseAlternative binders <$>
case result of
Left gs -> do
gs' <- forM gs $ \(grd, val) -> do
- grd' <- rethrow (addHint ErrorCheckingGuard) $ check grd tyBoolean
+ grd' <- withErrorMessageHint ErrorCheckingGuard $ check grd tyBoolean
val' <- TypedValue True <$> check val ret <*> pure ret
return (grd', val')
return $ Left gs'
@@ -505,7 +499,7 @@ check ::
Expr ->
Type ->
m Expr
-check val ty = rethrow (addHint (ErrorCheckingType val ty)) $ check' val ty
+check val ty = withErrorMessageHint (ErrorCheckingType val ty) $ check' val ty
-- |
-- Check the type of a value
@@ -574,8 +568,7 @@ check' (Literal (ArrayLiteral vals)) t@(TypeApp a ty) = do
return $ TypedValue True array t
check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do
unifyTypes t tyFunction
- Just moduleName <- checkCurrentModule <$> get
- ret' <- withBindingGroupVisible $ bindLocalVariables moduleName [(arg, argTy, Defined)] $ check ret retTy
+ ret' <- withBindingGroupVisible $ bindLocalVariables [(arg, argTy, Defined)] $ check ret retTy
return $ TypedValue True (Abs (Left arg) ret') ty
check' (Abs (Right _) _) _ = internalError "Binder was not desugared"
check' (App f arg) ret = do
@@ -583,9 +576,8 @@ check' (App f arg) ret = do
(_, app) <- checkFunctionApplication f' ft arg (Just ret)
return $ TypedValue True app ret
check' v@(Var var) ty = do
- Just moduleName <- checkCurrentModule <$> get
- checkVisibility moduleName var
- repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable moduleName $ var
+ checkVisibility var
+ repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable $ var
ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
v' <- subsumes (Just v) repl ty'
case v' of
@@ -599,7 +591,8 @@ check' (SuperClassDictionary className tys) _ = do
-- declaration gets desugared.
-}
dicts <- getTypeClassDictionaries
- return $ TypeClassDictionary (Constraint className tys Nothing) dicts
+ hints <- gets checkHints
+ return $ TypeClassDictionary (Constraint className tys Nothing) dicts hints
check' (TypedValue checkType val ty1) ty2 = do
Just moduleName <- checkCurrentModule <$> get
(kind, args) <- kindOfWithScopedVars ty1
@@ -638,7 +631,7 @@ check' e@(ObjectUpdate obj ps) t@(TypeApp o row) | o == tyRecord = do
obj' <- check obj (TypeApp tyRecord (rowFromList (us ++ remainingProps, rest)))
ps' <- checkProperties e ps row True
return $ TypedValue True (ObjectUpdate obj' ps') t
-check' (Accessor prop val) ty = rethrow (addHint (ErrorCheckingAccessor val prop)) $ do
+check' (Accessor prop val) ty = withErrorMessageHint (ErrorCheckingAccessor val prop) $ do
rest <- freshType
val' <- check val (TypeApp tyRecord (RCons prop ty rest))
return $ TypedValue True (Accessor prop val') ty
@@ -659,7 +652,7 @@ check' val kt@(KindedType ty kind) = do
checkTypeKind ty kind
val' <- check' val ty
return $ TypedValue True val' kt
-check' (PositionedValue pos c val) ty = warnAndRethrowWithPosition pos $ do
+check' (PositionedValue pos c val) ty = warnAndRethrowWithPositionTC pos $ do
TypedValue t v ty' <- check' val ty
return $ TypedValue t (PositionedValue pos c v) ty'
check' val ty = do
@@ -713,7 +706,7 @@ checkFunctionApplication ::
Expr ->
Maybe Type ->
m (Type, Expr)
-checkFunctionApplication fn fnTy arg ret = rethrow (addHint (ErrorInApplication fn fnTy arg)) $ do
+checkFunctionApplication fn fnTy arg ret = withErrorMessageHint (ErrorInApplication fn fnTy arg) $ do
subst <- gets checkSubstitution
checkFunctionApplication' fn (substituteType subst fnTy) arg (substituteType subst <$> ret)
@@ -749,7 +742,8 @@ checkFunctionApplication' fn (KindedType ty _) arg ret =
checkFunctionApplication fn ty arg ret
checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do
dicts <- getTypeClassDictionaries
- checkFunctionApplication' (foldl App fn (map (flip TypeClassDictionary dicts) constraints)) fnTy arg ret
+ hints <- gets checkHints
+ checkFunctionApplication' (foldl App fn (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) fnTy arg ret
checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} _ =
return (fnTy, App fn dict)
checkFunctionApplication' _ fnTy arg _ = throwError . errorMessage $ CannotApplyFunction fnTy arg
diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs
index 8716a6d..86e2c0a 100644
--- a/src/Language/PureScript/TypeChecker/Unify.hs
+++ b/src/Language/PureScript/TypeChecker/Unify.hs
@@ -80,7 +80,7 @@ unknownsInType t = everythingOnTypes (.) go t []
unifyTypes :: (MonadError MultipleErrors m, MonadState CheckState m) => Type -> Type -> m ()
unifyTypes t1 t2 = do
sub <- gets checkSubstitution
- rethrow (addHint (ErrorUnifyingTypes t1 t2)) $ unifyTypes' (substituteType sub t1) (substituteType sub t2)
+ withErrorMessageHint (ErrorUnifyingTypes t1 t2) $ unifyTypes' (substituteType sub t1) (substituteType sub t2)
where
unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()
unifyTypes' (TUnknown u) t = solveType u t
@@ -112,9 +112,11 @@ unifyTypes t1 t2 = do
unifyTypes' r1 r2@RCons{} = unifyRows r1 r2
unifyTypes' r1@REmpty r2 = unifyRows r1 r2
unifyTypes' r1 r2@REmpty = unifyRows r1 r2
- unifyTypes' ty1@(ConstrainedType _ _) ty2 = throwError . errorMessage $ ConstrainedTypeUnified ty1 ty2
+ unifyTypes' ty1@(ConstrainedType _ _) ty2 =
+ throwError . errorMessage $ ConstrainedTypeUnified ty1 ty2
unifyTypes' t3 t4@(ConstrainedType _ _) = unifyTypes' t4 t3
- unifyTypes' t3 t4 = throwError . errorMessage $ TypesDoNotUnify t3 t4
+ unifyTypes' t3 t4 =
+ throwError . errorMessage $ TypesDoNotUnify t3 t4
-- |
-- Unify two rows, updating the current substitution
@@ -147,7 +149,8 @@ unifyRows r1 r2 =
unifyRows' [] REmpty [] REmpty = return ()
unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()
unifyRows' [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) | s1 == s2 = return ()
- unifyRows' _ _ _ _ = throwError . errorMessage $ TypesDoNotUnify r1 r2
+ unifyRows' _ _ _ _ =
+ throwError . errorMessage $ TypesDoNotUnify r1 r2
-- |
-- Check that two types unify
@@ -195,7 +198,8 @@ replaceTypeWildcards = everywhereOnTypesM replace
where
replace (TypeWildcard ss) = do
t <- freshType
- warnWithPosition ss $ tell . errorMessage $ WildcardInferredType t
+ ctx <- getLocalContext
+ warnWithPosition ss $ tell . errorMessage $ WildcardInferredType t ctx
return t
replace other = return other
diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs
index 9bc82ed..5d2af00 100644
--- a/src/Language/PureScript/TypeClassDictionaries.hs
+++ b/src/Language/PureScript/TypeClassDictionaries.hs
@@ -21,7 +21,7 @@ data TypeClassDictionaryInScope
-- | Type class dependencies which must be satisfied to construct this dictionary
, tcdDependencies :: Maybe [Constraint]
}
- deriving (Show, Read)
+ deriving (Show)
-- |
-- A simplified representation of expressions which are used to represent type
@@ -44,4 +44,4 @@ data DictionaryValue
-- A subclass dictionary
--
| SubclassDictionaryValue DictionaryValue (Qualified (ProperName 'ClassName)) Integer
- deriving (Show, Read, Ord, Eq)
+ deriving (Show, Ord, Eq)
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index 8f2edf0..f9d7a60 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -23,7 +23,7 @@ import Language.PureScript.Names
-- An identifier for the scope of a skolem variable
--
newtype SkolemScope = SkolemScope { runSkolemScope :: Int }
- deriving (Show, Read, Eq, Ord, A.ToJSON, A.FromJSON)
+ deriving (Show, Eq, Ord, A.ToJSON, A.FromJSON)
-- |
-- The type of types
@@ -71,7 +71,7 @@ data Type
-- Note: although it seems this constructor is not used, it _is_ useful,
-- since it prevents certain traversals from matching.
| ParensInType Type
- deriving (Show, Read, Eq, Ord)
+ deriving (Show, Eq, Ord)
-- | Additional data relevant to type class constraints
data ConstraintData
@@ -81,7 +81,7 @@ data ConstraintData
-- not matched, and a flag indicating whether the list was truncated or not.
-- Note: we use 'String' here because using 'Binder' would introduce a cyclic
-- dependency in the module graph.
- deriving (Show, Read, Eq, Ord)
+ deriving (Show, Eq, Ord)
-- | A typeclass constraint
data Constraint = Constraint
@@ -91,7 +91,7 @@ data Constraint = Constraint
-- ^ type arguments
, constraintData :: Maybe ConstraintData
-- ^ additional data relevant to this constraint
- } deriving (Show, Read, Eq, Ord)
+ } deriving (Show, Eq, Ord)
mapConstraintArgs :: ([Type] -> [Type]) -> Constraint -> Constraint
mapConstraintArgs f c = c { constraintArgs = f (constraintArgs c) }
diff --git a/stack.yaml b/stack.yaml
index 304ee4c..e40e931 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,4 +1,4 @@
-resolver: lts-6.1
+resolver: lts-6.9
packages:
- '.'
extra-deps: []
diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs
index 5b5ba32..5680020 100644
--- a/tests/Language/PureScript/Ide/ImportsSpec.hs
+++ b/tests/Language/PureScript/Ide/ImportsSpec.hs
@@ -3,7 +3,7 @@
module Language.PureScript.Ide.ImportsSpec where
import Protolude
-import Unsafe (fromJust)
+import Data.Maybe (fromJust)
import qualified Language.PureScript as P
import Language.PureScript.Ide.Imports
diff --git a/tests/Language/PureScript/Ide/Integration.hs b/tests/Language/PureScript/Ide/Integration.hs
index 4f55441..f733959 100644
--- a/tests/Language/PureScript/Ide/Integration.hs
+++ b/tests/Language/PureScript/Ide/Integration.hs
@@ -48,7 +48,7 @@ module Language.PureScript.Ide.Integration
) where
import Protolude
-import Unsafe (fromJust)
+import Data.Maybe (fromJust)
import Data.Aeson
import Data.Aeson.Types
diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs
index 1c55a8a..05c082f 100644
--- a/tests/TestPscPublish.hs
+++ b/tests/TestPscPublish.hs
@@ -30,7 +30,7 @@ data TestResult
= ParseFailed String
| Mismatch ByteString ByteString -- ^ encoding before, encoding after
| Pass ByteString
- deriving (Show, Read)
+ deriving (Show)
roundTrip :: UploadedPackage -> TestResult
roundTrip pkg =