shell

module Shell
       where

import System.IO
import Data.List
import Data.Char

startsWith :: String -> String -> Bool
startsWith [] _ = True
startsWith _ [] = False
startsWith (c:cs) (m:ms) = (c==m) && startsWith cs ms

longestPrefix :: [String] -> String
longestPrefix ss = helper ss ""
  where helper [] acc = ""
        helper ss acc | any (=="") ss = acc
                      | otherwise = let x = ss !! 0
                                        b = x!!0
                                    in if all (startsWith [b]) ss
                                       then helper (map tail ss) (acc++[b]) else acc



rmdups :: Eq a => [a] -> [a]
rmdups [] = []
rmdups (e:es) = e:(rmdups (filter (/=e) es))

isUp str = (map ord str) == [27,91,65]
isDown str = (map ord str) == [27,91,66]

clearStr :: String -> IO ()
clearStr str = putStr ("\r"++ map (\_->' ') str++"\r")

data State = Newline (String, [String], [String])
           | Partial (String, String, [String], [String]) -- incomplete input followed by control characters
           | UpSearch (String, [String], [String])
           | DownSearch (String, [String], [String])
           | TabSearch (String, [String], [String])
           | PurePrefix (String, [String], [String]) -- just incomplete input

move :: State -> Char -> State
move (PurePrefix (buffer, past, future)) c | c == '\t' = TabSearch (buffer, past, future)
                                           | c == '\n' = Newline (buffer, past, future)
                                           | ord c == 127 = let b = if null buffer then buffer else ((reverse . tail . reverse) buffer)
                                                            in PurePrefix (b, past, future)
                                           | isControl c = Partial (buffer, [c], past, future)
                                           | isPrint c = PurePrefix (buffer++[c], past, future)
                                           | otherwise = PurePrefix (buffer, past, future)
move (Partial (buffer, special, past, future)) c | isUp (special++[c]) = UpSearch (buffer, past, future)
                                                 | isDown (special++[c]) = DownSearch (buffer, past, future)
                                                 | otherwise = Partial (buffer, special ++ [c], past, future)
move (TabSearch (buffer, past, future)) c | c == '\t' = TabSearch (buffer, past, future)
                                          | c == '\n' = Newline (buffer, past, future)
                                          | isPrint c = PurePrefix (buffer++[c], past, future)
                                          | otherwise = error "Control characters not expected in Tab Search mode" -- FIXME

move _ _ = error "should be handled by loop"

getBuffer :: State -> String
getBuffer (Newline (b, _, _)) = b
getBuffer (Partial (b, _, _, _)) = b
getBuffer (UpSearch (b, _, _)) = b
getBuffer (DownSearch (b, _, _)) = b
getBuffer (TabSearch (b, _, _)) = b
getBuffer (PurePrefix (b, _, _)) = b

type Launcher = String -> IO String

shell :: Launcher -> IO ()
shell launcher = do
  putStrLn "hsnsh: a shell in Haskell!"
  hSetEcho stdin False
  hSetBuffering stdin NoBuffering
  hSetBuffering stdout NoBuffering
  putStr prompt
  loop (PurePrefix ("", [], []))
  where loop state = do
          c <- getChar
          let buff = getBuffer state
          case move state c of
            st@(Partial (b, s, p, f)) -> loop st
            st@(PurePrefix (b, p, f)) -> rewrite buff b >> loop st
            Newline (b, p, f) -> do
              putStr "\n"
              if b=="exit" || b=="quit"
                then putStrLn "Thanks for using hsnsh!"
                else do
                result <- launcher b
                putStrLn result
                putStr prompt
                loop (PurePrefix ("", b:p, f))
            UpSearch (b, p, f) -> do
              if null p then loop (PurePrefix (b, p, f))
                else do
                let new_b = head p
                rewrite buff new_b
                loop (PurePrefix (new_b, tail p, buff:f))
            DownSearch (b, p, []) -> loop (PurePrefix (b, p, []))
            DownSearch (b, p, f) -> do
              let new_b = head f
              rewrite buff new_b
              loop (PurePrefix (new_b, buff:p, tail f))
            st@(TabSearch (b, p, f)) -> do
              let variants = rmdups $ filter (startsWith b) (p++f++reserved)
              if null variants then loop (TabSearch (b, p, f))
                else do
                putStrLn $ "\nvariants: "++(show variants)
                let lp = longestPrefix variants
                let s = if length b < length lp then lp else b
                putStr s
                loop (TabSearch (s, p, f))

        rewrite :: String -> String -> IO ()
        rewrite old new = clearStr (prompt ++ old) >> putStr (prompt++new)
        prompt = "nsh> "
        reserved = ["quit", "exit"]

execute :: String -> IO String
execute "help" = return $ concat $ intersperse "\n" ["modUname", "modLs", "modCat", "modTailF"]
execute command = do -- all the boring stuff: spawn a process, handle signals etc
--  pid <- forkProcess
  return "Success"