    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE BangPatterns #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE NoMonomorphismRestriction #-}
    {-# LANGUAGE NamedFieldPuns #-}
    {-# OPTIONS_GHC -funbox-strict-fields -O #-}
    module Data.Terminfo.Parse ( module Data.Terminfo.Parse
                               , Text.ParserCombinators.Parsec.ParseError
                               )
        where

    import Control.Applicative ( Applicative(..), pure, (<*>) )
    import Control.Monad ( liftM )
    import Control.Monad.Trans
    import Control.DeepSeq

    import Data.Monoid
    import Data.Word

    import Foreign.C.Types
    import Foreign.Marshal.Array
    import Foreign.Ptr

    import Text.ParserCombinators.Parsec

    type CapBytes = ( Ptr Word8, CSize )

    data CapExpression = CapExpression
        { cap_ops :: !CapOps
        , cap_bytes :: !CapBytes
        , source_string :: !String
        , param_count :: !Word
        , param_ops :: !ParamOps
        }

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

    type CapParam = Word

    type CapOps = [CapOp]
    data CapOp =
          Bytes !Int !CSize !Int
        | 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
          { conditional_expr :: !CapOps
          , conditional_parts :: ![(CapOps, CapOps)]
          }
        | BitwiseOr | BitwiseXOr | BitwiseAnd
        | ArithPlus | ArithMinus
        | CompareEq | CompareLt | CompareGt
        deriving ( Show )

    instance NFData CapOp where
        rnf (Bytes offset _count next_offset) = rnf offset `seq` rnf next_offset
        rnf (PushParam pn) = rnf pn
        rnf (PushValue v) = rnf v
        rnf (Conditional c_expr c_parts) = rnf c_expr `seq` rnf c_parts
        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 )

    instance NFData ParamOp where
        rnf IncFirstTwo = ()

    parse_cap_expression :: ( Applicative m
                            , MonadIO m
                            )
                         => String
                         -> m ( Either ParseError CapExpression )
    parse_cap_expression cap_string =
        let v = runParser cap_expression_parser
                               initial_build_state
                               "terminfo cap"
                               cap_string
        in case v of
            Left e -> return $ Left e
            Right build_results -> pure Right <*> construct_cap_expression cap_string build_results

    construct_cap_expression :: MonadIO m => [Char] -> BuildResults -> m CapExpression
    construct_cap_expression cap_string build_results = do
        byte_array <- liftIO $ newArray (map ( toEnum . fromEnum ) cap_string )
        let expr = CapExpression
                    { cap_ops = out_cap_ops build_results
                    -- 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.
                    , cap_bytes = ( byte_array, toEnum $! length cap_string )
                    , source_string = cap_string
                    , param_count = out_param_count build_results
                    , param_ops = out_param_ops build_results
                    }
        return $! rnf expr `seq` expr

    type CapParser a = GenParser Char BuildState a

    cap_expression_parser :: CapParser BuildResults
    cap_expression_parser = do
        rs <- many $ param_escape_parser <|> bytes_op_parser
        return $ mconcat rs

    param_escape_parser :: CapParser BuildResults
    param_escape_parser = do
        _ <- char '%'
        inc_offset 1
        literal_percent_parser <|> param_op_parser

    literal_percent_parser :: CapParser BuildResults
    literal_percent_parser = do
        _ <- char '%'
        start_offset <- getState >>= return . next_offset
        inc_offset 1
        return $ BuildResults 0 [Bytes start_offset 1 1] []

    param_op_parser :: CapParser BuildResults
    param_op_parser
        = increment_op_parser
        <|> push_op_parser
        <|> dec_out_parser
        <|> char_out_parser
        <|> conditional_op_parser
        <|> bitwise_op_parser
        <|> arith_op_parser
        <|> literal_int_op_parser
        <|> compare_op_parser
        <|> char_const_parser

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

    push_op_parser :: CapParser BuildResults
    push_op_parser = do
        _ <- char 'p'
        param_n <- digit >>= return . (\d -> read [d])
        inc_offset 2
        return $ BuildResults param_n [ PushParam $ param_n - 1 ] []

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

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

    conditional_op_parser :: CapParser BuildResults
    conditional_op_parser = do
        _ <- char '?'
        inc_offset 1
        cond_part <- many_expr conditional_true_parser
        parts <- many_p
                    ( do
                        true_part <- many_expr $ choice [ try $ lookAhead conditional_end_parser
                                                        , conditional_false_parser
                                                        ]
                        false_part <- many_expr $ choice [ try $ lookAhead conditional_end_parser
                                                         , conditional_true_parser
                                                         ]
                        return ( true_part, false_part )
                    )
                    conditional_end_parser

        let true_parts = map fst parts
            false_parts = map snd parts
            BuildResults n cond cond_param_ops = cond_part

        let n' = maximum $ n : map out_param_count true_parts
            n'' = maximum $ n' : map out_param_count false_parts

        let true_ops = map out_cap_ops true_parts
            false_ops = map out_cap_ops false_parts
            cond_parts = zip true_ops false_ops

        let true_param_ops = mconcat $ map out_param_ops true_parts
            false_param_ops = mconcat $ map out_param_ops false_parts
            p_ops = mconcat [cond_param_ops, true_param_ops, false_param_ops]

        return $ BuildResults n'' [ Conditional cond cond_parts ] p_ops

        where
            many_p !p !end = choice
                [ try end >> return []
                , do !v <- p
                     !vs <- many_p p end
                     return $! v : vs
                ]
            many_expr end = liftM mconcat $ many_p ( param_escape_parser <|> bytes_op_parser ) end

    conditional_true_parser :: CapParser ()
    conditional_true_parser = do
        _ <- string "%t"
        inc_offset 2

    conditional_false_parser :: CapParser ()
    conditional_false_parser = do
        _ <- string "%e"
        inc_offset 2

    conditional_end_parser :: CapParser ()
    conditional_end_parser = do
        _ <- string "%;"
        inc_offset 2

    bitwise_op_parser :: CapParser BuildResults
    bitwise_op_parser
        =   bitwise_or_parser
        <|> bitwise_and_parser
        <|> bitwise_xor_parser

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

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

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

    arith_op_parser :: CapParser BuildResults
    arith_op_parser
        =   plus_op
        <|> minus_op
        where
            plus_op = do
                _ <- char '+'
                inc_offset 1
                return $ BuildResults 0 [ ArithPlus ] [ ]
            minus_op = do
                _ <- char '-'
                inc_offset 1
                return $ BuildResults 0 [ ArithMinus ] [ ]

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

    compare_op_parser :: CapParser BuildResults
    compare_op_parser
        =   compare_eq_op
        <|> compare_lt_op
        <|> compare_gt_op
        where
            compare_eq_op = do
                _ <- char '='
                inc_offset 1
                return $ BuildResults 0 [ CompareEq ] [ ]
            compare_lt_op = do
                _ <- char '<'
                inc_offset 1
                return $ BuildResults 0 [ CompareLt ] [ ]
            compare_gt_op = do
                _ <- char '>'
                inc_offset 1
                return $ BuildResults 0 [ CompareGt ] [ ]

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

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

    data BuildState = BuildState
        { next_offset :: Int
        }

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

    initial_build_state :: BuildState
    initial_build_state = BuildState 0

    data BuildResults = BuildResults
        { out_param_count :: !Word
        , out_cap_ops :: !CapOps
        , out_param_ops :: !ParamOps
        }

    instance Monoid BuildResults where
        mempty = BuildResults 0 [] []
        v0 `mappend` v1
            = BuildResults
            { out_param_count = (out_param_count v0) `max` (out_param_count v1)
            , out_cap_ops = (out_cap_ops v0) `mappend` (out_cap_ops v1)
            , out_param_ops = (out_param_ops v0) `mappend` (out_param_ops v1)
            }