Main: src/ -> app/

2 files changed, 741 insertions, 0 deletions

diff --git a/app/Main.hs b/app/Main.hs
new file mode 100644
index 0000000..3c62184
--- /dev/null
+++ b/app/Main.hs
@@ -0,0 +1,633 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Main where
+
+import Control.Lens hiding (Empty, imap)
+import Control.Applicative
+import Control.Concurrent
+import Control.Monad
+import Data.Char
+import Data.IORef
+import Data.List hiding (delete)
+import Numeric (showIntAtBase)
+import System.IO
+--import System.Posix.Signals
+
+import GHC.Stats (getRTSStats)
+
+import Control.Monad.Except
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Writer
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+import Hack.Buffer
+import Process
+import Scanner
+import Blessings
+import qualified Blessings.Internal as Blessings
+import Blessings.String ()
+
+
+data Mode
+    = InsertMode
+    | NormalMode
+    | VerbatimMode
+    | SelectRegisterMode
+    | DeleteMode
+    | YankMode
+  deriving (Eq)
+
+instance Show Mode where
+  show NormalMode = "normal"
+  show InsertMode = "insert"
+  show VerbatimMode = "verbatim"
+  show SelectRegisterMode = "select register"
+  show DeleteMode = "delete"
+  show YankMode = "yank"
+
+
+data VTConfig = VTConfig
+    { withOutput :: IO () -> IO ()
+    }
+
+data VTState = VTState
+    { _buffer :: Buffer
+    , _mode :: Mode
+    , _processCount :: Int
+    , _count :: Maybe Int
+    , _register :: Char
+    , _registers :: Map Char String
+    }
+
+instance Show VTState where
+    show VTState{..} =
+      "<VTState"
+      ++ " buffer=" ++ show _buffer
+      ++ " mode=" ++ show _mode
+      ++ " processCount=" ++ show _processCount
+      ++ " count=" ++ show (maybe 0 id _count)
+      ++ " register=" ++ show _register
+      ++ " registers=" ++ show _registers
+      ++ ">"
+
+makeLenses ''VTState
+
+
+defaultRegister :: Char
+defaultRegister = '"'
+
+main :: IO ()
+main = do
+  hSetEcho stdin False
+  hSetBuffering stdin NoBuffering
+
+  -- WINCH
+  -- TODO installHandler 28 (Catch $ ioctl 0 ...) Nothing
+
+  let st = VTState
+          { _mode = InsertMode
+          , _buffer = ("!while date; do sleep 1; done", "")
+          , _processCount = 0
+          , _count = Nothing
+          , _register = defaultRegister
+          , _registers = Map.empty
+          }
+
+  lockRef <- newMVar ()
+  qRef <- newIORef st
+  let _putState = writeIORef qRef -- TODO atomicModifyIORef (?)
+      _getState = readIORef qRef
+      _withOutput a = do
+          q <- _getState
+          withMVar lockRef $ \ _ -> do
+              clearLine
+              a
+              renderInputLine (_count q) (_mode q) (_buffer q)
+              hFlush stdout
+
+  let cf = VTConfig
+            { withOutput = _withOutput
+            }
+
+  -- render initial input line
+  _withOutput $ return ()
+
+  uiThread cf _putState _getState
+
+
+uiThread :: VTConfig -> (VTState -> IO ()) -> IO VTState -> IO ()
+uiThread cf putState getState = forever $ do
+    q0 <- getState
+
+
+    _ <- hLookAhead stdin -- wait for input
+    --t0 <- getCurrentTime
+    s <- scan stdin
+    --t1 <- getCurrentTime
+    --putStrLn $ "====> \ESC[32;1m" ++ show s ++ "\ESC[m in " ++
+    --            (show $ diffUTCTime t1 t0)
+    --            ++ ": \"\ESC[35m" ++ (s >>= colorize . toChar)
+    --            ++ "\ESC[m\""
+    --case res of
+    --    Left msg -> putStrLn $ "  error: " ++ msg
+    --    Right _ -> return ()
+
+    -- TODO don't leak C
+    let ScanKey k = s
+    let cmd = getCommand (_mode q0) k
+
+    --withOutput cf $ do
+    --    putStrLn $ show cmd
+
+    ((eitCmd, lns), q1) <- runVT cf q0 (execCommand cmd)
+
+    -- TODO only putState if it has changed (?)
+    putState q1
+
+    withOutput cf $ do
+        forM_ lns putStrLn
+
+        whenLeft eitCmd $ \err ->
+            ringBell >> putStrLn (prettyError err)
+
+        --when (mode st /= mode st') $ do
+        --    putStrLn $ "change mode: " ++ (show $ mode st')
+
+
+
+data Command
+  = AlertBadInput String
+  | DebugShowVTState
+  | InsertString String
+  | ExecuteInputBuffer
+  | MoveCursor Motion
+  | MoveCursorLeftIfAtEndOfLine
+  | MoveCursorWarn Motion
+  | ChangeMode Mode
+  -- TODO Move Count Motion
+  --      Delete Count Register Motion
+  --      etc.
+  | Combine Command Command
+  | Nop
+  | RingBell
+  | AppendCount Int
+  | SetCount (Maybe Int)
+  | SetRegister Char
+  | Delete Motion
+  | DeleteEntireLine
+  | Yank Motion
+
+
+instance Semigroup Command where
+    (<>) = Combine
+
+
+instance Monoid Command where
+    mempty = Nop
+
+
+
+data ExecError
+  = UnhandledInputError String
+  | OtherError String
+
+
+prettyError :: ExecError -> String
+
+prettyError (UnhandledInputError s) =
+    pp $ SGR [31] $
+        "unhandled input: <" <> SGR [1] (gaudySpecial [35,1] s) <> ">"
+
+prettyError (OtherError s) =
+    pp $ SGR [31] $ gaudySpecial [35] s
+
+
+
+newtype VT a = VT
+    (ReaderT VTConfig
+        (ExceptT ExecError
+            (WriterT [String]
+                (StateT VTState IO
+        )))
+        a)
+  deriving
+    ( Applicative
+    , Functor
+    , Monad
+    , MonadError ExecError
+    , MonadIO
+    , MonadReader VTConfig
+    , MonadState VTState
+    , MonadWriter [String]
+    )
+
+runVT ::
+    VTConfig -> VTState -> VT a -> IO ((Either ExecError a, [String]), VTState)
+
+runVT cf st (VT a) =
+    runStateT (runWriterT (runExceptT (runReaderT a cf))) st
+
+
+
+insertString :: String -> Buffer -> Buffer
+insertString s (ls, rs) = (ls ++ s, rs)
+
+
+execCommand :: Command -> VT ()
+
+execCommand DebugShowVTState =
+    get >>= tell . (:[]) . pp . SGR [35] . Plain . show
+
+execCommand (MoveCursor x) = do
+    c <- uses count (maybe 1 id)
+    buffer %= move x c
+
+    -- TODO apply mode constraints somewhere else
+    whenM (uses mode (==NormalMode) >>&& uses (buffer . _2) null) $
+        buffer %= gotoLeft 1
+
+-- TODO merge with mode constraints in MoveCursor
+execCommand MoveCursorLeftIfAtEndOfLine = do
+    whenM (uses (buffer . _2) null) $
+        buffer %= gotoLeft 1
+
+-- TODO Make this "real" warnings, i.e. don't throwError but tell.  This
+-- is required in order to perform any Combine-d commands regardless of
+-- failed moves.  Currently this is only used to SetCount Nothing (which
+-- is defunct atm) Alternatively we could simply reset the state when an
+-- error happens Discus!
+execCommand (MoveCursorWarn x) = do
+    b0 <- use buffer
+    execCommand (MoveCursor x)
+    b1 <- use buffer
+
+    -- TODO make this a warning or else ...
+    when (b0 == b1) $
+      throwError (OtherError $ "your motion has no effect: " ++ show x)
+
+execCommand (ChangeMode m) =
+    mode .= m
+
+execCommand (InsertString s) =
+    buffer %= insertString s
+
+execCommand ExecuteInputBuffer = do
+
+    ---- XXX hack to replace empty command line
+    --gets (null . showBuffer . buffer) >>= flip when
+    --    (modify $ \q -> q { buffer = ("!","") })
+
+    st <- get
+
+    case showBuffer (_buffer st) of
+      ":c" -> do
+          let f i = pp $ SGR [38,5,i] $ Plain $ padl 3 '0' $ show i
+          tell [ intercalate " " $ map f [0..255]
+               ]
+      ":r" -> do
+          tell [ "--- Registers ---" ]
+          tell $ map (\(r, s) -> ['"', r] ++ "  " ++ s) -- TODO pp
+               $ Map.toList (_registers st)
+      ":s" -> do
+          s <- liftIO getRTSStats
+          tell [ show s ]
+      '!' : cmdline -> do
+          --tell [ "spawn: " ++ cmdline ]
+          -- "input: <" ++ (showBuffer b >>= reform 32) ++ ">" ]
+          -- TODO register process
+          i <- processCount <<+= 1
+          cf <- ask
+          liftIO $ forkIO $ spawn i (withOutput cf) cmdline
+          return ()
+      "" -> do
+          liftIO ringBell
+      s -> do
+          let s' = SGR [32] $ gaudySpecial [1] s
+          tell [ pp $ "input: " <> s'
+               , pp $ SGR [35] $ gaudySpecial [1] $ pp s'
+               ]
+
+    buffer .= emptyBuffer
+
+execCommand (AlertBadInput s) =
+    throwError (UnhandledInputError s)
+
+execCommand (Combine c1 c2) = do
+    cf <- ask
+    q0 <- get
+
+    ((eSt1, lines1), q1) <- liftIO $ runVT cf q0 (execCommand c1)
+
+    -- TODO "stack trace"
+    whenLeft eSt1 throwError
+
+    ((eSt2, lines2), q2) <- liftIO $ runVT cf q1 (execCommand c2)
+
+    -- TODO "stack trace"
+    whenLeft eSt2 throwError
+
+    tell lines1
+    tell lines2
+
+    put q2
+
+execCommand Nop = return ()
+
+execCommand RingBell = liftIO ringBell
+
+execCommand (AppendCount i) =
+    count %= Just . (i+) . maybe 0 (10*)
+
+execCommand (SetCount i) =
+    count .= i
+
+execCommand (SetRegister c) =
+    register .= c
+
+execCommand DeleteEntireLine =
+    -- TODO Numbered registers "0 to "9
+    --      Small delete _register "-
+    modify $ \q -> do
+
+        let v = Just $ showBuffer $ _buffer q
+            r = _register q
+
+        q & buffer .~ emptyBuffer
+          & register .~ defaultRegister
+          & registers %~ (at r .~ v) .
+                         (at defaultRegister .~ v)
+
+-- TODO yank into "- (smallDeleteRegister) when deleting less than one line
+-- TODO reset register after this command (q & register .~ defaultRegister)
+execCommand (Delete x) = do
+    b0 <- use buffer
+    c <- uses count (maybe 1 id)
+    buffer %= delete x c
+    b1 <- use buffer
+
+    when (b0 == b1) $ throwError (OtherError "nothing to delete")
+
+
+-- TODO Yank register motion (after motion has incorporated count)
+execCommand (Yank x) =
+    modify $ \q@VTState{..} -> do
+        let c = maybe 1 id _count
+            y = select x c _buffer
+
+        q & registers %~ (at _register .~ Just y)
+
+
+-- XXX assumes that the cursor is already at the (cleared) input line
+-- TODO renderInputLine looks like it wants to be -> VT ()
+renderInputLine :: Maybe Int -> Mode -> Buffer -> IO ()
+renderInputLine mb_cnt m (lhs, rhs) = do
+    renderRight $
+        SGR [30,1] $
+        Plain (show m) <>
+            maybe Empty
+                  (("["<>) . (<>"]") . SGR [33,1] . Plain . show)
+                  mb_cnt
+    renderLeft $ promptString m <> gaudySpecial [35] (lhs ++ rhs)
+    moveCursorLeft $ length $ lit rhs
+
+
+renderLeft :: Blessings String -> IO ()
+renderLeft = putStr . pp
+
+
+renderRight :: Blessings String -> IO ()
+renderRight a = do
+    saveCursor
+    moveCursorRight 1024 -- XXX obviously, this is a hack..^_^
+    moveCursorLeft $ Blessings.length a - 1
+    renderLeft a
+    unsaveCursor
+
+
+
+promptString :: Mode -> Blessings String
+promptString NormalMode = SGR [33,1] "@ "
+promptString InsertMode = "> "
+promptString SelectRegisterMode = "\" "
+promptString DeleteMode = SGR [31,1] "> "
+promptString VerbatimMode = SGR [34,1] "^ "
+promptString YankMode = SGR [31,1] "y "
+
+
+spans :: (a -> Bool) -> [a] -> [Either [a] [a]]
+spans p xs = f_r (span p_r xs)
+  where
+    p_r = not . p
+    p_l = p
+    f_r (as, bs) = Right as : if null bs then [] else f_l (span p_l bs)
+    f_l (as, bs) = Left  as : if null bs then [] else f_r (span p_r bs)
+
+
+gaudySpans :: Pm -> (Char -> Bool) -> String -> Blessings String
+gaudySpans c p =
+    mconcat . map (either (SGR c . Plain . lit) Plain) . spans p
+
+
+gaudySpecial :: Pm -> String -> Blessings String
+gaudySpecial c = gaudySpans c (not . isPrint)
+
+
+lit :: String -> String
+lit = (>>= f)
+  where f '\ESC' = "^["
+        f c = showLitChar c ""
+
+
+clearLine :: IO ()
+clearLine =
+    putStr "\ESC[2K" >>
+    moveCursorLeft 1024
+
+
+ringBell :: IO ()
+ringBell = putStr "\x07" -- BEL '\a'
+
+
+saveCursor :: IO ()
+saveCursor = putStr "\ESC[s"
+
+unsaveCursor :: IO ()
+unsaveCursor = putStr "\ESC[u"
+
+
+moveCursorLeft :: Int -> IO ()
+moveCursorLeft 0 = return ()
+moveCursorLeft i = putStr $ "\ESC[" ++ show i ++ "D"
+
+
+moveCursorRight :: Int -> IO ()
+moveCursorRight 0 = return ()
+moveCursorRight i = putStr $ "\ESC[" ++ show i ++ "C"
+
+
+-- TODO? charToCode c = "\\x" ++ showHex (ord c)
+charToCode :: Char -> String
+charToCode c = "\\x" ++ showIntAtBase 16 intToDigit (ord c) ""
+
+
+dmap :: Keymap
+dmap =
+  [ ("\ESC", ChangeMode NormalMode <> SetCount Nothing)
+  , ("\ESC[24~", DebugShowVTState)
+  , ("d", DeleteEntireLine <> ChangeMode NormalMode <> SetCount Nothing)
+  , ("$", Yank ToEndOfLine <>
+          Delete ToEndOfLine <>
+          ChangeMode NormalMode <>
+          SetCount Nothing <>
+          MoveCursorLeftIfAtEndOfLine
+          )
+  , ("0", Yank ToStartOfLine <>
+          Delete ToStartOfLine <>
+          ChangeMode NormalMode <> SetCount Nothing)
+  , ("h", Yank CharsBackward <>
+          Delete CharsBackward <>
+          ChangeMode NormalMode <> SetCount Nothing)
+  , ("l", Yank CharsForward <>
+          Delete CharsForward <>
+          ChangeMode NormalMode <>
+          SetCount Nothing <>
+          MoveCursorLeftIfAtEndOfLine
+          )
+  ]
+
+
+selectRegisterMap :: Keymap
+selectRegisterMap =
+  [ ("\ESC", ChangeMode NormalMode)
+  ]
+  ++ (map (\c -> ([c], SetRegister c <> ChangeMode NormalMode))
+          (['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ".%#:-\""))
+
+
+-- TODO maybe in normal mode reset count (SetCount Nothing) after each
+-- command doesn't alter the count. How would this work together with
+-- ChangeMode DeleteMode
+-- TODO 2017-08-06
+--  initialize count whenever nmap is entered
+--  ditch SetCount Nothing
+--  pass count to commands / modes
+nmap :: Keymap
+nmap =
+  [ ("\ESC", SetCount Nothing)
+            -- ^TODO RingBell if count is already Nothing
+            --  TODO cancel any unfinished commands
+  , ("i", ChangeMode InsertMode <> SetCount Nothing)
+  , ("a", ChangeMode InsertMode <> SetCount Nothing <> MoveCursor CharsForward)
+  , ("I", ChangeMode InsertMode <> MoveCursor ToStartOfLine)
+  , ("A", ChangeMode InsertMode <> MoveCursor ToEndOfLine)
+  , ("|", MoveCursorWarn ToColumn <> SetCount Nothing)
+  , ("$", MoveCursorWarn ToEndOfLine <> SetCount Nothing)
+  , ("h", MoveCursorWarn CharsBackward <> SetCount Nothing)
+  , ("l", MoveCursorWarn CharsForward <> SetCount Nothing)
+  , ("b", MoveCursorWarn WordsBackward <> SetCount Nothing)
+  , ("w", MoveCursorWarn WordsForward <> SetCount Nothing)
+  , ("d", ChangeMode DeleteMode)
+  , ("y", ChangeMode YankMode)
+  , ("\"", ChangeMode SelectRegisterMode <> SetCount Nothing)
+  , ("\ESC[24~", DebugShowVTState)
+  , ("\ESC[C", MoveCursorWarn CharsForward <> SetCount Nothing)
+  , ("\ESC[D", MoveCursorWarn CharsBackward <> SetCount Nothing)
+  , ("\n", ExecuteInputBuffer <> ChangeMode InsertMode <> SetCount Nothing)
+  ]
+  ++ (map (\i -> (show i, AppendCount i)) [0..9])
+  -- XXX
+  --  if we would want 0 to move the cursor to the first character of the
+  --  line, then we would need ("0", x)
+  --    where
+  --      x :: Command
+  --      x = Embed f
+  --      f :: VT Command
+  --      f = gets (isJust . count) >>=
+  --          return . bool (MoveCursor ToStartOfLine) (AppendCount 0)
+  --      bool :: a -> a -> Bool -> a
+  --      bool _ a True = a
+  --      bool a _ False = a
+  --  and also we would have to extend data Command by Embed (VT Command)
+  --  execCommand (Embed a) = a >>= execCommand
+  --
+  --  This all looks quite strange, so just use | if you want that movement...
+  --  ^_^
+
+
+imap :: Keymap
+imap =
+  [ ("\ESC", ChangeMode NormalMode <> MoveCursor CharsBackward)
+  , ("\x01", MoveCursorWarn ToStartOfLine)
+  , ("\x05", MoveCursorWarn ToEndOfLine)
+  , ("\ESC[24~", DebugShowVTState)
+  , ("\ESC[3~", Delete CharsForward)
+  , ("\ESC[C", MoveCursorWarn CharsForward)
+  , ("\ESC[D", MoveCursorWarn CharsBackward)
+  , ("\x16", ChangeMode VerbatimMode) -- ^V
+  , ("\x17", Delete WordsBackward) -- ^W
+  , ("\x0a", ExecuteInputBuffer)
+  , ("\x7f", Delete CharsBackward) -- Delete
+  , ("\x08", Delete CharsBackward) -- BackSpace
+  , ("\ESCOc", MoveCursorWarn WordsForward)
+  , ("\ESCOd", MoveCursorWarn WordsBackward)
+  ]
+
+ymap :: Keymap
+ymap =
+  [ ("\ESC", ChangeMode NormalMode <> SetCount Nothing)
+  , ("\ESC[24~", DebugShowVTState)
+  -- TODO , ("y", DeleteEntireLine <> ChangeMode NormalMode <> SetCount Nothing)
+  , ("$", Yank ToEndOfLine <> ChangeMode NormalMode <> SetCount Nothing)
+  , ("0", Yank ToStartOfLine <> ChangeMode NormalMode <> SetCount Nothing)
+  , ("h", Yank CharsBackward <> ChangeMode NormalMode <> SetCount Nothing)
+  , ("l", Yank CharsForward <> ChangeMode NormalMode <> SetCount Nothing)
+  ]
+
+
+type Keymap = [(String, Command)]
+
+
+getCommand :: Mode -> String -> Command
+
+getCommand InsertMode s = maybe (InsertString s) id $ lookup s imap
+
+getCommand NormalMode s =
+    maybe (AlertBadInput s <> SetCount Nothing) id $ lookup s nmap
+
+getCommand VerbatimMode s = InsertString s <> ChangeMode InsertMode
+
+getCommand SelectRegisterMode s =
+    maybe (AlertBadInput s) id $ lookup s selectRegisterMap
+          -- ^ TODO clear bad input
+
+getCommand DeleteMode s = maybe (AlertBadInput s) id $ lookup s dmap
+
+getCommand YankMode s = maybe (AlertBadInput s) id $ lookup s ymap
+
+
+-- TODO Control.Monad.whenLeft
+whenLeft :: Monad m => Either a b -> (a -> m ()) -> m ()
+whenLeft (Left x) f = f x
+whenLeft _ _ = return ()
+
+whenM :: Monad m => m Bool -> m () -> m ()
+whenM a b = a >>= flip when b
+
+infixl 1 >>&&
+
+(>>&&) :: Monad m => m Bool -> m Bool -> m Bool
+a >>&& b = do
+    ra <- a
+    rb <- b
+    return $ ra && rb
+
+
+padl :: Int -> a -> [a] -> [a]
+padl n c s
+  | length s < n = padl n c (c : s)
+  | otherwise = s
diff --git a/app/Process.hs b/app/Process.hs
new file mode 100644
index 0000000..41ea113
--- /dev/null
+++ b/app/Process.hs
@@ -0,0 +1,108 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Process
+    ( spawn
+    , module System.Process
+    ) where
+
+import Control.Concurrent
+import Control.Monad (unless, when)
+import Data.Monoid
+import System.Exit
+import System.IO
+import System.Process
+
+import Blessings
+import Blessings.String ()
+
+
+type OutputWrapper = IO () -> IO ()
+
+data OutStreamType = Stderr | Stdout
+
+color :: OutStreamType -> Ps
+color Stderr = 31
+color Stdout = 32
+
+data ReaperConfig = ReaperConfig
+    { withOutput :: OutputWrapper
+    , jobName :: String
+    , openFdsRef :: MVar Int
+    , processHandle :: ProcessHandle
+    , streamHandle :: Handle
+    , streamType :: OutStreamType
+    }
+
+
+spawn :: Int -> OutputWrapper -> String -> IO ()
+spawn jobId _withOutput cmdline = do
+
+    -- TODO stdin
+    (Nothing, Just hOut, Just hErr, ph) <-
+        createProcess (shell cmdline)
+            { std_in = Inherit -- TODO close
+            , std_out = CreatePipe
+            , std_err = CreatePipe
+            }
+
+    _openFdsRef <- newMVar 2
+
+    let rcOut = ReaperConfig
+          { streamType = Stdout
+          , streamHandle = hOut
+          , withOutput = _withOutput
+          , jobName = '&' : show jobId
+          , openFdsRef = _openFdsRef
+          , processHandle = ph
+          }
+        rcErr = rcOut
+          { streamType = Stderr
+          , streamHandle = hErr
+          } 
+
+    forkIO $ reap rcOut
+    reap rcErr
+
+
+reap :: ReaperConfig -> IO ()
+reap rc@ReaperConfig{..} = do
+    forLines_ streamHandle $ \line ->
+        withOutput $ putStrLn $ pp $
+            SGR [35] (Plain jobName) <>
+            Plain " " <>
+            SGR [color streamType] (Plain line)
+
+    i <- decMVar openFdsRef
+
+    --withOutput $
+    --    putStrLn $ "\x1b[35m" ++ name ++ "\x1b[m eof"
+
+    when (i == 0) $ finish rc
+
+    hClose streamHandle
+    myThreadId >>= killThread
+
+
+finish :: ReaperConfig -> IO ()
+finish ReaperConfig{..} = do
+    exitCode <- waitForProcess processHandle
+    when (exitCode /= ExitSuccess) $
+        withOutput $ putStrLn $ pp $
+            SGR [35] (Plain jobName) <>
+            Plain " " <>
+            SGR [31] (Plain $ show exitCode)
+
+
+decMVar :: MVar Int -> IO Int
+decMVar =
+    flip modifyMVar dec
+  where
+    dec i = let i' = i - 1 in return (i', i')
+ 
+
+
+-- TODO move utilities somewhere else
+forLines_ :: Handle -> (String -> IO ()) -> IO ()
+forLines_ h f = rec
+  where
+    rec = hIsEOF h >>= flip unless (hGetLine h >>= f >> rec)