fork download 
  1. {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}
  2.  
  3. import System.Console.Haskeline
  4. import System.IO
  5. import System.IO.Unsafe
  6. import Control.Monad.State.Strict
  7. import qualified Data.ByteString.Char8 as B
  8. import Data.Maybe
  9. import Data.List 
  10. import qualified Data.Map as M
  11.  
  12. data MyDataState = MyDataState {
  13.   mydata :: [Int],
  14.   selectedElement :: Int,
  15.   showEven :: Bool
  16. } deriving (Show)
  17.  
  18. instance MonadState s m => MonadState s (InputT m) where
  19.     get = lift get
  20.     put = lift . put
  21.     state = lift . state
  22.  
  23. myfile :: FilePath
  24. myfile = "data.txt"
  25.  
  26. defaultFlagValue :: Bool
  27. defaultFlagValue = False
  28.  
  29. defaultSelectedElement :: Int
  30. defaultSelectedElement = 0
  31.  
  32. saveDataToFile :: [Int] -> IO ()
  33. saveDataToFile _data = withFile myfile WriteMode $ \h -> hPutStr h (unwords $ map show _data)
  34.  
  35. {-# NOINLINE loadDataFromFile #-} 
  36. loadDataFromFile :: [Int]
  37. loadDataFromFile = map read . words $ B.unpack $ unsafePerformIO $ B.readFile myfile
  38.  
  39. generalSetOfCommands = M.fromList [
  40.     (":help", "outputs this help"), 
  41.     (":q", "quits the program"), 
  42.     (":commands", "list of all commands applicable to the current selection"), 
  43.     (":show", "show current set of data"), 
  44.     (":save", "saves data to file"), 
  45.     (":load", "loads data from file"), 
  46.     (":select", "selects one of the data set elements to be current"), 
  47.     (":new", "adds element to the data set"), 
  48.     (":toggleShowEven", "toggles the flag that controls output of even data set elements")
  49.   ]
  50. firstSetOfCommands = M.fromList [
  51.     (":command1_1", "description of :command1_1"), 
  52.     (":command1_2", "description of :command1_2"), 
  53.     (":command1_3", "description of :command1_3"), 
  54.     (":command1_4", "description of :command1_4")
  55.   ]
  56. secondSetOfCommands = M.fromList [
  57.     (":command2_1", "description of :command2_1"), 
  58.     (":command2_2", "description of :command2_2"), 
  59.     (":command2_3", "description of :command2_3"), 
  60.     (":command2_4", "description of :command2_4")
  61.   ]
  62. thirdSetOfCommands = M.fromList [
  63.     (":command3_1", "description of :command3_1"), 
  64.     (":command3_2", "description of :command3_2"), 
  65.     (":command3_3", "description of :command3_3"), 
  66.     (":command3_4", "description of :command3_4")
  67.   ]
  68.  
  69. searchFunc :: MyDataState -> String -> [Completion]
  70. searchFunc (MyDataState mydata selectedElement showEven) str = 
  71.     map simpleCompletion $ filter (str `isPrefixOf`) (M.keys generalSetOfCommands ++ 
  72.         case selectedElement of 
  73.           1 -> M.keys firstSetOfCommands
  74.           2 -> M.keys secondSetOfCommands
  75.           3 -> M.keys thirdSetOfCommands
  76.           otherwise -> []
  77.     )
  78.  
  79. mySettings :: Settings (StateT MyDataState IO)
  80. mySettings = Settings { historyFile = Just "myhist"
  81.                       , complete = completeWord Nothing " \t" $ \str -> do 
  82.                           _data <- get
  83.                           return $ searchFunc _data str 
  84.                       , autoAddHistory = True
  85.                       }
  86.  
  87. help :: InputT (StateT MyDataState IO) ()
  88. help = commands
  89.  
  90. commands :: InputT (StateT MyDataState IO) ()
  91. commands = do
  92.         (MyDataState mydata selectedElement flag) <- get
  93.         liftIO $ mapM_ putStrLn $ case selectedElement of 
  94.           1 -> M.elems $ M.mapWithKey (\k v -> k ++ "\t - " ++ v) $ M.unionWith (++) generalSetOfCommands firstSetOfCommands
  95.           2 -> M.elems $ M.mapWithKey (\k v -> k ++ "\t - " ++ v) $ M.unionWith (++) generalSetOfCommands secondSetOfCommands
  96.           3 -> M.elems $ M.mapWithKey (\k v -> k ++ "\t - " ++ v) $ M.unionWith (++) generalSetOfCommands thirdSetOfCommands
  97.           otherwise -> M.elems $ M.mapWithKey (\k v -> k ++ "\t - " ++ v) generalSetOfCommands
  98.  
  99. toggleFlag :: InputT (StateT MyDataState IO) ()
  100. toggleFlag = do
  101.   MyDataState mydata selectedElement flag <- get
  102.   put $ MyDataState mydata selectedElement (not flag)
  103.  
  104. parseInput :: String -> InputT (StateT MyDataState IO) () 
  105. parseInput inp
  106.   | ":q" == inp = return ()
  107.  
  108.   | ":help" == inp = help >> mainLoop
  109.  
  110.   | ":commands" == inp = (commands >> mainLoop)
  111.  
  112.   | ":toggleShowEven" == inp = do 
  113.       toggleFlag 
  114.       MyDataState mydata selectedElement flag <- get
  115.       liftIO $ putStrLn $ "Flag has been set to " ++ (show flag)
  116.       mainLoop
  117.  
  118.   | ":select" == inp = do
  119.       MyDataState mydata selectedElement showEven <- get
  120.       inputData <- getInputLine "\tSelect one of the data elements to be current: "
  121.       case inputData of
  122.         Nothing -> put (MyDataState mydata selectedElement showEven)
  123.         Just inputD ->
  124.           let inputInt = read inputD 
  125.           in if elem inputInt mydata
  126.             then put (MyDataState mydata inputInt showEven)
  127.             else do 
  128.               liftIO $ putStrLn $ "The element you entered (" ++ (show inputInt) ++ ") has not been found in the data set"
  129.               put (MyDataState mydata selectedElement showEven)
  130.       mainLoop  
  131.  
  132.   | ":show" == inp = do
  133.       MyDataState mydata selectedElement showEven <- get
  134.       liftIO $ putStrLn $ unwords $ if showEven 
  135.         then map (\x -> if x == selectedElement then "[" ++ show x ++ "]" else show x) mydata
  136.         else map (\x -> if x == selectedElement then "[" ++ show x ++ "]" else show x) $ filter odd mydata
  137.       mainLoop 
  138.  
  139.   | ":save" == inp = do
  140.       MyDataState mydata selectedElement _ <- get 
  141.       liftIO $ saveDataToFile mydata
  142.       mainLoop
  143.  
  144.   | ":load" == inp = do
  145.       put (MyDataState loadDataFromFile defaultSelectedElement defaultFlagValue)
  146.       mainLoop
  147.  
  148.   | ":new" == inp = do
  149.       MyDataState mydata selectedElement showEven <- get                     -- reads the state
  150.       inputData <- getInputLine "\tEnter data: "
  151.       case inputData of 
  152.         Nothing -> 
  153.           put $ if null mydata
  154.             then ( MyDataState [0] selectedElement showEven )
  155.             else ( MyDataState mydata selectedElement showEven )
  156.         Just inputD -> 
  157.           put $ if null mydata 
  158.             then MyDataState [read inputD] selectedElement showEven
  159.             else MyDataState (mydata ++ [read inputD]) selectedElement showEven -- updates the state
  160.       mainLoop
  161.  
  162.   | ":" == inp = do
  163.     outputStrLn $ "\nNo command \"" ++ inp ++ "\"\n"
  164.     mainLoop
  165.  
  166.   | otherwise = handleInput inp
  167.  
  168. handleInput :: String -> InputT (StateT MyDataState IO) ()
  169. handleInput inp = mainLoop
  170.  
  171. mainLoop :: InputT (StateT MyDataState IO ) ()
  172. mainLoop = do
  173.   inp <- getInputLine "% "
  174.   maybe (return ()) parseInput inp
  175.  
  176. greet :: IO ()
  177. greet = mapM_ putStrLn
  178.         [ ""
  179.         , "          MyProgram"
  180.         , "=============================="
  181.         , "For help type \":help\""
  182.         , ""
  183.         ]
  184.  
  185. main :: IO ((), MyDataState)
  186. main = do 
  187.     greet 
  188.     runStateT (runInputT mySettings mainLoop) MyDataState {mydata = [] , selectedElement = defaultSelectedElement, showEven = defaultFlagValue}
  189.  
Success #stdin #stdout 0s 4348KB
comments (?)
stdin 
Standard input is empty
stdout 
          MyProgram
==============================
For help type ":help"

%
https://ideone.com/sFcL2N
language:
Haskell (ghc 8.4.4)
created:
6 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!