content: {-# LANGUAGE CPP, NoImplicitPrelude, DoAndIfThenElse, TypeFamilies, FlexibleContexts #-}
  
  {- |
  Description:    Generates tab completion options.
  
  This has a limited amount of context sensitivity. It distinguishes between four contexts at the moment:
  - import statements (completed using modules)
  - identifiers (completed using in scope values)
  - extensions via :ext (completed using GHC extensions)
  - qualified identifiers (completed using in-scope values)
  
  -}
  module IHaskell.Eval.Completion (complete, completionTarget, completionType, CompletionType(..)) where
  
  import           IHaskellPrelude
  
  import           Data.Char
  import           Data.List (init, last, elemIndex)
  import qualified Data.List.Split as Split
  import qualified Data.List.Split.Internals as Split
  import           System.Environment (getEnv)
  
  import           GHC hiding (ModuleName)
  #if MIN_VERSION_ghc(9,4,0)
  import           GHC.Unit.Database
  import           GHC.Unit.State
  import           GHC.Driver.Env
  import           GHC.Driver.Ppr
  import           GHC.Driver.Session
  import           GHC.Driver.Monad as GhcMonad
  #elif MIN_VERSION_ghc(9,2,0)
  import           GHC.Unit.Database
  import           GHC.Unit.State
  import           GHC.Driver.Ppr
  import           GHC.Driver.Session
  import           GHC.Driver.Monad as GhcMonad
  #elif MIN_VERSION_ghc(9,0,0)
  import           GHC.Unit.Database
  import           GHC.Unit.State
  import           GHC.Driver.Session
  import           GHC.Driver.Monad as GhcMonad
  import           GHC.Utils.Outputable (showPpr)
  #else
  import           GHC.PackageDb
  import           DynFlags
  import           GhcMonad
  import           Outputable (showPpr)
  #endif
  
  import           System.Directory
  import           Control.Exception (try)
  
  import           System.Console.Haskeline.Completion
  
  import           IHaskell.Types
  import           IHaskell.Eval.Evaluate (Interpreter)
  import           IHaskell.Eval.ParseShell (parseShell)
  import           StringUtils (replace, strip, split)
  
  data CompletionType = Empty
                      | Identifier String
                      | DynFlag String
                      | Qualified String String
                      | ModuleName String String
                      | HsFilePath String String
                      | FilePath String String
                      | KernelOption String
                      | Extension String
    deriving (Show, Eq)
  
  exposedName :: (a, b) -> a
  exposedName = fst
  
  extName :: FlagSpec flag -> String
  extName (FlagSpec { flagSpecName = name }) = name
  
  complete :: String -> Int -> Interpreter (String, [String])
  complete code posOffset = do
    -- Get the line of code which is being completed and offset within that line
    let findLine offset (first:rest) =
          if offset <= length first
            then (offset, first)
            else findLine (offset - length first - 1) rest
        findLine _ [] = error $ "Could not find line: " ++ show (map length $ lines code, posOffset)
        (pos, line) = findLine posOffset (lines code)
  
  
    flags <- getSessionDynFlags
    rdrNames <- map (showPpr flags) <$> getRdrNamesInScope
    scopeNames <- nub <$> map (showPpr flags) <$> getNamesInScope
    let isQualified = ('.' `elem`)
        unqualNames = nub $ filter (not . isQualified) rdrNames
        qualNames = nub $ scopeNames ++ filter isQualified rdrNames
  #if MIN_VERSION_ghc(9,4,0)
    logger <- getLogger
    hsc_env <- getSession
    (db, _, _, _) <- liftIO $ initUnits logger flags Nothing (hsc_all_home_unit_ids hsc_env)
    let getNames = map (moduleNameString . exposedName) . unitExposedModules
        moduleNames = nub $ concatMap getNames $ concatMap unitDatabaseUnits db
  #elif MIN_VERSION_ghc(9,2,0)
    logger <- getLogger
    (db, _, _, _) <- liftIO $ initUnits logger flags Nothing
    let getNames = map (moduleNameString . exposedName) . unitExposedModules
        moduleNames = nub $ concatMap getNames $ concatMap unitDatabaseUnits db
  #elif MIN_VERSION_ghc(9,0,0)
    let Just db = unitDatabases flags
        getNames = map (moduleNameString . exposedName) . unitExposedModules
        moduleNames = nub $ concatMap getNames $ concatMap unitDatabaseUnits db
  #else
    let Just db = pkgDatabase flags
        getNames = map (moduleNameString . exposedName) . exposedModules
        moduleNames = nub $ concatMap getNames $ concatMap snd db
  #endif
  
    let target = completionTarget line pos
        completion = completionType line pos target
  
    let matchedText =
          case completion of
            HsFilePath _ match -> match
            FilePath _ match   -> match
            _                  -> intercalate "." target
  
    options <- case completion of
                 Empty -> return []
  
                 Identifier candidate ->
                   return $ filter (candidate `isPrefixOf`) unqualNames
  
                 Qualified mName candidate -> do
                   let prefix = intercalate "." [mName, candidate]
                       completions = filter (prefix `isPrefixOf`) qualNames
                   return completions
  
                 ModuleName previous candidate -> do
                   let prefix = if null previous
                                  then candidate
                                  else intercalate "." [previous, candidate]
                   return $ filter (prefix `isPrefixOf`) moduleNames
  
                 DynFlag ext -> do
                   -- Possibly leave out the fLangFlags?
                   let otherNames = ["-package", "-Wall", "-w"]
  
                       fNames = map extName fFlags ++
                                map extName wWarningFlags ++
                                map extName fLangFlags
                       fNoNames = map ("no" ++) fNames
                       fAllNames = map ("-f" ++) (fNames ++ fNoNames)
  
                       xNames = map extName xFlags
                       xNoNames = map ("No" ++) xNames
                       xAllNames = map ("-X" ++) (xNames ++ xNoNames)
  
                       allNames = xAllNames ++ otherNames ++ fAllNames
  
                   return $ filter (ext `isPrefixOf`) allNames
  
                 Extension ext -> do
                   let xNames = map extName xFlags
                       xNoNames = map ("No" ++) xNames
                   return $ filter (ext `isPrefixOf`) $ xNames ++ xNoNames
  
                 HsFilePath lineUpToCursor _match -> completePathWithExtensions [".hs", ".lhs"]
                                                      lineUpToCursor
  
                 FilePath lineUpToCursor _match -> completePath lineUpToCursor
  
                 KernelOption str -> return $
                   filter (str `isPrefixOf`) (concatMap getOptionName kernelOpts)
  
    return (matchedText, options)
  
  
  -- | Get which type of completion this is from the surrounding context.
  completionType :: String            -- ^ The line on which the completion is being done.
                 -> Int                -- ^ Location of the cursor in the line.
                 -> [String]          -- ^ The identifier being completed (pieces separated by dots).
                 -> CompletionType
  completionType line loc target
    -- File and directory completions are special
    | ":!" `isPrefixOf` stripped =
        fileComplete FilePath
    | ":l" `isPrefixOf` stripped =
        fileComplete HsFilePath
  
    -- Complete :set, :opt, and :ext
    | ":s" `isPrefixOf` stripped =
        DynFlag candidate
    | ":o" `isPrefixOf` stripped =
        KernelOption candidate
    | ":e" `isPrefixOf` stripped =
        Extension candidate
  
    -- Use target for other completions. If it's empty, no completion.
    | null target =
        Empty
  
    -- When in a string, complete filenames.
    | cursorInString line loc =
        FilePath (getStringTarget lineUpToCursor) (getStringTarget lineUpToCursor)
  
    -- Complete module names in imports and elsewhere.
    | "import" `isPrefixOf` stripped && isModName =
        ModuleName dotted candidate
    | isModName && (not . null . init) target =
        Qualified dotted candidate
  
    -- Default to completing identifiers.
    | otherwise =
        Identifier candidate
    where
      stripped = strip line
      dotted = dots target
      candidate
        | null target = ""
        | otherwise = last target
      dots = intercalate "." . init
      isModName = all isCapitalized (init target)
  
      isCapitalized [] = False
      isCapitalized (x:_) = isUpper x
  
      lineUpToCursor = take loc line
      fileComplete filePath =
        case parseShell lineUpToCursor of
          Right xs -> filePath lineUpToCursor $
            if last xs `isSuffixOf` lineUpToCursor
              then last xs
              else []
          Left _ -> Empty
  
      cursorInString str lcn = nquotes (take lcn str) `mod` 2 /= (0 :: Int)
  
      nquotes ('\\':'"':xs) = nquotes xs
      nquotes ('"':xs) = 1 + nquotes xs
      nquotes (_:xs) = nquotes xs
      nquotes [] = 0
  
      -- Get the bit of a string that might be a filename completion. Logic is a bit convoluted, but
      -- basically go backwards from the end, stopping at any quote or space, unless they are escaped.
      getStringTarget :: String -> String
      getStringTarget = go "" . reverse
        where
          go acc rest =
            case rest of
              '"':'\\':xs -> go ('"' : acc) xs
              '"':_       -> acc
              ' ':'\\':xs -> go (' ' : acc) xs
              ' ':_       -> acc
              x:xs        -> go (x : acc) xs
              []          -> acc
  
  -- | Get the word under a given cursor location.
  completionTarget :: String -> Int -> [String]
  completionTarget code cursor = expandCompletionPiece pieceToComplete
    where
      pieceToComplete = map fst <$> find (elem cursor . map snd) pieces
      pieces = splitAlongCursor $ Split.split splitter $ zip code [1 ..]
      splitter = Split.defaultSplitter
        {
        -- Split using only the characters, which are the first elements of the (char, index) tuple
        Split.delimiter = Split.Delimiter [uncurry isDelim]
        -- Condense multiple delimiters into one and then drop them.
        , Split.condensePolicy = Split.Condense
        , Split.delimPolicy = Split.Drop
        }
  
      isDelim :: Char -> Int -> Bool
      isDelim char _idx = char `elem` neverIdent || isSymbol char
  
      splitAlongCursor :: [[(Char, Int)]] -> [[(Char, Int)]]
      splitAlongCursor [] = []
      splitAlongCursor (x:xs) =
        case elemIndex cursor $ map snd x of
          Nothing  -> x : splitAlongCursor xs
          Just idx -> take (idx + 1) x : drop (idx + 1) x : splitAlongCursor xs
  
      -- These are never part of an identifier.
      neverIdent :: String
      neverIdent = " \n\t(),{}[]\\'\"`"
  
      expandCompletionPiece Nothing = []
      expandCompletionPiece (Just str) = Split.splitOn "." str
  
  getHome :: IO String
  getHome = do
    homeEither <- try $ getEnv "HOME" :: IO (Either SomeException String)
    return $
      case homeEither of
        Left _     -> "~"
        Right home -> home
  
  dirExpand :: String -> IO String
  dirExpand str = do
    home <- getHome
    return $ replace "~" home str
  
  unDirExpand :: String -> IO String
  unDirExpand str = do
    home <- getHome
    return $ replace home "~" str
  
  completePath :: String -> Interpreter [String]
  completePath line = completePathFilter acceptAll acceptAll line ""
    where
      acceptAll = const True
  
  completePathWithExtensions :: [String] -> String -> Interpreter [String]
  completePathWithExtensions extns line =
    completePathFilter (extensionIsOneOf extns) acceptAll line ""
    where
      acceptAll = const True
      extensionIsOneOf exts str = any correctEnding exts
        where
          correctEnding ext = ext `isSuffixOf` str
  
  completePathFilter :: (String -> Bool)      -- ^ File filter: test whether to include this file.
                     -> (String -> Bool)      -- ^ Directory filter: test whether to include this directory.
                     -> String               -- ^ Line contents to the left of the cursor.
                     -> String               -- ^ Line contents to the right of the cursor.
                     -> Interpreter [String]
  completePathFilter includeFile includeDirectory left right = GhcMonad.liftIO $ do
    -- Get the completions from Haskeline.  It has a bit of a strange API.
    expanded <- dirExpand left
    completions <- map replacement <$> snd <$> completeFilename (reverse expanded, right)
  
    -- Split up into files and directories. Filter out ones we don't want.
    areDirs <- mapM doesDirectoryExist completions
    let dirs = filter includeDirectory $ map fst $ filter snd $ zip completions areDirs
        files = filter includeFile $ map fst $ filter (not . snd) $ zip completions areDirs
  
    -- Return directories before files. However, stick everything that starts with a dot after
    -- everything else. If we wanted to keep original order, we could instead use
    --   filter (`elem` (dirs ++ files)) completions
    suggestions <- mapM unDirExpand $ dirs ++ files
    let isHidden str = isPrefixOf "." . last . split "/" $
          if "/" `isSuffixOf` str
            then init str
            else str
        visible = filter (not . isHidden) suggestions
        hidden = filter isHidden suggestions
    return $ visible ++ hidden
  