module Language.PureScript.Ide.Types where
import Protolude
import Control.Concurrent.STM
import Data.Aeson
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 Text.Parsec as Parsec
import Text.Parsec.Text
type ModuleIdent = Text
data IdeDeclaration
= IdeValue P.Ident P.Type
| IdeType (P.ProperName 'P.TypeName) P.Kind
| IdeTypeSynonym (P.ProperName 'P.TypeName) P.Type
| IdeDataConstructor (P.ProperName 'P.ConstructorName) (P.ProperName 'P.TypeName) P.Type
| IdeTypeClass (P.ProperName 'P.ClassName)
| IdeValueOperator (P.OpName 'P.ValueOpName) Text P.Precedence P.Associativity
| IdeTypeOperator (P.OpName 'P.TypeOpName) Text P.Precedence P.Associativity
deriving (Show, Eq, Ord)
data IdeDeclarationAnn = IdeDeclarationAnn Annotation IdeDeclaration
deriving (Show, Eq, Ord)
data Annotation
= Annotation
{ annLocation :: Maybe P.SourceSpan
, annExportedFrom :: Maybe P.ModuleName
} deriving (Show, Eq, Ord)
emptyAnn :: Annotation
emptyAnn = Annotation Nothing Nothing
type Module = (P.ModuleName, [IdeDeclarationAnn])
newtype AstData a =
AstData (Map P.ModuleName (Map (Either Text Text) a))
deriving (Show, Eq, Ord, Functor, Foldable)
data Configuration =
Configuration
{ confOutputPath :: FilePath
, confDebug :: Bool
, confGlobs :: [FilePath]
}
data IdeEnvironment =
IdeEnvironment
{ ideStateVar :: TVar IdeState
, ideConfiguration :: Configuration
}
type Ide m = (MonadIO m, MonadReader IdeEnvironment m)
data IdeState = IdeState
{ ideStage1 :: Stage1
, ideStage2 :: Stage2
, ideStage3 :: Stage3
}
emptyIdeState :: IdeState
emptyIdeState = IdeState emptyStage1 emptyStage2 emptyStage3
emptyStage1 :: Stage1
emptyStage1 = Stage1 M.empty M.empty
emptyStage2 :: Stage2
emptyStage2 = Stage2 (AstData M.empty)
emptyStage3 :: Stage3
emptyStage3 = Stage3 M.empty Nothing
data Stage1 = Stage1
{ s1Externs :: M.Map P.ModuleName P.ExternsFile
, s1Modules :: M.Map P.ModuleName (P.Module, FilePath)
}
data Stage2 = Stage2
{ s2AstData :: AstData P.SourceSpan
}
data Stage3 = Stage3
{ s3Declarations :: M.Map P.ModuleName [IdeDeclarationAnn]
, s3CachedRebuild :: Maybe (P.ModuleName, P.ExternsFile)
}
newtype Match a = Match (P.ModuleName, a)
deriving (Show, Eq, Functor)
newtype Completion =
Completion (Text, Text, Text)
deriving (Show,Eq)
newtype Info =
Info (Text, Text, Text, Maybe P.SourceSpan)
deriving (Show,Eq)
instance ToJSON Info where
toJSON (Info (m, d, t, sourceSpan)) =
object ["module" .= m, "identifier" .= d, "type" .= t, "definedAt" .= sourceSpan]
instance ToJSON Completion where
toJSON (Completion (m, d, t)) =
object ["module" .= m, "identifier" .= d, "type" .= t]
data ModuleImport =
ModuleImport
{ importModuleName :: ModuleIdent
, importType :: P.ImportDeclarationType
, importQualifier :: Maybe Text
} deriving(Show)
instance Eq ModuleImport where
mi1 == mi2 =
importModuleName mi1 == importModuleName mi2
&& importQualifier mi1 == importQualifier mi2
instance ToJSON ModuleImport where
toJSON (ModuleImport mn P.Implicit qualifier) =
object $ [ "module" .= mn
, "importType" .= ("implicit" :: Text)
] ++ fmap (\x -> "qualifier" .= x) (maybeToList qualifier)
toJSON (ModuleImport mn (P.Explicit refs) _) =
object [ "module" .= mn
, "importType" .= ("explicit" :: Text)
, "identifiers" .= (identifierFromDeclarationRef <$> refs)
]
toJSON (ModuleImport mn (P.Hiding refs) _) =
object [ "module" .= mn
, "importType" .= ("hiding" :: Text)
, "identifiers" .= (identifierFromDeclarationRef <$> refs)
]
identifierFromDeclarationRef :: P.DeclarationRef -> Text
identifierFromDeclarationRef (P.TypeRef name _) = runProperNameT name
identifierFromDeclarationRef (P.ValueRef ident) = runIdentT ident
identifierFromDeclarationRef (P.TypeClassRef name) = runProperNameT name
identifierFromDeclarationRef _ = ""
data Success =
CompletionResult [Completion]
| InfoResult [Info]
| TextResult Text
| MultilineTextResult [Text]
| PursuitResult [PursuitResponse]
| ImportList [ModuleImport]
| ModuleList [ModuleIdent]
| RebuildSuccess [P.JSONError]
deriving(Show, Eq)
encodeSuccess :: (ToJSON a) => a -> Value
encodeSuccess res =
object ["resultType" .= ("success" :: Text), "result" .= res]
instance ToJSON Success where
toJSON (CompletionResult cs) = encodeSuccess cs
toJSON (InfoResult i) = encodeSuccess i
toJSON (TextResult t) = encodeSuccess t
toJSON (MultilineTextResult ts) = encodeSuccess ts
toJSON (PursuitResult resp) = encodeSuccess resp
toJSON (ImportList decls) = encodeSuccess decls
toJSON (ModuleList modules) = encodeSuccess modules
toJSON (RebuildSuccess modules) = encodeSuccess modules
newtype PursuitQuery = PursuitQuery Text
deriving (Show, Eq)
data PursuitSearchType = Package | Identifier
deriving (Show, Eq)
instance FromJSON PursuitSearchType where
parseJSON (String t) = case t of
"package" -> pure Package
"completion" -> pure Identifier
_ -> mzero
parseJSON _ = mzero
instance FromJSON PursuitQuery where
parseJSON o = PursuitQuery <$> parseJSON o
data PursuitResponse =
ModuleResponse ModuleIdent Text
| DeclarationResponse Text ModuleIdent Text Text
deriving (Show,Eq)
instance FromJSON PursuitResponse where
parseJSON (Object o) = do
package <- o .: "package"
info <- o .: "info"
(type' :: Text) <- info .: "type"
case type' of
"module" -> do
name <- info .: "module"
pure (ModuleResponse name package)
"declaration" -> do
moduleName <- info .: "module"
Right (ident, declType) <- typeParse <$> o .: "text"
pure (DeclarationResponse declType moduleName ident package)
_ -> mzero
parseJSON _ = mzero
typeParse :: Text -> Either Text (Text, Text)
typeParse t = case parse parseType "" t of
Right (x,y) -> Right (x, y)
Left err -> Left (show err)
where
parseType :: Parser (Text, Text)
parseType = do
name <- identifier
_ <- string "::"
spaces
type' <- many1 anyChar
pure (name, toS type')
identifier :: Parser Text
identifier = do
spaces
ident <-
between (char '(') (char ')') (many1 (noneOf ", )")) Parsec.<|>
many1 (noneOf ", )")
spaces
pure (toS ident)
instance ToJSON PursuitResponse where
toJSON (ModuleResponse name package) =
object ["module" .= name, "package" .= package]
toJSON (DeclarationResponse module' ident type' package) =
object
[ "module" .= module'
, "ident" .= ident
, "type" .= type'
, "package" .= package
]