module Language.PureScript.Ide.Types where
import Prelude ()
import Prelude.Compat
import Control.Concurrent.STM
import Control.Monad
import Control.Monad.Reader.Class
import Control.Monad.Trans
import Data.Aeson
import Data.Map.Lazy as M
import Data.Maybe (maybeToList)
import Data.Text (Text (), pack, unpack)
import qualified Language.PureScript.AST.Declarations as D
import Language.PureScript.Externs
import Language.PureScript.Names
import qualified Language.PureScript.Names as N
import Text.Parsec
import Text.Parsec.Text
type ModuleIdent = Text
type DeclIdent = Text
type Type = Text
data Fixity = Infix | Infixl | Infixr deriving(Show, Eq, Ord)
data ExternDecl
= FunctionDecl { functionName :: DeclIdent
, functionType :: Type
}
| FixityDeclaration Fixity
Int
DeclIdent
| Dependency { dependencyModule :: ModuleIdent
, dependencyNames :: [Text]
, dependencyAlias :: Maybe Text
}
| ModuleDecl ModuleIdent
[DeclIdent]
| DataDecl DeclIdent
Text
| Export ModuleIdent
deriving (Show,Eq,Ord)
instance ToJSON ExternDecl where
toJSON (FunctionDecl n t) = object ["name" .= n, "type" .= t]
toJSON (ModuleDecl n t) = object ["name" .= n, "type" .= t]
toJSON (DataDecl n t) = object ["name" .= n, "type" .= t]
toJSON (Dependency n names _) = object ["module" .= n, "names" .= names]
toJSON (FixityDeclaration f p n) = object ["name" .= n
, "fixity" .= show f
, "precedence" .= p]
toJSON (Export _) = object []
type Module = (ModuleIdent, [ExternDecl])
data Configuration =
Configuration {
confOutputPath :: FilePath
, confDebug :: Bool
}
data PscIdeEnvironment =
PscIdeEnvironment {
envStateVar :: TVar PscIdeState
, envConfiguration :: Configuration
}
type PscIde m = (Applicative m, MonadIO m, MonadReader PscIdeEnvironment m)
data PscIdeState =
PscIdeState {
pscStateModules :: M.Map Text [ExternDecl]
, externsFiles :: M.Map ModuleName ExternsFile
} deriving Show
emptyPscIdeState :: PscIdeState
emptyPscIdeState = PscIdeState M.empty M.empty
newtype Completion =
Completion (ModuleIdent, DeclIdent, Type)
deriving (Show,Eq)
data ModuleImport =
ModuleImport {
importModuleName :: ModuleIdent
, importType :: D.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 D.Implicit qualifier) =
object $ ["module" .= mn
, "importType" .= ("implicit" :: Text)
] ++ fmap (\x -> "qualifier" .= x) (maybeToList qualifier)
toJSON (ModuleImport mn (D.Explicit refs) _) =
object ["module" .= mn
, "importType" .= ("explicit" :: Text)
, "identifiers" .= (identifierFromDeclarationRef <$> refs)]
toJSON (ModuleImport mn (D.Hiding refs) _) =
object ["module" .= mn
, "importType" .= ("hiding" :: Text)
, "identifiers" .= (identifierFromDeclarationRef <$> refs)]
identifierFromDeclarationRef :: D.DeclarationRef -> String
identifierFromDeclarationRef (D.TypeRef name _) = N.runProperName name
identifierFromDeclarationRef (D.ValueRef ident) = N.runIdent ident
identifierFromDeclarationRef (D.TypeClassRef name) = N.runProperName name
identifierFromDeclarationRef _ = ""
instance FromJSON Completion where
parseJSON (Object o) = do
m <- o .: "module"
d <- o .: "identifier"
t <- o .: "type"
return $ Completion (m, d, t)
parseJSON _ = mzero
instance ToJSON Completion where
toJSON (Completion (m,d,t)) =
object ["module" .= m, "identifier" .= d, "type" .= t]
data Success =
CompletionResult [Completion]
| TextResult Text
| MultilineTextResult [Text]
| PursuitResult [PursuitResponse]
| ImportList [ModuleImport]
| ModuleList [ModuleIdent]
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 (TextResult t) = encodeSuccess t
toJSON (MultilineTextResult ts) = encodeSuccess ts
toJSON (PursuitResult resp) = encodeSuccess resp
toJSON (ImportList decls) = encodeSuccess decls
toJSON (ModuleList 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" -> return Package
"completion" -> return Identifier
_ -> mzero
parseJSON _ = mzero
instance FromJSON PursuitQuery where
parseJSON o = fmap PursuitQuery (parseJSON o)
data PursuitResponse
= ModuleResponse { moduleResponseName :: Text
, moduleResponsePackage :: Text}
| DeclarationResponse { declarationResponseType :: Text
, declarationResponseModule :: Text
, declarationResponseIdent :: Text
, declarationResponsePackage :: Text
}
deriving (Show,Eq)
instance FromJSON PursuitResponse where
parseJSON (Object o) = do
package <- o .: "package"
info <- o .: "info"
(type' :: String) <- info .: "type"
case type' of
"module" -> do
name <- info .: "module"
return
ModuleResponse
{ moduleResponseName = name
, moduleResponsePackage = package
}
"declaration" -> do
moduleName <- info .: "module"
Right (ident, declType) <- typeParse <$> o .: "text"
return
DeclarationResponse
{ declarationResponseType = declType
, declarationResponseModule = moduleName
, declarationResponseIdent = ident
, declarationResponsePackage = package
}
_ -> mzero
parseJSON _ = mzero
typeParse :: Text -> Either Text (Text, Text)
typeParse t = case parse parseType "" t of
Right (x,y) -> Right (pack x, pack y)
Left err -> Left (pack (show err))
where
parseType :: Parser (String, String)
parseType = do
name <- identifier
_ <- string "::"
spaces
type' <- many1 anyChar
return (unpack name, type')
identifier :: Parser Text
identifier = do
spaces
ident <-
between (char '(') (char ')') (many1 (noneOf ", )")) <|>
many1 (noneOf ", )")
spaces
return (pack ident)
instance ToJSON PursuitResponse where
toJSON ModuleResponse{..} =
object ["module" .= moduleResponseName, "package" .= moduleResponsePackage]
toJSON DeclarationResponse{..} =
object
[ "module" .= declarationResponseModule
, "ident" .= declarationResponseIdent
, "type" .= declarationResponseType
, "package" .= declarationResponsePackage]