module Language.PureScript.Interactive.Completion
  ( CompletionM
  , liftCompletionM
  , completion
  , completion'
  , formatCompletions
  ) where

import Prelude
import Protolude (ordNub)

import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.State.Class (MonadState(..))
import Control.Monad.Trans.Reader (asks, runReaderT, ReaderT)
import Data.List (nub, isPrefixOf, isInfixOf, isSuffixOf, sortBy, stripPrefix)
import Data.Map (keys)
import Data.Maybe (mapMaybe)
import Data.Text qualified as T
import Language.PureScript qualified as P
import Language.PureScript.Interactive.Directive qualified as D
import Language.PureScript.Interactive.Types (Directive(..), PSCiState, psciExports, psciImports, psciLoadedExterns, replQueryStrings)
import System.Console.Haskeline (Completion(..), CompletionFunc, completeWordWithPrev, listFiles, simpleCompletion)

-- Completions may read the state, but not modify it.
type CompletionM = ReaderT PSCiState IO

-- Lift a `CompletionM` action into a state monad.
liftCompletionM
  :: (MonadState PSCiState m, MonadIO m)
  => CompletionM a
  -> m a
liftCompletionM :: forall (m :: * -> *) a.
(MonadState PSCiState m, MonadIO m) =>
CompletionM a -> m a
liftCompletionM CompletionM a
act = do
  PSCiState
st <- forall s (m :: * -> *). MonadState s m => m s
get
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT CompletionM a
act PSCiState
st

-- Haskeline completions

-- | Loads module, function, and file completions.
completion
  :: (MonadState PSCiState m, MonadIO m)
  => CompletionFunc m
completion :: forall (m :: * -> *).
(MonadState PSCiState m, MonadIO m) =>
CompletionFunc m
completion = forall (m :: * -> *) a.
(MonadState PSCiState m, MonadIO m) =>
CompletionM a -> m a
liftCompletionM forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompletionFunc (ReaderT PSCiState IO)
completion'

completion' :: CompletionFunc CompletionM
completion' :: CompletionFunc (ReaderT PSCiState IO)
completion' = forall (m :: * -> *).
Monad m =>
Maybe Char
-> String
-> (String -> String -> m [Completion])
-> CompletionFunc m
completeWordWithPrev forall a. Maybe a
Nothing String
" \t\n\r([" String -> String -> CompletionM [Completion]
findCompletions

-- | Callback for Haskeline's `completeWordWithPrev`.
-- Expects:
--   * Line contents to the left of the word, reversed
--   * Word to be completed
findCompletions :: String -> String -> CompletionM [Completion]
findCompletions :: String -> String -> CompletionM [Completion]
findCompletions String
prev String
word = do
    let ctx :: [CompletionContext]
ctx = [String] -> String -> [CompletionContext]
completionContext (String -> [String]
words (forall a. [a] -> [a]
reverse String
prev)) String
word
    [Completion]
completions <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse CompletionContext -> CompletionM [Completion]
getCompletions [CompletionContext]
ctx
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Completion -> Completion -> Ordering
directivesFirst [Completion]
completions
  where
    getCompletions :: CompletionContext -> CompletionM [Completion]
    getCompletions :: CompletionContext -> CompletionM [Completion]
getCompletions = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> String -> Maybe Completion
prefixedBy String
word) forall a. a -> Maybe a
Just)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompletionContext -> CompletionM [Either String Completion]
getCompletion

    getCompletion :: CompletionContext -> CompletionM [Either String Completion]
    getCompletion :: CompletionContext -> CompletionM [Either String Completion]
getCompletion CompletionContext
ctx =
      case CompletionContext
ctx of
        CtxFilePath String
f        -> forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => String -> m [Completion]
listFiles String
f
        CompletionContext
CtxModule            -> forall a b. (a -> b) -> [a] -> [b]
map forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CompletionM [String]
getModuleNames
        CompletionContext
CtxIdentifier        -> forall a b. (a -> b) -> [a] -> [b]
map forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. [a] -> [a] -> [a]
(++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CompletionM [String]
getIdentNames forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CompletionM [String]
getDctorNames)
        CtxType String
pre          -> forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
pre forall a. [a] -> [a] -> [a]
++)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CompletionM [String]
getTypeNames
        CtxFixed String
str         -> forall (m :: * -> *) a. Monad m => a -> m a
return [forall a b. a -> Either a b
Left String
str]
        CtxDirective String
d       -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map forall a b. a -> Either a b
Left (String -> [String]
completeDirectives String
d))

    completeDirectives :: String -> [String]
    completeDirectives :: String -> [String]
completeDirectives = forall a b. (a -> b) -> [a] -> [b]
map (Char
':' forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
D.directiveStringsFor

    prefixedBy :: String -> String -> Maybe Completion
    prefixedBy :: String -> String -> Maybe Completion
prefixedBy String
w String
cand = if String
w forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
cand
                          then forall a. a -> Maybe a
Just (String -> Completion
simpleCompletion String
cand)
                          else forall a. Maybe a
Nothing

    directivesFirst :: Completion -> Completion -> Ordering
    directivesFirst :: Completion -> Completion -> Ordering
directivesFirst (Completion String
_ String
d1 Bool
_) (Completion String
_ String
d2 Bool
_) = String -> String -> Ordering
go String
d1 String
d2
      where
      go :: String -> String -> Ordering
go (Char
':' : String
xs) (Char
':' : String
ys) = forall a. Ord a => a -> a -> Ordering
compare String
xs String
ys
      go (Char
':' : String
_) String
_ = Ordering
LT
      go String
_ (Char
':' : String
_) = Ordering
GT
      go String
xs String
ys = forall a. Ord a => a -> a -> Ordering
compare String
xs String
ys

-- |
-- Convert Haskeline completion result to results as they would be displayed
formatCompletions :: (String, [Completion]) -> [String]
formatCompletions :: (String, [Completion]) -> [String]
formatCompletions (String
unusedR, [Completion]
completions) = [String]
actuals
  where
    unused :: String
unused = forall a. [a] -> [a]
reverse String
unusedR
    actuals :: [String]
actuals = forall a b. (a -> b) -> [a] -> [b]
map ((String
unused forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Completion -> String
replacement) [Completion]
completions

data CompletionContext
  = CtxDirective String
  | CtxFilePath String
  | CtxModule
  | CtxIdentifier
  | CtxType String
  | CtxFixed String
  deriving (Int -> CompletionContext -> String -> String
[CompletionContext] -> String -> String
CompletionContext -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [CompletionContext] -> String -> String
$cshowList :: [CompletionContext] -> String -> String
show :: CompletionContext -> String
$cshow :: CompletionContext -> String
showsPrec :: Int -> CompletionContext -> String -> String
$cshowsPrec :: Int -> CompletionContext -> String -> String
Show)

-- |
-- Decide what kind of completion we need based on input. This function expects
-- a list of complete words (to the left of the cursor) as the first argument,
-- and the current word as the second argument.
completionContext :: [String] -> String -> [CompletionContext]
completionContext :: [String] -> String -> [CompletionContext]
completionContext [String]
_ String
w  | String
"::" forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
w = [String -> CompletionContext
CtxType (String
w String -> String -> String
`endingWith` String
"::")]
completionContext [String]
ws String
_ | forall a. (a -> Bool) -> [a] -> Bool
lastSatisfies (String
"::" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf`) [String]
ws = [String -> CompletionContext
CtxType String
""]
completionContext [] String
_ = [String -> CompletionContext
CtxDirective String
"", CompletionContext
CtxIdentifier, String -> CompletionContext
CtxFixed String
"import"]
completionContext [String]
ws String
w | forall a. (a -> Bool) -> [a] -> Bool
headSatisfies (String
":" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
ws = [String] -> String -> [CompletionContext]
completeDirective [String]
ws String
w
completionContext [String]
ws String
w | forall a. (a -> Bool) -> [a] -> Bool
headSatisfies (forall a. Eq a => a -> a -> Bool
== String
"import") [String]
ws = [String] -> String -> [CompletionContext]
completeImport [String]
ws String
w
completionContext [String]
_ String
_ = [CompletionContext
CtxIdentifier]

endingWith :: String -> String -> String
endingWith :: String -> String -> String
endingWith String
str String
stop = String -> String -> String
aux String
"" String
str
  where
  aux :: String -> String -> String
aux String
acc s :: String
s@(Char
x:String
xs)
    | String
stop forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s = forall a. [a] -> [a]
reverse (String
stop forall a. [a] -> [a] -> [a]
++ String
acc)
    | Bool
otherwise           = String -> String -> String
aux (Char
xforall a. a -> [a] -> [a]
:String
acc) String
xs
  aux String
acc []              = forall a. [a] -> [a]
reverse (String
stop forall a. [a] -> [a] -> [a]
++ String
acc)

completeDirective :: [String] -> String -> [CompletionContext]
completeDirective :: [String] -> String -> [CompletionContext]
completeDirective [String]
ws String
w =
  case [String]
ws of
    []     -> [String -> CompletionContext
CtxDirective String
w]
    (String
x:[String]
xs) -> case String -> [Directive]
D.directivesFor forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
":" String
x of
                 -- only offer completions if the directive is unambiguous
                 Just [Directive
dir] -> [String] -> Directive -> [CompletionContext]
directiveArg [String]
xs Directive
dir
                 Maybe [Directive]
_          -> []

directiveArg :: [String] -> Directive -> [CompletionContext]
directiveArg :: [String] -> Directive -> [CompletionContext]
directiveArg [] Directive
Browse = [CompletionContext
CtxModule]                    -- only complete very next term
directiveArg [] Directive
Show   = forall a b. (a -> b) -> [a] -> [b]
map String -> CompletionContext
CtxFixed [String]
replQueryStrings  -- only complete very next term
directiveArg [String]
_ Directive
Type    = [CompletionContext
CtxIdentifier]
directiveArg [String]
_ Directive
Kind    = [String -> CompletionContext
CtxType String
""]
directiveArg [String]
_ Directive
_       = []

completeImport :: [String] -> String -> [CompletionContext]
completeImport :: [String] -> String -> [CompletionContext]
completeImport [String]
ws String
w' =
  case ([String]
ws, String
w') of
    ([String
"import"], String
_) -> [CompletionContext
CtxModule]
    ([String], String)
_               -> []

headSatisfies :: (a -> Bool) -> [a] -> Bool
headSatisfies :: forall a. (a -> Bool) -> [a] -> Bool
headSatisfies a -> Bool
p [a]
str =
  case [a]
str of
    (a
c:[a]
_)  -> a -> Bool
p a
c
    [a]
_     -> Bool
False

lastSatisfies :: (a -> Bool) -> [a] -> Bool
lastSatisfies :: forall a. (a -> Bool) -> [a] -> Bool
lastSatisfies a -> Bool
_ [] = Bool
False
lastSatisfies a -> Bool
p [a]
xs = a -> Bool
p (forall a. [a] -> a
last [a]
xs)

getLoadedModules :: CompletionM [P.Module]
getLoadedModules :: CompletionM [Module]
getLoadedModules = forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSCiState -> [(Module, ExternsFile)]
psciLoadedExterns)

getModuleNames :: CompletionM [String]
getModuleNames :: CompletionM [String]
getModuleNames = [Module] -> [String]
moduleNames forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CompletionM [Module]
getLoadedModules

getIdentNames :: CompletionM [String]
getIdentNames :: CompletionM [String]
getIdentNames = do
  [Qualified Ident]
importedVals <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks (forall k a. Map k a -> [k]
keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. Imports -> Map (Qualified Ident) [ImportRecord Ident]
P.importedValues forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSCiState -> Imports
psciImports)
  [Ident]
exportedVals <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks (forall k a. Map k a -> [k]
keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exports -> Map Ident ExportSource
P.exportedValues forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSCiState -> Exports
psciExports)

  [Qualified (OpName 'ValueOpName)]
importedValOps <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks (forall k a. Map k a -> [k]
keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. Imports
-> Map
     (Qualified (OpName 'ValueOpName))
     [ImportRecord (OpName 'ValueOpName)]
P.importedValueOps forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSCiState -> Imports
psciImports)
  [OpName 'ValueOpName]
exportedValOps <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks (forall k a. Map k a -> [k]
keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exports -> Map (OpName 'ValueOpName) ExportSource
P.exportedValueOps forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSCiState -> Exports
psciExports)

  forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Text) -> Qualified a -> Text
P.showQualified Ident -> Text
P.showIdent) [Qualified Ident]
importedVals
              forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Text) -> Qualified a -> Text
P.showQualified forall (a :: OpNameType). OpName a -> Text
P.runOpName) [Qualified (OpName 'ValueOpName)]
importedValOps
              forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Text
P.showIdent) [Ident]
exportedVals
              forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: OpNameType). OpName a -> Text
P.runOpName) [OpName 'ValueOpName]
exportedValOps

getDctorNames :: CompletionM [String]
getDctorNames :: CompletionM [String]
getDctorNames = do
  [Qualified (ProperName 'ConstructorName)]
imports <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks (forall k a. Map k a -> [k]
keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. Imports
-> Map
     (Qualified (ProperName 'ConstructorName))
     [ImportRecord (ProperName 'ConstructorName)]
P.importedDataConstructors forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSCiState -> Imports
psciImports)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Text) -> Qualified a -> Text
P.showQualified forall (a :: ProperNameType). ProperName a -> Text
P.runProperName) [Qualified (ProperName 'ConstructorName)]
imports

getTypeNames :: CompletionM [String]
getTypeNames :: CompletionM [String]
getTypeNames = do
  [Qualified (ProperName 'TypeName)]
importedTypes <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks (forall k a. Map k a -> [k]
keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. Imports
-> Map
     (Qualified (ProperName 'TypeName))
     [ImportRecord (ProperName 'TypeName)]
P.importedTypes forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSCiState -> Imports
psciImports)
  [ProperName 'TypeName]
exportedTypes <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks (forall k a. Map k a -> [k]
keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exports
-> Map
     (ProperName 'TypeName)
     ([ProperName 'ConstructorName], ExportSource)
P.exportedTypes forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSCiState -> Exports
psciExports)

  [Qualified (OpName 'TypeOpName)]
importedTypeOps <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks (forall k a. Map k a -> [k]
keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. Imports
-> Map
     (Qualified (OpName 'TypeOpName))
     [ImportRecord (OpName 'TypeOpName)]
P.importedTypeOps forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSCiState -> Imports
psciImports)
  [OpName 'TypeOpName]
exportedTypeOps <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks (forall k a. Map k a -> [k]
keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exports -> Map (OpName 'TypeOpName) ExportSource
P.exportedTypeOps forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSCiState -> Exports
psciExports)

  forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Text) -> Qualified a -> Text
P.showQualified forall (a :: ProperNameType). ProperName a -> Text
P.runProperName) [Qualified (ProperName 'TypeName)]
importedTypes
              forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Text) -> Qualified a -> Text
P.showQualified forall (a :: OpNameType). OpName a -> Text
P.runOpName) [Qualified (OpName 'TypeOpName)]
importedTypeOps
              forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: ProperNameType). ProperName a -> Text
P.runProperName) [ProperName 'TypeName]
exportedTypes
              forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: OpNameType). OpName a -> Text
P.runOpName) [OpName 'TypeOpName]
exportedTypeOps

moduleNames :: [P.Module] -> [String]
moduleNames :: [Module] -> [String]
moduleNames = forall a. Ord a => [a] -> [a]
ordNub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> Text
P.runModuleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
P.getModuleName)