{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# OPTIONS_GHC -funbox-strict-fields -O #-}

#ifndef MIN_VERSION_base
#defined MIN_VERSION_base(x,y,z) 1
#endif

module Data.Terminfo.Parse ( module Data.Terminfo.Parse
                           , Text.Parsec.ParseError
                           )
    where

import Control.Monad ( liftM )
import Control.DeepSeq

import Data.Word
import qualified Data.Vector.Unboxed as Vector

import Numeric (showHex)

import Text.Parsec

#if !(MIN_VERSION_base(4,8,0))
import Data.Monoid
#endif

data CapExpression = CapExpression
    { capOps :: !CapOps
    , capBytes :: !(Vector.Vector Word8)
    , sourceString :: !String
    , paramCount :: !Int
    , paramOps :: !ParamOps
    } deriving (Eq)

instance Show CapExpression where
    show c
        = "CapExpression { " ++ show (capOps c) ++ " }"
        ++ " <- [" ++ hexDump ( map ( toEnum . fromEnum ) $! sourceString c ) ++ "]"
        ++ " <= " ++ show (sourceString c)
        where
            hexDump :: [Word8] -> String
            hexDump = foldr (\b s -> showHex b s) ""

instance NFData CapExpression where
    rnf (CapExpression ops !_bytes !str !c !pOps) 
        = rnf ops `seq` rnf str `seq` rnf c `seq` rnf pOps

type CapParam = Word

type CapOps = [CapOp]
data CapOp = 
      Bytes !Int !Int -- offset count
    | DecOut | CharOut
    -- This stores a 0-based index to the parameter. However the operation that implies this op is
    -- 1-based
    | PushParam !Word | PushValue !Word
    -- The conditional parts are the sequence of (%t expression, %e expression) pairs.
    -- The %e expression may be NOP
    | Conditional 
      { conditionalExpr :: !CapOps
      , conditionalParts :: ![(CapOps, CapOps)]
      }
    | BitwiseOr | BitwiseXOr | BitwiseAnd
    | ArithPlus | ArithMinus
    | CompareEq | CompareLt | CompareGt
    deriving (Show, Eq)

instance NFData CapOp where
    rnf (Bytes offset byteCount ) = rnf offset `seq` rnf byteCount
    rnf (PushParam pn) = rnf pn
    rnf (PushValue v) = rnf v 
    rnf (Conditional cExpr cParts) = rnf cExpr `seq` rnf cParts 
    rnf BitwiseOr = ()
    rnf BitwiseXOr = ()
    rnf BitwiseAnd = ()
    rnf ArithPlus = ()
    rnf ArithMinus = ()
    rnf CompareEq = ()
    rnf CompareLt = ()
    rnf CompareGt = ()
    rnf DecOut = ()
    rnf CharOut = ()

type ParamOps = [ParamOp]
data ParamOp =
      IncFirstTwo
    deriving (Show, Eq)

instance NFData ParamOp where
    rnf IncFirstTwo = ()

parseCapExpression :: String -> Either ParseError CapExpression
parseCapExpression capString = 
    let v = runParser capExpressionParser
                      initialBuildState
                      "terminfo cap" 
                      capString 
    in case v of
        Left e -> Left e
        Right buildResults -> Right $ constructCapExpression capString buildResults

constructCapExpression :: [Char] -> BuildResults -> CapExpression
constructCapExpression capString buildResults =
    let expr = CapExpression
                { capOps = outCapOps buildResults
                -- The cap bytes are the lower 8 bits of the input string's characters.
                -- \todo Verify the input string actually contains an 8bit byte per character.
                , capBytes = Vector.fromList $ map (toEnum.fromEnum) capString
                , sourceString = capString
                , paramCount = outParamCount buildResults
                , paramOps = outParamOps buildResults
                } 
    in rnf expr `seq` expr

type CapParser a = Parsec String BuildState a 

capExpressionParser :: CapParser BuildResults
capExpressionParser = do
    rs <- many $ paramEscapeParser <|> bytesOpParser 
    return $ mconcat rs

paramEscapeParser :: CapParser BuildResults
paramEscapeParser = do
    _ <- char '%'
    incOffset 1
    literalPercentParser <|> paramOpParser 

literalPercentParser :: CapParser BuildResults
literalPercentParser = do
    _ <- char '%'
    startOffset <- getState >>= return . nextOffset
    incOffset 1
    return $ BuildResults 0 [Bytes startOffset 1] []

paramOpParser :: CapParser BuildResults
paramOpParser
    = incrementOpParser 
    <|> pushOpParser
    <|> decOutParser
    <|> charOutParser
    <|> conditionalOpParser
    <|> bitwiseOpParser
    <|> arithOpParser
    <|> literalIntOpParser
    <|> compareOpParser
    <|> charConstParser

incrementOpParser :: CapParser BuildResults
incrementOpParser = do
    _ <- char 'i'
    incOffset 1
    return $ BuildResults 0 [] [ IncFirstTwo ]

pushOpParser :: CapParser BuildResults
pushOpParser = do
    _ <- char 'p'
    paramN <- digit >>= return . (\d -> read [d])
    incOffset 2
    return $ BuildResults (fromEnum paramN) [PushParam $ paramN - 1] []

decOutParser :: CapParser BuildResults
decOutParser = do
    _ <- char 'd'
    incOffset 1
    return $ BuildResults 0 [ DecOut ] []

charOutParser :: CapParser BuildResults
charOutParser = do
    _ <- char 'c'
    incOffset 1
    return $ BuildResults 0 [ CharOut ] []

conditionalOpParser :: CapParser BuildResults
conditionalOpParser = do
    _ <- char '?'
    incOffset 1
    condPart <- manyExpr conditionalTrueParser
    parts <- manyP 
             ( do
                truePart <- manyExpr $ choice [ try $ lookAhead conditionalEndParser
                                              , conditionalFalseParser 
                                              ]
                falsePart <- manyExpr $ choice [ try $ lookAhead conditionalEndParser
                                               , conditionalTrueParser
                                               ]
                return ( truePart, falsePart )
             ) 
             conditionalEndParser

    let trueParts = map fst parts
        falseParts = map snd parts
        BuildResults n cond condParamOps = condPart

    let n' = maximum $ n : map outParamCount trueParts
        n'' = maximum $ n' : map outParamCount falseParts

    let trueOps = map outCapOps trueParts
        falseOps = map outCapOps falseParts
        condParts = zip trueOps falseOps

    let trueParamOps = mconcat $ map outParamOps trueParts
        falseParamOps = mconcat $ map outParamOps falseParts
        pOps = mconcat [condParamOps, trueParamOps, falseParamOps]

    return $ BuildResults n'' [ Conditional cond condParts ] pOps

    where 
        manyP !p !end = choice 
            [ try end >> return []
            , do !v <- p 
                 !vs <- manyP p end
                 return $! v : vs
            ]
        manyExpr end = liftM mconcat $ manyP ( paramEscapeParser <|> bytesOpParser ) end

conditionalTrueParser :: CapParser ()
conditionalTrueParser = do
    _ <- string "%t"
    incOffset 2

conditionalFalseParser :: CapParser ()
conditionalFalseParser = do
    _ <- string "%e"
    incOffset 2

conditionalEndParser :: CapParser ()
conditionalEndParser = do
    _ <- string "%;"
    incOffset 2

bitwiseOpParser :: CapParser BuildResults
bitwiseOpParser 
    =   bitwiseOrParser
    <|> bitwiseAndParser
    <|> bitwiseXorParser

bitwiseOrParser :: CapParser BuildResults
bitwiseOrParser = do
    _ <- char '|'
    incOffset 1
    return $ BuildResults 0 [ BitwiseOr ] [ ]

bitwiseAndParser :: CapParser BuildResults
bitwiseAndParser = do
    _ <- char '&'
    incOffset 1
    return $ BuildResults 0 [ BitwiseAnd ] [ ]

bitwiseXorParser :: CapParser BuildResults
bitwiseXorParser = do
    _ <- char '^'
    incOffset 1
    return $ BuildResults 0 [ BitwiseXOr ] [ ]

arithOpParser :: CapParser BuildResults
arithOpParser 
    =   plusOp 
    <|> minusOp 
    where
        plusOp = do
            _ <- char '+'
            incOffset 1
            return $ BuildResults 0 [ ArithPlus ] [ ]
        minusOp = do
            _ <- char '-'
            incOffset 1
            return $ BuildResults 0 [ ArithMinus ] [ ]

literalIntOpParser :: CapParser BuildResults
literalIntOpParser = do
    _ <- char '{'
    incOffset 1
    nStr <- many1 digit
    incOffset $ toEnum $ length nStr
    let n :: Word = read nStr
    _ <- char '}'
    incOffset 1
    return $ BuildResults 0 [ PushValue n ] [ ]

compareOpParser :: CapParser BuildResults
compareOpParser 
    =   compareEqOp
    <|> compareLtOp 
    <|> compareGtOp 
    where
        compareEqOp = do
            _ <- char '='
            incOffset 1
            return $ BuildResults 0 [ CompareEq ] [ ]
        compareLtOp = do
            _ <- char '<'
            incOffset 1
            return $ BuildResults 0 [ CompareLt ] [ ]
        compareGtOp = do
            _ <- char '>'
            incOffset 1
            return $ BuildResults 0 [ CompareGt ] [ ]

bytesOpParser :: CapParser BuildResults
bytesOpParser = do
    bytes <- many1 $ satisfy (/= '%')
    startOffset <- getState >>= return . nextOffset
    let !c = length bytes
    !s <- getState
    let s' = s { nextOffset = startOffset + c }
    setState s'
    return $ BuildResults 0 [Bytes startOffset c] []

charConstParser :: CapParser BuildResults
charConstParser = do
    _ <- char '\''
    charValue <- liftM (toEnum . fromEnum) anyChar 
    _ <- char '\''
    incOffset 3
    return $ BuildResults 0 [ PushValue charValue ] [ ]

data BuildState = BuildState 
    { nextOffset :: Int
    } 

incOffset :: Int -> CapParser ()
incOffset n = do
    s <- getState
    let s' = s { nextOffset = nextOffset s + n }
    setState s'

initialBuildState :: BuildState
initialBuildState = BuildState 0

data BuildResults = BuildResults
    { outParamCount :: !Int
    , outCapOps :: !CapOps
    , outParamOps :: !ParamOps
    }

instance Monoid BuildResults where
    mempty = BuildResults 0 [] []
    v0 `mappend` v1 
        = BuildResults
        { outParamCount = (outParamCount v0) `max` (outParamCount v1)
        , outCapOps = (outCapOps v0) `mappend` (outCapOps v1)
        , outParamOps = (outParamOps v0) `mappend` (outParamOps v1)
        }