purescript · natefaubion · Dec 21, 2018 · Dec 14, 2018 · Dec 15, 2018 · Dec 15, 2018
diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs
@@ -60,7 +60,7 @@ data Binder
   -- |
   -- A binder with a type annotation
   --
-  | TypedBinder Type Binder
+  | TypedBinder SourceType Binder
   deriving (Show)
 
 -- Manual Eq and Ord instances for `Binder` were added on 2018-03-05. Comparing

diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
@@ -39,27 +39,27 @@ import qualified Language.PureScript.Constants as C
 import qualified Text.Parsec as P
 
 -- | A map of locally-bound names in scope.
-type Context = [(Ident, Type)]
+type Context = [(Ident, SourceType)]
 
 -- | Holds the data necessary to do type directed search for typed holes
 data TypeSearch
   = TSBefore Environment
   -- ^ An Environment captured for later consumption by type directed search
   | TSAfter
-    { tsAfterIdentifiers :: [(Qualified Text, Type)]
+    { tsAfterIdentifiers :: [(Qualified Text, SourceType)]
     -- ^ The identifiers that fully satisfy the subsumption check
-    , tsAfterRecordFields :: Maybe [(Label, Type)]
+    , tsAfterRecordFields :: Maybe [(Label, SourceType)]
     -- ^ Record fields that are available on the first argument to the typed
     -- hole
     }
   -- ^ Results of applying type directed search to the previously captured
   -- Environment
   deriving Show
 
-onTypeSearchTypes :: (Type -> Type) -> TypeSearch -> TypeSearch
+onTypeSearchTypes :: (SourceType -> SourceType) -> TypeSearch -> TypeSearch
 onTypeSearchTypes f = runIdentity . onTypeSearchTypesM (Identity . f)
 
-onTypeSearchTypesM :: (Applicative m) => (Type -> m Type) -> TypeSearch -> m TypeSearch
+onTypeSearchTypesM :: (Applicative m) => (SourceType -> m SourceType) -> TypeSearch -> m TypeSearch
 onTypeSearchTypesM f (TSAfter i r) = TSAfter <$> traverse (traverse f) i <*> traverse (traverse (traverse f)) r
 onTypeSearchTypesM _ (TSBefore env) = pure (TSBefore env)
 
@@ -76,8 +76,8 @@ data SimpleErrorMessage
   | CannotGetFileInfo FilePath
   | CannotReadFile FilePath
   | CannotWriteFile FilePath
-  | InfiniteType Type
-  | InfiniteKind Kind
+  | InfiniteType SourceType
+  | InfiniteKind SourceKind
   | MultipleValueOpFixities (OpName 'ValueOpName)
   | MultipleTypeOpFixities (OpName 'TypeOpName)
   | OrphanTypeDeclaration Ident
@@ -104,46 +104,46 @@ data SimpleErrorMessage
   | NameIsUndefined Ident
   | UndefinedTypeVariable (ProperName 'TypeName)
   | PartiallyAppliedSynonym (Qualified (ProperName 'TypeName))
-  | EscapedSkolem Text (Maybe SourceSpan) Type
-  | TypesDoNotUnify Type Type
-  | KindsDoNotUnify Kind Kind
-  | ConstrainedTypeUnified Type Type
-  | OverlappingInstances (Qualified (ProperName 'ClassName)) [Type] [Qualified Ident]
-  | NoInstanceFound Constraint
-  | AmbiguousTypeVariables Type Constraint
+  | EscapedSkolem Text (Maybe SourceSpan) SourceType
+  | TypesDoNotUnify SourceType SourceType
+  | KindsDoNotUnify SourceKind SourceKind
+  | ConstrainedTypeUnified SourceType SourceType
+  | OverlappingInstances (Qualified (ProperName 'ClassName)) [SourceType] [Qualified Ident]
+  | NoInstanceFound SourceConstraint
+  | AmbiguousTypeVariables SourceType SourceConstraint
   | UnknownClass (Qualified (ProperName 'ClassName))
-  | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type]
-  | CannotDerive (Qualified (ProperName 'ClassName)) [Type]
-  | InvalidDerivedInstance (Qualified (ProperName 'ClassName)) [Type] Int
-  | ExpectedTypeConstructor (Qualified (ProperName 'ClassName)) [Type] Type
-  | InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [Type]
-  | MissingNewtypeSuperclassInstance (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'ClassName)) [Type]
-  | UnverifiableSuperclassInstance (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'ClassName)) [Type]
+  | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [SourceType]
+  | CannotDerive (Qualified (ProperName 'ClassName)) [SourceType]
+  | InvalidDerivedInstance (Qualified (ProperName 'ClassName)) [SourceType] Int
+  | ExpectedTypeConstructor (Qualified (ProperName 'ClassName)) [SourceType] SourceType
+  | InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [SourceType]
+  | MissingNewtypeSuperclassInstance (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'ClassName)) [SourceType]
+  | UnverifiableSuperclassInstance (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'ClassName)) [SourceType]
   | CannotFindDerivingType (ProperName 'TypeName)
   | DuplicateLabel Label (Maybe Expr)
   | DuplicateValueDeclaration Ident
   | ArgListLengthsDiffer Ident
   | OverlappingArgNames (Maybe Ident)
-  | MissingClassMember (NEL.NonEmpty (Ident, Type))
+  | MissingClassMember (NEL.NonEmpty (Ident, SourceType))
   | ExtraneousClassMember Ident (Qualified (ProperName 'ClassName))
-  | ExpectedType Type Kind
+  | ExpectedType SourceType SourceKind
   -- | constructor name, expected argument count, actual argument count
   | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName)) Int Int
-  | ExprDoesNotHaveType Expr Type
+  | ExprDoesNotHaveType Expr SourceType
   | PropertyIsMissing Label
   | AdditionalProperty Label
   | TypeSynonymInstance
-  | OrphanInstance Ident (Qualified (ProperName 'ClassName)) (Set ModuleName) [Type]
+  | OrphanInstance Ident (Qualified (ProperName 'ClassName)) (Set ModuleName) [SourceType]
   | InvalidNewtype (ProperName 'TypeName)
-  | InvalidInstanceHead Type
+  | InvalidInstanceHead SourceType
   | TransitiveExportError DeclarationRef [DeclarationRef]
   | TransitiveDctorExportError DeclarationRef (ProperName 'ConstructorName)
   | ShadowedName Ident
   | ShadowedTypeVar Text
   | UnusedTypeVar Text
-  | WildcardInferredType Type Context
-  | HoleInferredType Text Type Context TypeSearch
-  | MissingTypeDeclaration Ident Type
+  | WildcardInferredType SourceType Context
+  | HoleInferredType Text SourceType Context TypeSearch
+  | MissingTypeDeclaration Ident SourceType
   | OverlappingPattern [[Binder]] Bool
   | IncompleteExhaustivityCheck
   | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName)
@@ -164,14 +164,14 @@ data SimpleErrorMessage
   | CaseBinderLengthDiffers Int [Binder]
   | IncorrectAnonymousArgument
   | InvalidOperatorInBinder (Qualified (OpName 'ValueOpName)) (Qualified Ident)
-  | CannotGeneralizeRecursiveFunction Ident Type
+  | CannotGeneralizeRecursiveFunction Ident SourceType
   | CannotDeriveNewtypeForData (ProperName 'TypeName)
   | ExpectedWildcard (ProperName 'TypeName)
   | CannotUseBindWithDo Ident
   -- | instance name, type class, expected argument count, actual argument count
   | ClassInstanceArityMismatch Ident (Qualified (ProperName 'ClassName)) Int Int
   -- | a user-defined warning raised by using the Warn type class
-  | UserDefinedWarning Type
+  | UserDefinedWarning SourceType
   -- | a declaration couldn't be used because it contained free variables
   | UnusableDeclaration Ident [[Text]]
   | CannotDefinePrimModules ModuleName
@@ -181,17 +181,17 @@ data SimpleErrorMessage
 
 -- | Error message hints, providing more detailed information about failure.
 data ErrorMessageHint
-  = ErrorUnifyingTypes Type Type
+  = ErrorUnifyingTypes SourceType SourceType
   | ErrorInExpression Expr
   | ErrorInModule ModuleName
-  | ErrorInInstance (Qualified (ProperName 'ClassName)) [Type]
-  | ErrorInSubsumption Type Type
+  | ErrorInInstance (Qualified (ProperName 'ClassName)) [SourceType]
+  | ErrorInSubsumption SourceType SourceType
   | ErrorCheckingAccessor Expr PSString
-  | ErrorCheckingType Expr Type
-  | ErrorCheckingKind Type
+  | ErrorCheckingType Expr SourceType
+  | ErrorCheckingKind SourceType
   | ErrorCheckingGuard
   | ErrorInferringType Expr
-  | ErrorInApplication Expr Type Expr
+  | ErrorInApplication Expr SourceType Expr
   | ErrorInDataConstructor (ProperName 'ConstructorName)
   | ErrorInTypeConstructor (ProperName 'TypeName)
   | ErrorInBindingGroup (NEL.NonEmpty Ident)
@@ -201,7 +201,7 @@ data ErrorMessageHint
   | ErrorInTypeDeclaration Ident
   | ErrorInTypeClassDeclaration (ProperName 'ClassName)
   | ErrorInForeignImport Ident
-  | ErrorSolvingConstraint Constraint
+  | ErrorSolvingConstraint SourceConstraint
   | PositionedError (NEL.NonEmpty SourceSpan)
   deriving (Show)
 
@@ -432,7 +432,7 @@ isExplicit _ = False
 data TypeDeclarationData = TypeDeclarationData
   { tydeclSourceAnn :: !SourceAnn
   , tydeclIdent :: !Ident
-  , tydeclType :: !Type
+  , tydeclType :: !SourceType
   } deriving (Show, Eq)
 
 overTypeDeclaration :: (TypeDeclarationData -> TypeDeclarationData) -> Declaration -> Declaration
@@ -442,7 +442,7 @@ getTypeDeclaration :: Declaration -> Maybe TypeDeclarationData
 getTypeDeclaration (TypeDeclaration d) = Just d
 getTypeDeclaration _ = Nothing
 
-unwrapTypeDeclaration :: TypeDeclarationData -> (Ident, Type)
+unwrapTypeDeclaration :: TypeDeclarationData -> (Ident, SourceType)
 unwrapTypeDeclaration td = (tydeclIdent td, tydeclType td)
 
 -- | A value declaration assigns a name and potential binders, to an expression (or multiple guarded expressions).
@@ -478,15 +478,15 @@ data Declaration
   -- |
   -- A data type declaration (data or newtype, name, arguments, data constructors)
   --
-  = DataDeclaration SourceAnn DataDeclType (ProperName 'TypeName) [(Text, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]
+  = DataDeclaration SourceAnn DataDeclType (ProperName 'TypeName) [(Text, Maybe SourceKind)] [(ProperName 'ConstructorName, [SourceType])]
   -- |
   -- A minimal mutually recursive set of data type declarations
   --
   | DataBindingGroupDeclaration (NEL.NonEmpty Declaration)
   -- |
   -- A type synonym declaration (name, arguments, type)
   --
-  | TypeSynonymDeclaration SourceAnn (ProperName 'TypeName) [(Text, Maybe Kind)] Type
+  | TypeSynonymDeclaration SourceAnn (ProperName 'TypeName) [(Text, Maybe SourceKind)] SourceType
   -- |
   -- A type declaration for a value (name, ty)
   --
@@ -505,11 +505,11 @@ data Declaration
   -- |
   -- A foreign import declaration (name, type)
   --
-  | ExternDeclaration SourceAnn Ident Type
+  | ExternDeclaration SourceAnn Ident SourceType
   -- |
   -- A data type foreign import (name, kind)
   --
-  | ExternDataDeclaration SourceAnn (ProperName 'TypeName) Kind
+  | ExternDataDeclaration SourceAnn (ProperName 'TypeName) SourceKind
   -- |
   -- A foreign kind import (name)
   --
@@ -525,12 +525,12 @@ data Declaration
   -- |
   -- A type class declaration (name, argument, implies, member declarations)
   --
-  | TypeClassDeclaration SourceAnn (ProperName 'ClassName) [(Text, Maybe Kind)] [Constraint] [FunctionalDependency] [Declaration]
+  | TypeClassDeclaration SourceAnn (ProperName 'ClassName) [(Text, Maybe SourceKind)] [SourceConstraint] [FunctionalDependency] [Declaration]
   -- |
   -- A type instance declaration (instance chain, chain index, name,
   -- dependencies, class name, instance types, member declarations)
   --
-  | TypeInstanceDeclaration SourceAnn [Ident] Integer Ident [Constraint] (Qualified (ProperName 'ClassName)) [Type] TypeInstanceBody
+  | TypeInstanceDeclaration SourceAnn [Ident] Integer Ident [SourceConstraint] (Qualified (ProperName 'ClassName)) [SourceType] TypeInstanceBody
   deriving (Show)
 
 data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'ConstructorName))) (OpName 'ValueOpName)
@@ -767,7 +767,7 @@ data Expr
   -- |
   -- A value with a type annotation
   --
-  | TypedValue Bool Expr Type
+  | TypedValue Bool Expr SourceType
   -- |
   -- A let binding
   --
@@ -792,7 +792,7 @@ 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
+  | TypeClassDictionary SourceConstraint
                         (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))))
                         [ErrorMessageHint]
   -- |
@@ -802,7 +802,7 @@ data Expr
   -- |
   -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking
   --
-  | DeferredDictionary (Qualified (ProperName 'ClassName)) [Type]
+  | DeferredDictionary (Qualified (ProperName 'ClassName)) [SourceType]
   -- |
   -- A placeholder for an anonymous function argument
   --

diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs
@@ -110,8 +110,8 @@ typeInstanceConstituents (TypeInstanceDeclaration _ _ _ _ constraints className
 
   -- Note that type synonyms are disallowed in instance declarations, so
   -- we don't need to handle them here.
-  go (TypeConstructor n) = [Right n]
-  go (ConstrainedType c _) = fromConstraint c
+  go (TypeConstructor _ n) = [Right n]
+  go (ConstrainedType _ c _) = fromConstraint c
   go _ = []
 
 typeInstanceConstituents _ = []

diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs
@@ -82,3 +82,26 @@ internalModuleSourceSpan name = SourceSpan name (SourcePos 0 0) (SourcePos 0 0)
 
 nullSourceSpan :: SourceSpan
 nullSourceSpan = internalModuleSourceSpan ""
+
+nullSourceAnn :: SourceAnn
+nullSourceAnn = (nullSourceSpan, [])
+
+pattern NullSourceSpan :: SourceSpan
+pattern NullSourceSpan = SourceSpan "" (SourcePos 0 0) (SourcePos 0 0)
+
+pattern NullSourceAnn :: SourceAnn
+pattern NullSourceAnn = (NullSourceSpan, [])
+
+nonEmptySpan :: SourceAnn -> Maybe SourceSpan
+nonEmptySpan (NullSourceSpan, _) = Nothing
+nonEmptySpan (ss, _) = Just ss
+
+widenSourceSpan :: SourceSpan -> SourceSpan -> SourceSpan
+widenSourceSpan (SourceSpan n1 s1 e1) (SourceSpan n2 s2 e2) =
+  SourceSpan n (min s1 s2) (max e1 e2)
+  where
+  n | n1 == ""  = n2
+    | otherwise = n1
+
+widenSourceAnn :: SourceAnn -> SourceAnn -> SourceAnn
+widenSourceAnn (s1, _) (s2, _) = (widenSourceSpan s1 s2, [])
diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs
@@ -620,7 +620,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
 
 accumTypes
   :: (Monoid r)
-  => (Type -> r)
+  => (SourceType -> r)
   -> ( Declaration -> r
      , Expr -> r
      , Binder -> r
@@ -644,7 +644,7 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con
 
 accumKinds
   :: (Monoid r)
-  => (Kind -> r)
+  => (SourceKind -> r)
   -> ( Declaration -> r
      , Expr -> r
      , Binder -> r
@@ -675,13 +675,13 @@ accumKinds f = everythingOnValues mappend forDecls forValues (const mempty) (con
   forValues (TypedValue _ _ ty) = forTypes ty
   forValues _ = mempty
 
-  forTypes (KindedType _ k) = f k
+  forTypes (KindedType _ _ k) = f k
   forTypes _ = mempty
 
 -- |
 -- Map a function over type annotations appearing inside a value
 --
-overTypes :: (Type -> Type) -> Expr -> Expr
+overTypes :: (SourceType -> SourceType) -> Expr -> Expr
 overTypes f = let (_, f', _) = everywhereOnValues id g id in f'
   where
   g :: Expr -> Expr

diff --git a/src/Language/PureScript/Comments.hs b/src/Language/PureScript/Comments.hs
@@ -1,18 +1,23 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveGeneric #-}
 
 -- |
 -- Defines the types of source code comments
 --
 module Language.PureScript.Comments where
 
 import Prelude.Compat
+import Control.DeepSeq (NFData)
 import Data.Text (Text)
+import GHC.Generics (Generic)
 
 import Data.Aeson.TH
 
 data Comment
   = LineComment Text
   | BlockComment Text
-  deriving (Show, Eq, Ord)
+  deriving (Show, Eq, Ord, Generic)
+
+instance NFData Comment
 
 $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Comment)