module System.Console.Shell.Backend.Haskeline
                    (haskelineBackend,
                    ShellacState) where

import System.Console.Shell.Backend
import System.Console.Haskeline hiding (completeFilename)
import qualified System.Console.Haskeline.Encoding as Encoding
import qualified System.Console.Haskeline.History as History
import System.Console.Haskeline.IO
import System.IO
import Data.IORef
import Control.Monad.State
import Data.Maybe(fromMaybe)
import qualified Data.ByteString as B

data ShellacState = ShellacState {
                        inputState :: InputState,
                        wordBreakChars  :: IORef String,
                        completer :: IORef CompletionFunction,
                        defaultCompleter :: IORef (Maybe (String -> IO [String]))
                    }

initShellacState :: IO ShellacState
initShellacState = do
    wbcsRef <- newIORef filenameWordBreakChars
    complRef <- newIORef (wrapHaskelineCompleter listFiles)
    dcomplRef <- newIORef Nothing
    let completionWrapper = \line -> do
        wbcs <- readIORef wbcsRef
        compl <- readIORef complRef
        dcompl <- readIORef dcomplRef
        wrapShellacCompleter wbcs compl dcompl line
    is <- initializeInput Settings {complete = completionWrapper,
                        autoAddHistory = False,
                        historyFile = Nothing}
    return ShellacState {inputState = is, wordBreakChars = wbcsRef,
                completer = complRef, defaultCompleter = dcomplRef}
        
queryInputState :: ShellacState -> (InputT IO a) -> IO a
queryInputState = queryInput . inputState

--------------
haskelineBackend :: ShellBackend ShellacState
haskelineBackend = ShBackend {
            initBackend = initShellacState,
            shutdownBackend = closeInput . inputState,
            outputString = \ss -> queryInputState ss . outputter,
            flushOutput = \_ -> hFlush stdout,
            getSingleChar = \ss pre -> queryInputState ss $ getInputChar pre,
            getInput = \ss pre -> queryInputState ss $ getInputLine pre,
            addHistory = \ss line -> queryInputState ss 
                    $ modify $ History.addHistory line,
            setWordBreakChars = \ss -> writeIORef (wordBreakChars ss),
            getWordBreakChars = readIORef . wordBreakChars,
            onCancel = cancelInput . inputState,
            setAttemptedCompletionFunction = \ss -> writeIORef (completer ss),
            setDefaultCompletionFunction = \ss -> writeIORef (defaultCompleter ss),
            completeFilename = \_ -> fmap (map replacement) . listFiles,
            completeUsername = \_ _ -> return [],
            clearHistoryState = \ss -> queryInputState ss $ put History.emptyHistory,
            setMaxHistoryEntries = \ss n -> let
                        stifle = if n < 0 then Nothing else Just n
                        in queryInputState ss $ modify $ History.stifleHistory stifle,
            getMaxHistoryEntries = \ss -> queryInputState ss $ gets
                                    $ fromMaybe (-1) . History.stifleAmount,
            readHistory = \ss file -> History.readHistory file 
                                >>= queryInputState ss . put,
            writeHistory = \ss file -> queryInputState ss get 
                                        >>= History.writeHistory file
            }


outputter :: BackendOutput -> InputT IO ()
outputter (RegularOutput str) = outputStr str
outputter (InfoOutput str) = outputStr str
outputter (ErrorOutput str) = Encoding.encode str
                                >>= liftIO . B.hPutStr stderr


wrapShellacCompleter :: String -> CompletionFunction -> Maybe (String -> IO [String])
                            -> CompletionFunc IO
wrapShellacCompleter breakChars f mg (left,right) = do
    let (rword,rleft') = break (`elem` breakChars) left
    let (left', word) = (reverse rleft', reverse rword)
    result <- f (left',word,right)
    completions <- case result of
                        Nothing -> case mg of
                            Nothing -> return []
                            Just g -> g word
                        Just (str,[]) -> return [str]
                        Just (_,alts) -> return alts
    return (rleft', map makeCompletion completions)

-- a hack to avoid adding a trailing space to completed folders.
-- I could go a little further and test whether it corresponds to an
-- actual file.
makeCompletion :: String -> Completion
makeCompletion "" = simpleCompletion ""
makeCompletion s = (simpleCompletion s) {
                isFinished = not (last s `elem` "/\\")
                    }

longestPrefix :: [String] -> String
longestPrefix = foldl1 commonPrefix
    where
        commonPrefix (x:xs) (y:ys) | x==y = x : commonPrefix xs ys
        commonPrefix _ _ = ""

wrapHaskelineCompleter :: (String -> IO [Completion]) -> CompletionFunction
wrapHaskelineCompleter f (_,w,_) = do
    ws <- fmap (map replacement) (f w)
    return $ case ws of
        [] -> Nothing
        _ -> Just (longestPrefix ws,ws)