{-# LANGUAGE LambdaCase #-}

module Scanner
    ( scan
    , Scan(..)
    ) where

import Data.Bits ((.&.), testBit)
import Data.Char (ord)
import System.IO (Handle, hGetChar, hLookAhead, hWaitForInput)


timeout :: Int
timeout = 1

data Scan =
    ScanKey String
  | ScanMouse
      { mouseButton :: Int
      , mousePressed :: Bool -- True == pressed, False == released
      , mouseShift :: Bool
      , mouseMeta :: Bool
      , mouseControl :: Bool
      , mouseMotion :: Bool
      , mouseX :: Int
      , mouseY :: Int
      }
  deriving Show



scan :: Handle -> IO Scan
scan h =
    hGetChar h >>= \case
        '\ESC' -> scanESC h
        c -> return $ ScanKey [c]



scanESC :: Handle -> IO Scan
scanESC h =
    hWaitGetChar timeout h >>= \case
        Nothing -> return $ ScanKey "\ESC"
        Just c
            | c == '[' -> -- 05/11
                scanCS h
            | c == '\ESC' -> -- 01/11
                -- XXX M-F1 and other crazy chords may cause
                -- \ESC\ESC... on wu, so we just recurse here...
                scanESC h
            | c == 'O' -> -- 04/15
                -- XXX Non-CSI SS3
                -- XXX finalByte is maybe calles somehow else here, but it's
                -- the same range
                one h finalByte ['O','\ESC'] >>=
                return . ScanKey . reverse
            | otherwise ->
                return $ ScanKey ['\ESC',c]


scanCS :: Handle -> IO Scan
scanCS h =
    hWaitLookAhead timeout h >>= \case
        Nothing -> return $ ScanKey "\ESC" -- TODO move this to scanESC
        Just c
          | c == '<' -> hGetChar h >> scanSGRMousePayload h
          | c == 'M' -> hGetChar h >> scanX10MousePayload h
          | otherwise -> scanOtherCSISequence h


scanX10MousePayload :: Handle -> IO Scan
scanX10MousePayload h = do
    b <- ord <$> hGetChar h
    x <- ord <$> hGetChar h
    y <- ord <$> hGetChar h
    let pressed = (b .&. 3) /= 3
    return (decodeMouseEvent (b - 32) (x - 32) (y - 32) pressed)


scanSGRMousePayload :: Handle -> IO Scan
scanSGRMousePayload h = do
    b <- scanNumber h
    _ <- expectChar h (==';')
    x <- scanNumber h
    _ <- expectChar h (==';')
    y <- scanNumber h
    m <- hGetChar h -- 'M' or 'm'
    let pressed = (m == 'M')
    return (decodeMouseEvent b x y pressed)


scanOtherCSISequence :: Handle -> IO Scan
scanOtherCSISequence h = do
    params <- zeroOrMore h parameterByte ['[', '\ESC']
    inters <- zeroOrMore h intermediateByte params
    final <- expectChar h finalByte
    return (ScanKey (reverse (final : inters)))


scanNumber :: Handle -> IO Int
scanNumber h = go 0
  where
    go acc =
        hWaitLookAhead timeout h >>= \case
          Just c ->
            if '0' <= c && c <= '9'
              then hGetChar h >> go (acc * 10 + (ord c - ord '0'))
              else return acc

          Nothing -> fail "timeout"



zeroOrMore :: Handle -> (Char -> Bool) -> [Char] -> IO [Char]
zeroOrMore h p buf =
    hWaitLookAhead timeout h >>= \case
        Nothing -> return buf
        Just c
            | p c ->
                hGetChar h {-drop c-} >> zeroOrMore h p (c:buf)
            | otherwise ->
                return buf


one :: Handle -> (Char -> Bool) -> [Char] -> IO [Char]
one h p buf =
    expectChar h p >>= \c -> return (c : buf)


expectChar :: Handle -> (Char -> Bool) -> IO Char
expectChar h p =
    hWaitGetChar timeout h >>= \case
      Just c ->
        if p c
          then return c
          else fail ("unexpected char: " ++ show c)
      Nothing ->
        fail "timeout"


parameterByte :: Char -> Bool
parameterByte = between '0' '?'     -- 03/00 03/15

intermediateByte :: Char -> Bool
intermediateByte = between ' ' '/'  -- 02/00 02/15

finalByte :: Char -> Bool
finalByte = between '@' '~'         -- 04/00 07/14


between :: Ord a => a -> a -> (a -> Bool)
between lo hi = \ x -> lo <= x && x <= hi


hWaitGetChar :: Int -> Handle -> IO (Maybe Char)
hWaitGetChar t h = do
    ready <- hWaitForInput h t
    if ready
        then hGetChar h >>= return . Just
        else return Nothing


hWaitLookAhead :: Int -> Handle -> IO (Maybe Char)
hWaitLookAhead t h = do
    ready <- hWaitForInput h t
    if ready
        then hLookAhead h >>= return . Just
        else return Nothing


decodeMouseEvent :: Int -> Int -> Int -> Bool -> Scan
decodeMouseEvent b x y pressed =
    let
        button = case (b .&. 3) + (b .&. 64) of
                0 -> 1
                1 -> 2
                2 -> 3
                64 -> 4 -- wheel up
                65 -> 5 -- wheel down
                66 -> 6 -- wheel left
                67 -> 7 -- wheel right
                3  -> 0 -- X10 release
                btn -> error $ "TODO proper parseNormalButton error: " ++ show btn
    in
    ScanMouse
        { mouseButton  = button
        , mousePressed = pressed
        , mouseShift   = testBit b 2
        , mouseMeta    = testBit b 3
        , mouseControl = testBit b 4
        , mouseMotion  = testBit b 5
        , mouseX       = x
        , mouseY       = y
        }