{-# LANGUAGE OverloadedStrings #-}

module Ide.Plugin.Cabal.Completion.Completer.Snippet where

import           Control.Lens                                 ((?~))
import           Control.Monad.Extra                          (mapMaybeM)
import           Data.Function                                ((&))
import           Data.Map                                     (Map)
import qualified Data.Map                                     as Map
import qualified Data.Text                                    as T
import           Ide.Logger                                   (Priority (..),
                                                               logWith)
import           Ide.Plugin.Cabal.Completion.Completer.Simple
import           Ide.Plugin.Cabal.Completion.Completer.Types
import           Ide.Plugin.Cabal.Completion.Types
import qualified Language.LSP.Protocol.Lens                   as JL
import qualified Language.LSP.Protocol.Types                  as LSP
import qualified Text.Fuzzy.Parallel                          as Fuzzy

-- | Maps snippet triggerwords with their completers
snippetCompleter :: Completer
snippetCompleter :: Completer
snippetCompleter Recorder (WithPriority Log)
recorder CompleterData
cData = do
  let scored :: [Scored TriggerWord]
scored = Int -> Int -> TriggerWord -> [TriggerWord] -> [Scored TriggerWord]
Fuzzy.simpleFilter Int
Fuzzy.defChunkSize Int
Fuzzy.defMaxResults (CabalPrefixInfo -> TriggerWord
completionPrefix CabalPrefixInfo
prefInfo) ([TriggerWord] -> [Scored TriggerWord])
-> [TriggerWord] -> [Scored TriggerWord]
forall a b. (a -> b) -> a -> b
$ Map TriggerWord TriggerWord -> [TriggerWord]
forall k a. Map k a -> [k]
Map.keys Map TriggerWord TriggerWord
snippets
  (Scored TriggerWord -> IO (Maybe CompletionItem))
-> [Scored TriggerWord] -> IO [CompletionItem]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM
    ( \Scored TriggerWord
compl -> do
        let matched :: TriggerWord
matched = Scored TriggerWord -> TriggerWord
forall a. Scored a -> a
Fuzzy.original Scored TriggerWord
compl
        let completion' :: Maybe TriggerWord
completion' = TriggerWord -> Map TriggerWord TriggerWord -> Maybe TriggerWord
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TriggerWord
matched Map TriggerWord TriggerWord
snippets
        case Maybe TriggerWord
completion' of
          Maybe TriggerWord
Nothing -> do
            Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Warning (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ TriggerWord -> Log
LogMapLookUpOfKnownKeyFailed TriggerWord
matched
            Maybe CompletionItem -> IO (Maybe CompletionItem)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CompletionItem
forall a. Maybe a
Nothing
          Just TriggerWord
completion ->
            Maybe CompletionItem -> IO (Maybe CompletionItem)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe CompletionItem -> IO (Maybe CompletionItem))
-> Maybe CompletionItem -> IO (Maybe CompletionItem)
forall a b. (a -> b) -> a -> b
$ CompletionItem -> Maybe CompletionItem
forall a. a -> Maybe a
Just (CompletionItem -> Maybe CompletionItem)
-> CompletionItem -> Maybe CompletionItem
forall a b. (a -> b) -> a -> b
$ TriggerWord -> TriggerWord -> CompletionItem
mkSnippetCompletion TriggerWord
completion TriggerWord
matched
    )
    [Scored TriggerWord]
scored
  where
    snippets :: Map TriggerWord TriggerWord
snippets = CabalPrefixInfo -> Map TriggerWord TriggerWord
snippetMap CabalPrefixInfo
prefInfo
    prefInfo :: CabalPrefixInfo
prefInfo = CompleterData -> CabalPrefixInfo
cabalPrefixInfo CompleterData
cData
    mkSnippetCompletion :: T.Text -> T.Text -> LSP.CompletionItem
    mkSnippetCompletion :: TriggerWord -> TriggerWord -> CompletionItem
mkSnippetCompletion TriggerWord
insertText TriggerWord
toDisplay =
      TriggerWord -> CompletionItem
mkDefaultCompletionItem TriggerWord
toDisplay
        CompletionItem
-> (CompletionItem -> CompletionItem) -> CompletionItem
forall a b. a -> (a -> b) -> b
& (Maybe CompletionItemKind -> Identity (Maybe CompletionItemKind))
-> CompletionItem -> Identity CompletionItem
forall s a. HasKind s a => Lens' s a
Lens' CompletionItem (Maybe CompletionItemKind)
JL.kind ((Maybe CompletionItemKind -> Identity (Maybe CompletionItemKind))
 -> CompletionItem -> Identity CompletionItem)
-> CompletionItemKind -> CompletionItem -> CompletionItem
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ CompletionItemKind
LSP.CompletionItemKind_Snippet
        CompletionItem
-> (CompletionItem -> CompletionItem) -> CompletionItem
forall a b. a -> (a -> b) -> b
& (Maybe TriggerWord -> Identity (Maybe TriggerWord))
-> CompletionItem -> Identity CompletionItem
forall s a. HasInsertText s a => Lens' s a
Lens' CompletionItem (Maybe TriggerWord)
JL.insertText ((Maybe TriggerWord -> Identity (Maybe TriggerWord))
 -> CompletionItem -> Identity CompletionItem)
-> TriggerWord -> CompletionItem -> CompletionItem
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ TriggerWord
insertText
        CompletionItem
-> (CompletionItem -> CompletionItem) -> CompletionItem
forall a b. a -> (a -> b) -> b
& (Maybe InsertTextFormat -> Identity (Maybe InsertTextFormat))
-> CompletionItem -> Identity CompletionItem
forall s a. HasInsertTextFormat s a => Lens' s a
Lens' CompletionItem (Maybe InsertTextFormat)
JL.insertTextFormat ((Maybe InsertTextFormat -> Identity (Maybe InsertTextFormat))
 -> CompletionItem -> Identity CompletionItem)
-> InsertTextFormat -> CompletionItem -> CompletionItem
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ InsertTextFormat
LSP.InsertTextFormat_Snippet

type TriggerWord = T.Text

snippetMap :: CabalPrefixInfo -> Map TriggerWord T.Text
snippetMap :: CabalPrefixInfo -> Map TriggerWord TriggerWord
snippetMap CabalPrefixInfo
prefInfo =
  ([TriggerWord] -> TriggerWord)
-> Map TriggerWord [TriggerWord] -> Map TriggerWord TriggerWord
forall a b. (a -> b) -> Map TriggerWord a -> Map TriggerWord b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [TriggerWord] -> TriggerWord
T.unlines (Map TriggerWord [TriggerWord] -> Map TriggerWord TriggerWord)
-> Map TriggerWord [TriggerWord] -> Map TriggerWord TriggerWord
forall a b. (a -> b) -> a -> b
$
    [(TriggerWord, [TriggerWord])] -> Map TriggerWord [TriggerWord]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ ( TriggerWord
"library-snippet",
          [ TriggerWord
"library",
            TriggerWord
"  hs-source-dirs: $1",
            TriggerWord
"  exposed-modules: $2",
            TriggerWord
"  build-depends: base",
            TriggerWord
"  default-language: Haskell2010"
          ]
        ),
        ( TriggerWord
"recommended-fields",
          [ TriggerWord
"cabal-version: $1",
            TriggerWord
"name: " TriggerWord -> TriggerWord -> TriggerWord
forall a. Semigroup a => a -> a -> a
<> CabalPrefixInfo -> TriggerWord
completionFileName CabalPrefixInfo
prefInfo,
            TriggerWord
"version: 0.1.0.0",
            TriggerWord
"maintainer: $4",
            TriggerWord
"category: $5",
            TriggerWord
"synopsis: $6",
            TriggerWord
"license: $7",
            TriggerWord
"build-type: Simple"
          ]
        ),
        ( TriggerWord
"executable-snippet",
          [ TriggerWord
"executable $1",
            TriggerWord
"  main-is: ${2:Main.hs}",
            TriggerWord
"  build-depends: base"
          ]
        ),
        ( TriggerWord
"benchmark-snippet",
          [ TriggerWord
"benchmark $1",
            TriggerWord
"  type: exitcode-stdio-1.0",
            TriggerWord
"  main-is: ${3:Main.hs}",
            TriggerWord
"  build-depends: base"
          ]
        ),
        ( TriggerWord
"testsuite-snippet",
          [ TriggerWord
"test-suite $1",
            TriggerWord
"  type: exitcode-stdio-1.0",
            TriggerWord
"  main-is: ${3:Main.hs}",
            TriggerWord
"  build-depends: base"
          ]
        ),
        ( TriggerWord
"common-warnings",
          [ TriggerWord
"common warnings",
            TriggerWord
"  ghc-options: -Wall"
          ]
        ),
        ( TriggerWord
"source-repo-github-snippet",
          [ TriggerWord
"source-repository head",
            TriggerWord
"  type: git",
            TriggerWord
"  location: git://github.com/$2"
          ]
        ),
        ( TriggerWord
"source-repo-git-snippet",
          [ TriggerWord
"source-repository head",
            TriggerWord
"  type: git",
            TriggerWord
"  location: $1"
          ]
        )
      ]