module Language.PureScript.AST.Declarations where
import Prelude.Compat
import Control.Monad.Identity
import Data.Aeson.TH
import qualified Data.Map as M
import Data.Text (Text)
import Language.PureScript.AST.Binders
import Language.PureScript.AST.Literals
import Language.PureScript.AST.Operators
import Language.PureScript.AST.SourcePos
import Language.PureScript.Types
import Language.PureScript.Names
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
type Context = [(Ident, Type)]
data TypeSearch
= TSBefore Environment
| TSAfter [(Qualified Ident, Type)]
deriving Show
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 Text
| CannotGetFileInfo FilePath
| CannotReadFile FilePath
| CannotWriteFile FilePath
| InfiniteType Type
| InfiniteKind Kind
| MultipleValueOpFixities (OpName 'ValueOpName)
| MultipleTypeOpFixities (OpName 'TypeOpName)
| OrphanTypeDeclaration Ident
| 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)
| DuplicateModule ModuleName [SourceSpan]
| DuplicateTypeArgument Text
| 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
| AmbiguousTypeVariables Type Constraint
| UnknownClass (Qualified (ProperName 'ClassName))
| PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type]
| CannotDerive (Qualified (ProperName 'ClassName)) [Type]
| InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [Type]
| CannotFindDerivingType (ProperName 'TypeName)
| DuplicateLabel Text (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 Text
| AdditionalProperty Text
| TypeSynonymInstance
| OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type]
| InvalidNewtype (ProperName 'TypeName)
| InvalidInstanceHead Type
| TransitiveExportError DeclarationRef [DeclarationRef]
| TransitiveDctorExportError DeclarationRef (ProperName 'ConstructorName)
| ShadowedName Ident
| ShadowedTypeVar Text
| UnusedTypeVar Text
| WildcardInferredType Type Context
| HoleInferredType Text Type Context TypeSearch
| MissingTypeDeclaration Ident Type
| OverlappingPattern [[Binder]] Bool
| IncompleteExhaustivityCheck
| MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName)
| ImportHidingModule ModuleName
| UnusedImport ModuleName
| UnusedExplicitImport ModuleName [Name] (Maybe ModuleName) [DeclarationRef]
| UnusedDctorImport ModuleName (ProperName 'TypeName) (Maybe ModuleName) [DeclarationRef]
| UnusedDctorExplicitImport ModuleName (ProperName 'TypeName) [ProperName 'ConstructorName] (Maybe ModuleName) [DeclarationRef]
| DuplicateSelectiveImport ModuleName
| DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)
| DuplicateImportRef Name
| DuplicateExportRef Name
| IntOutOfRange Integer Text 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
| CannotDeriveNewtypeForData (ProperName 'TypeName)
| ExpectedWildcard (ProperName 'TypeName)
deriving (Show)
data ErrorMessageHint
= ErrorUnifyingTypes Type Type
| ErrorInExpression Expr
| ErrorInModule ModuleName
| ErrorInInstance (Qualified (ProperName 'ClassName)) [Type]
| ErrorInSubsumption Type Type
| ErrorCheckingAccessor Expr Text
| ErrorCheckingType Expr Type
| ErrorCheckingKind Type
| ErrorCheckingGuard
| ErrorInferringType Expr
| ErrorInApplication Expr Type Expr
| ErrorInDataConstructor (ProperName 'ConstructorName)
| ErrorInTypeConstructor (ProperName 'TypeName)
| ErrorInBindingGroup [Ident]
| ErrorInDataBindingGroup [ProperName 'TypeName]
| ErrorInTypeSynonym (ProperName 'TypeName)
| ErrorInValueDeclaration Ident
| ErrorInTypeDeclaration Ident
| ErrorInTypeClassDeclaration (ProperName 'ClassName)
| ErrorInForeignImport Ident
| ErrorSolvingConstraint Constraint
| PositionedError SourceSpan
deriving (Show)
data HintCategory
= ExprHint
| KindHint
| CheckHint
| PositionHint
| SolverHint
| OtherHint
deriving (Show, Eq)
data ErrorMessage = ErrorMessage
[ErrorMessageHint]
SimpleErrorMessage
deriving (Show)
data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef])
deriving (Show)
getModuleName :: Module -> ModuleName
getModuleName (Module _ _ name _ _) = name
getModuleSourceSpan :: Module -> SourceSpan
getModuleSourceSpan (Module ss _ _ _ _) = ss
addDefaultImport :: ModuleName -> Module -> Module
addDefaultImport toImport m@(Module ss coms mn decls exps) =
if isExistingImport `any` decls || mn == toImport then m
else Module ss coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps
where
isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
isExistingImport _ = False
data DeclarationRef
= TypeRef (ProperName 'TypeName) (Maybe [ProperName 'ConstructorName])
| TypeOpRef (OpName 'TypeOpName)
| ValueRef Ident
| ValueOpRef (OpName 'ValueOpName)
| TypeClassRef (ProperName 'ClassName)
| TypeInstanceRef Ident
| ModuleRef ModuleName
| KindRef (ProperName 'KindName)
| ReExportRef ModuleName DeclarationRef
| PositionedDeclarationRef SourceSpan [Comment] DeclarationRef
deriving (Show)
instance Eq DeclarationRef where
(TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors'
(TypeOpRef name) == (TypeOpRef name') = name == name'
(ValueRef name) == (ValueRef name') = name == name'
(ValueOpRef name) == (ValueOpRef name') = name == name'
(TypeClassRef name) == (TypeClassRef name') = name == name'
(TypeInstanceRef name) == (TypeInstanceRef name') = name == name'
(ModuleRef name) == (ModuleRef name') = name == name'
(KindRef name) == (KindRef name') = name == name'
(ReExportRef mn ref) == (ReExportRef mn' ref') = mn == mn' && ref == ref'
(PositionedDeclarationRef _ _ r) == r' = r == r'
r == (PositionedDeclarationRef _ _ r') = r == r'
_ == _ = False
compDecRef :: DeclarationRef -> DeclarationRef -> Ordering
compDecRef (TypeRef name _) (TypeRef name' _) = compare name name'
compDecRef (TypeOpRef name) (TypeOpRef name') = compare name name'
compDecRef (ValueRef ident) (ValueRef ident') = compare ident ident'
compDecRef (ValueOpRef name) (ValueOpRef name') = compare name name'
compDecRef (TypeClassRef name) (TypeClassRef name') = compare name name'
compDecRef (TypeInstanceRef ident) (TypeInstanceRef ident') = compare ident ident'
compDecRef (ModuleRef name) (ModuleRef name') = compare name name'
compDecRef (KindRef name) (KindRef name') = compare name name'
compDecRef (ReExportRef name _) (ReExportRef name' _) = compare name name'
compDecRef (PositionedDeclarationRef _ _ ref) ref' = compDecRef ref ref'
compDecRef ref (PositionedDeclarationRef _ _ ref') = compDecRef ref ref'
compDecRef ref ref' = compare
(orderOf ref) (orderOf ref')
where
orderOf :: DeclarationRef -> Int
orderOf (TypeClassRef _) = 0
orderOf (TypeOpRef _) = 1
orderOf (TypeRef _ _) = 2
orderOf (ValueRef _) = 3
orderOf (ValueOpRef _) = 4
orderOf (KindRef _) = 5
orderOf _ = 6
getTypeRef :: DeclarationRef -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName])
getTypeRef (TypeRef name dctors) = Just (name, dctors)
getTypeRef (PositionedDeclarationRef _ _ r) = getTypeRef r
getTypeRef _ = Nothing
getTypeOpRef :: DeclarationRef -> Maybe (OpName 'TypeOpName)
getTypeOpRef (TypeOpRef op) = Just op
getTypeOpRef (PositionedDeclarationRef _ _ r) = getTypeOpRef r
getTypeOpRef _ = Nothing
getValueRef :: DeclarationRef -> Maybe Ident
getValueRef (ValueRef name) = Just name
getValueRef (PositionedDeclarationRef _ _ r) = getValueRef r
getValueRef _ = Nothing
getValueOpRef :: DeclarationRef -> Maybe (OpName 'ValueOpName)
getValueOpRef (ValueOpRef op) = Just op
getValueOpRef (PositionedDeclarationRef _ _ r) = getValueOpRef r
getValueOpRef _ = Nothing
getTypeClassRef :: DeclarationRef -> Maybe (ProperName 'ClassName)
getTypeClassRef (TypeClassRef name) = Just name
getTypeClassRef (PositionedDeclarationRef _ _ r) = getTypeClassRef r
getTypeClassRef _ = Nothing
getKindRef :: DeclarationRef -> Maybe (ProperName 'KindName)
getKindRef (KindRef name) = Just name
getKindRef (PositionedDeclarationRef _ _ r) = getKindRef r
getKindRef _ = Nothing
isModuleRef :: DeclarationRef -> Bool
isModuleRef (PositionedDeclarationRef _ _ r) = isModuleRef r
isModuleRef (ModuleRef _) = True
isModuleRef _ = False
data ImportDeclarationType
= Implicit
| Explicit [DeclarationRef]
| Hiding [DeclarationRef]
deriving (Eq, Show)
isImplicit :: ImportDeclarationType -> Bool
isImplicit Implicit = True
isImplicit _ = False
isExplicit :: ImportDeclarationType -> Bool
isExplicit (Explicit _) = True
isExplicit _ = False
data Declaration
= DataDeclaration DataDeclType (ProperName 'TypeName) [(Text, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]
| DataBindingGroupDeclaration [Declaration]
| TypeSynonymDeclaration (ProperName 'TypeName) [(Text, Maybe Kind)] Type
| TypeDeclaration Ident Type
| ValueDeclaration Ident NameKind [Binder] (Either [(Guard, Expr)] Expr)
| BindingGroupDeclaration [(Ident, NameKind, Expr)]
| ExternDeclaration Ident Type
| ExternDataDeclaration (ProperName 'TypeName) Kind
| ExternKindDeclaration (ProperName 'KindName)
| FixityDeclaration (Either ValueFixity TypeFixity)
| ImportDeclaration ModuleName ImportDeclarationType (Maybe ModuleName)
| TypeClassDeclaration (ProperName 'ClassName) [(Text, Maybe Kind)] [Constraint] [FunctionalDependency] [Declaration]
| TypeInstanceDeclaration Ident [Constraint] (Qualified (ProperName 'ClassName)) [Type] TypeInstanceBody
| PositionedDeclaration SourceSpan [Comment] Declaration
deriving (Show)
data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'ConstructorName))) (OpName 'ValueOpName)
deriving (Eq, Ord, Show)
data TypeFixity = TypeFixity Fixity (Qualified (ProperName 'TypeName)) (OpName 'TypeOpName)
deriving (Eq, Ord, Show)
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
pattern TypeFixityDeclaration fixity name op = FixityDeclaration (Right (TypeFixity fixity name op))
data TypeInstanceBody
= DerivedInstance
| NewtypeInstance
| NewtypeInstanceWithDictionary Expr
| ExplicitInstance [Declaration]
deriving (Show)
mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody
mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)
traverseTypeInstanceBody :: (Applicative f) => ([Declaration] -> f [Declaration]) -> TypeInstanceBody -> f TypeInstanceBody
traverseTypeInstanceBody f (ExplicitInstance ds) = ExplicitInstance <$> f ds
traverseTypeInstanceBody _ other = pure other
isValueDecl :: Declaration -> Bool
isValueDecl ValueDeclaration{} = True
isValueDecl (PositionedDeclaration _ _ d) = isValueDecl d
isValueDecl _ = False
isDataDecl :: Declaration -> Bool
isDataDecl DataDeclaration{} = True
isDataDecl TypeSynonymDeclaration{} = True
isDataDecl (PositionedDeclaration _ _ d) = isDataDecl d
isDataDecl _ = False
isImportDecl :: Declaration -> Bool
isImportDecl ImportDeclaration{} = True
isImportDecl (PositionedDeclaration _ _ d) = isImportDecl d
isImportDecl _ = False
isExternDataDecl :: Declaration -> Bool
isExternDataDecl ExternDataDeclaration{} = True
isExternDataDecl (PositionedDeclaration _ _ d) = isExternDataDecl d
isExternDataDecl _ = False
isExternKindDecl :: Declaration -> Bool
isExternKindDecl ExternKindDeclaration{} = True
isExternKindDecl (PositionedDeclaration _ _ d) = isExternKindDecl d
isExternKindDecl _ = False
isFixityDecl :: Declaration -> Bool
isFixityDecl FixityDeclaration{} = True
isFixityDecl (PositionedDeclaration _ _ d) = isFixityDecl d
isFixityDecl _ = False
getFixityDecl :: Declaration -> Maybe (Either ValueFixity TypeFixity)
getFixityDecl (FixityDeclaration fixity) = Just fixity
getFixityDecl (PositionedDeclaration _ _ d) = getFixityDecl d
getFixityDecl _ = Nothing
isExternDecl :: Declaration -> Bool
isExternDecl ExternDeclaration{} = True
isExternDecl (PositionedDeclaration _ _ d) = isExternDecl d
isExternDecl _ = False
isTypeClassInstanceDeclaration :: Declaration -> Bool
isTypeClassInstanceDeclaration TypeInstanceDeclaration{} = True
isTypeClassInstanceDeclaration (PositionedDeclaration _ _ d) = isTypeClassInstanceDeclaration d
isTypeClassInstanceDeclaration _ = False
isTypeClassDeclaration :: Declaration -> Bool
isTypeClassDeclaration TypeClassDeclaration{} = True
isTypeClassDeclaration (PositionedDeclaration _ _ d) = isTypeClassDeclaration d
isTypeClassDeclaration _ = False
flattenDecls :: [Declaration] -> [Declaration]
flattenDecls = concatMap flattenOne
where flattenOne :: Declaration -> [Declaration]
flattenOne (DataBindingGroupDeclaration decls) = concatMap flattenOne decls
flattenOne d = [d]
type Guard = Expr
data Expr
= Literal (Literal Expr)
| UnaryMinus Expr
| BinaryNoParens Expr Expr Expr
| Parens Expr
| Accessor Text Expr
| ObjectUpdate Expr [(Text, Expr)]
| Abs (Either Ident Binder) Expr
| App Expr Expr
| Var (Qualified Ident)
| Op (Qualified (OpName 'ValueOpName))
| IfThenElse Expr Expr Expr
| Constructor (Qualified (ProperName 'ConstructorName))
| Case [Expr] [CaseAlternative]
| TypedValue Bool Expr Type
| Let [Declaration] Expr
| Do [DoNotationElement]
| TypeClassDictionaryConstructorApp (Qualified (ProperName 'ClassName)) Expr
| TypeClassDictionary Constraint
(M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict)))
[ErrorMessageHint]
| TypeClassDictionaryAccessor (Qualified (ProperName 'ClassName)) Ident
| DeferredDictionary (Qualified (ProperName 'ClassName)) [Type]
| AnonymousArgument
| Hole Text
| PositionedValue SourceSpan [Comment] Expr
deriving (Show)
data CaseAlternative = CaseAlternative
{
caseAlternativeBinders :: [Binder]
, caseAlternativeResult :: Either [(Guard, Expr)] Expr
} deriving (Show)
data DoNotationElement
= DoNotationValue Expr
| DoNotationBind Binder Expr
| DoNotationLet [Declaration]
| PositionedDoNotationElement SourceSpan [Comment] DoNotationElement
deriving (Show)
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef)
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType)