completion-test.hs

{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}

import System.Console.Haskeline
import System.IO
import System.IO.Unsafe
import Control.Monad.State.Strict
import Control.Monad.Reader
import qualified Data.ByteString.Char8 as B
import Data.Maybe
import Data.List 
import qualified Data.Map as M
import Debug.Trace

data MyDataState = MyDataState {
  mydata :: [Int],
  selectedElement :: Int,
  showEven :: Bool
} deriving (Show)

instance MonadState s m => MonadState s (InputT m) where
    get = lift get
    put = lift . put
    state = lift . state

instance MonadReader s m => MonadReader s (InputT m) where
    reader = lift . reader
    local f = mapInputT (local f)

type M = ReaderT SearchFunc (StateT MyDataState IO)

type SearchFunc = MyDataState -> String -> [Completion]

myfile :: FilePath
myfile = "data.txt"

defaultFlagValue :: Bool
defaultFlagValue = False

defaultSelectedElement :: Int
defaultSelectedElement = 0

saveDataToFile :: [Int] -> IO ()
saveDataToFile _data = withFile myfile WriteMode $ \h -> hPutStr h (unwords $ map show _data)

{-# NOINLINE loadDataFromFile #-} 
loadDataFromFile :: [Int]
loadDataFromFile = map read . words $ B.unpack $ unsafePerformIO $ B.readFile myfile

generalSetOfCommands = M.fromList [
    (":help", "outputs this help"), 
    (":q", "quits the program"), 
    (":commands", "list of all commands applicable to the current selection"), 
    (":show", "show current set of data"), 
    (":save", "saves data to file"), 
    (":load", "loads data from file"), 
    (":select", "selects one of the data set elements to be current"), 
    (":new", "adds element to the data set"), 
    (":toggleShowEven", "toggles the flag that controls output of even data set elements")
  ]
firstSetOfCommands = M.fromList [
    (":command1_1", "description of :command1_1"), 
    (":command1_2", "description of :command1_2"), 
    (":command1_3", "description of :command1_3"), 
    (":command1_4", "description of :command1_4")
  ]
secondSetOfCommands = M.fromList [
    (":command2_1", "description of :command2_1"), 
    (":command2_2", "description of :command2_2"), 
    (":command2_3", "description of :command2_3"), 
    (":command2_4", "description of :command2_4")
  ]
thirdSetOfCommands = M.fromList [
    (":command3_1", "description of :command3_1"), 
    (":command3_2", "description of :command3_2"), 
    (":command3_3", "description of :command3_3"), 
    (":command3_4", "description of :command3_4")
  ]

topLevelSearchFunc :: MyDataState -> String -> [Completion]
topLevelSearchFunc (MyDataState mydata selectedElement showEven) str = 
    map simpleCompletion $ filter (str `isPrefixOf`) (M.keys generalSetOfCommands ++ 
        case selectedElement of 
          1 -> M.keys firstSetOfCommands
          2 -> M.keys secondSetOfCommands
          3 -> M.keys thirdSetOfCommands
          otherwise -> []
    )

selectSearchFunc :: MyDataState -> String -> [Completion]
selectSearchFunc (MyDataState mydata selectedElement showEven) str =
    map simpleCompletion $ filter (str `isPrefixOf`) $ map show mydata

mySettings :: Settings M
mySettings = Settings { historyFile = Just "myhist"
                      , complete = completeWord Nothing " \t" $ \str -> do 
                          _data <- get
                          searchFunc <- ask
                          return $ searchFunc _data str 
                      , autoAddHistory = True
                      }

help :: InputT M ()
help = commands

commands :: InputT M ()
commands = do
        (MyDataState mydata selectedElement flag) <- get
        liftIO $ mapM_ putStrLn $ case selectedElement of 
          1 -> M.elems $ M.mapWithKey (\k v -> k ++ "\t - " ++ v) $ M.unionWith (++) generalSetOfCommands firstSetOfCommands
          2 -> M.elems $ M.mapWithKey (\k v -> k ++ "\t - " ++ v) $ M.unionWith (++) generalSetOfCommands secondSetOfCommands
          3 -> M.elems $ M.mapWithKey (\k v -> k ++ "\t - " ++ v) $ M.unionWith (++) generalSetOfCommands thirdSetOfCommands
          otherwise -> M.elems $ M.mapWithKey (\k v -> k ++ "\t - " ++ v) generalSetOfCommands

toggleFlag :: InputT M ()
toggleFlag = do
  MyDataState mydata selectedElement flag <- get
  put $ MyDataState mydata selectedElement (not flag)

parseInput :: String -> InputT M () 
parseInput inp
  | ":q" == inp = return ()

  | ":help" == inp = help >> mainLoop

  | ":commands" == inp = (commands >> mainLoop)

  | ":toggleShowEven" == inp = do 
      toggleFlag 
      MyDataState mydata selectedElement flag <- get
      liftIO $ putStrLn $ "Flag has been set to " ++ (show flag)
      mainLoop

  | ":select" == inp = do
      MyDataState mydata selectedElement showEven <- get
      inputData <- local (\_ -> selectSearchFunc) $ getInputLine "\tSelect one of the data elements to be current: "
      case inputData of
        Nothing -> put (MyDataState mydata selectedElement showEven)
        Just inputD ->
          let inputInt = read inputD 
          in if elem inputInt mydata
            then put (MyDataState mydata inputInt showEven)
            else do 
              liftIO $ putStrLn $ "The element you entered (" ++ (show inputInt) ++ ") has not been found in the data set"
              put (MyDataState mydata selectedElement showEven)
      mainLoop  

  | ":show" == inp = do
      MyDataState mydata selectedElement showEven <- get
      liftIO $ putStrLn $ unwords $ if showEven 
        then map (\x -> if x == selectedElement then "[" ++ show x ++ "]" else show x) mydata
        else map (\x -> if x == selectedElement then "[" ++ show x ++ "]" else show x) $ filter odd mydata
      mainLoop 

  | ":save" == inp = do
      MyDataState mydata selectedElement _ <- get 
      liftIO $ saveDataToFile mydata
      mainLoop

  | ":load" == inp = do
      put (MyDataState loadDataFromFile defaultSelectedElement defaultFlagValue)
      mainLoop

  | ":new" == inp = do
      MyDataState mydata selectedElement showEven <- get                     -- reads the state
      inputData <- getInputLine "\tEnter data: "
      case inputData of 
        Nothing -> 
          put $ if null mydata
            then ( MyDataState [0] selectedElement showEven )
            else ( MyDataState mydata selectedElement showEven )
        Just inputD -> 
          put $ if null mydata 
            then MyDataState [read inputD] selectedElement showEven
            else MyDataState (mydata ++ [read inputD]) selectedElement showEven -- updates the state
      mainLoop

  | ":" == inp = do
    outputStrLn $ "\nNo command \"" ++ inp ++ "\"\n"
    mainLoop

  | otherwise = handleInput inp

handleInput :: String -> InputT M ()
handleInput inp = mainLoop

mainLoop :: InputT M ()
mainLoop = do
  inp <- getInputLine "% "
  maybe (return ()) parseInput inp

greet :: IO ()
greet = mapM_ putStrLn
        [ ""
        , "          MyProgram"
        , "=============================="
        , "For help type \":help\""
        , ""
        ]

main :: IO ((), MyDataState)
main = do
    greet
    runStateT (runReaderT (runInputT mySettings mainLoop) topLevelSearchFunc) MyDataState {mydata = [] , selectedElement = defaultSelectedElement, showEven = defaultFlagValue}