Main: src/ -> app/

2 files changed, 0 insertions, 741 deletions

diff --git a/src/Main.hs b/src/Main.hs
deleted file mode 100644
index 3c62184..0000000
--- a/src/Main.hs
+++ /dev/null
@@ -1,633 +0,0 @@
-{-# 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/src/Process.hs b/src/Process.hs
deleted file mode 100644
index 41ea113..0000000
--- a/src/Process.hs
+++ /dev/null
@@ -1,108 +0,0 @@
-{-# 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)