experiment.hs

{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where

import Data.Foldable (for_)
import Data.Traversable (for)
import Control.Monad.IO.Class

-- build-depends: base, haskeline, optparse-applicative
-- -- for example parser
-- build-depends: optparse-generic

import qualified System.Console.Haskeline as HL
import qualified Options.Applicative as O
import qualified Options.Generic as OG

-------------------------------------------------------------------------------
-- Implementation
-------------------------------------------------------------------------------

getInputVal :: (HL.MonadException m) => O.Parser a -> String -> HL.InputT m (Maybe a)
getInputVal p prompt = do
    ms <- HL.getInputLine prompt
    case ms of
        Nothing -> pure Nothing
        Just s -> case O.execParserPure O.defaultPrefs (O.info p mempty) (words s) of
            O.Success x -> pure (Just x)
            O.Failure e -> do
                HL.outputStrLn $ fst $ O.renderFailure e ""
                pure Nothing
            O.CompletionInvoked (O.CompletionResult f) -> do
                liftIO (f "") >>= HL.outputStrLn
                pure Nothing

completionFunc :: O.Parser a -> HL.CompletionFunc IO
completionFunc p = HL.completeWordWithPrev Nothing " " $ \ys y -> do
    let ws = words ys ++ if null y then [] else [y]
    let args = concatMap (\x -> ["--bash-completion-word", x]) ws ++ ["--bash-completion-index", show (length ws - 1)]
    case O.execParserPure O.defaultPrefs (O.info p mempty) args of
        O.CompletionInvoked (O.CompletionResult f) -> do
            xs <- f ""
            pure (HL.simpleCompletion <$> lines xs)
        _ -> pure []

-------------------------------------------------------------------------------
-- Example
-------------------------------------------------------------------------------

data Example = Example { foo :: Int, bar :: Maybe Double }
    deriving (OG.Generic, Show)

instance OG.ParseRecord Example

exampleP :: O.Parser Example
exampleP = OG.parseRecord

main :: IO ()
main = HL.runInputT (HL.setComplete (completionFunc exampleP) HL.defaultSettings) loop where
    loop = do
        x <- getInputVal exampleP ">>> "
        if fmap foo x == Just 0
        then return ()
        else do
            for_ x (HL.outputStrLn . show)
            loop