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

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

    import Control.Monad ( liftM )
    import Control.DeepSeq

    #if !(MIN_VERSION_base(4,11,0))
    import Data.Semigroup (Semigroup(..))
    #endif
    import Data.Word
    import qualified Data.Vector.Unboxed as Vector

    import Numeric (showHex)

    import Text.Parsec

    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
        -- The expression) pairs. %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.
                    , 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 Semigroup BuildResults where
        v0 <> v1
            = BuildResults
            { outParamCount = (outParamCount v0) `max` (outParamCount v1)
            , outCapOps = (outCapOps v0) <> (outCapOps v1)
            , outParamOps = (outParamOps v0) <> (outParamOps v1)
            }

    instance Monoid BuildResults where
        mempty = BuildResults 0 [] []
    #if !(MIN_VERSION_base(4,11,0))
        mappend = (<>)
    #endif