Skip to content
This repository
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 91 lines (78 sloc) 3.182 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NamedFieldPuns #-}
module VerifyEvalTerminfoCaps where

import Blaze.ByteString.Builder.Internal.Write (runWrite, getBound)
import Data.Terminfo.Eval
import Data.Terminfo.Parse
import Control.DeepSeq

import qualified System.Console.Terminfo as Terminfo

import Verify
import Verify.Graphics.Vty.Output

import Control.Applicative ( (<$>) )
import Control.Exception ( try, SomeException(..) )

import Control.Monad ( mapM_, forM, forM_ )

import Data.Maybe ( fromJust )
import Data.Word

import Foreign.Marshal.Alloc (mallocBytes)
import Foreign.Ptr (Ptr, minusPtr)
import Numeric

-- If a terminal defines one of the caps then it's expected to be parsable.
capsOfInterest =
    [ "cup"
    , "sc"
    , "rc"
    , "setf"
    , "setb"
    , "setaf"
    , "setab"
    , "op"
    , "cnorm"
    , "civis"
    , "smcup"
    , "rmcup"
    , "clear"
    , "hpa"
    , "vpa"
    , "sgr"
    , "sgr0"
    ]

fromCapname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr name)

tests :: IO [Test]
tests = do
    evalBuffer :: Ptr Word8 <- mallocBytes (1024 * 1024) -- Should be big enough for any termcaps ;-)
    fmap concat $ forM terminalsOfInterest $ \termName -> do
        putStrLn $ "adding tests for terminal: " ++ termName
        mti <- try $ Terminfo.setupTerm termName
        case mti of
            Left (_e :: SomeException)
                -> return []
            Right ti -> do
                fmap concat $ forM capsOfInterest $ \capName -> do
                    case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
                        Just capDef -> do
                            putStrLn $ "\tadding test for cap: " ++ capName
                            let testName = termName ++ "(" ++ capName ++ ")"
                            case parseCapExpression capDef of
                                Left error -> return [verify testName (failed {reason = "parse error " ++ show error})]
                                Right !cap_expr -> return [verify testName (verifyEvalCap evalBuffer cap_expr)]
                        Nothing -> do
                            return []

{-# NOINLINE verifyEvalCap #-}
verifyEvalCap :: Ptr Word8 -> CapExpression -> Int -> Property
verifyEvalCap evalBuffer expr !junkInt = do
    forAll (vector 9) $ \inputValues ->
        let write = writeCapExpr expr inputValues
            !byteCount = getBound write
        in liftIOResult $ do
            let startPtr :: Ptr Word8 = evalBuffer
            forM_ [0..100] $ \i -> runWrite write startPtr
            endPtr <- runWrite write startPtr
            case endPtr `minusPtr` startPtr of
                count | count < 0 ->
                            return $ failed { reason = "End pointer before start pointer." }
                      | toEnum count > byteCount ->
                            return $ failed { reason = "End pointer past end of buffer by "
                                                       ++ show (toEnum count - byteCount)
                                            }
                      | otherwise ->
                            return succeeded

Something went wrong with that request. Please try again.