packages feed

deka-tests (empty) → 0.6.0.2

raw patch · 33 files changed

+2036/−0 lines, 33 filesdep +QuickCheckdep +basedep +bytestringsetup-changed

Dependencies added: QuickCheck, base, bytestring, containers, deka, parsec, pipes, quickpull, transformers

Files

+ ChangeLog view
@@ -0,0 +1,40 @@+version 0.6.0.2:++* changed build system to use cartel.++* moved tests to separate package, deka-tests++version 0.6.0.0:++* switch to mpdecimal for the underlying C library.  This allows+higher limits on exponents and precision.  All arithmetic is now+(practically speaking) arbitrary precision.  This also allows more+operations, such as logarithms and all exponents.  As a possible+disadvantage, this might be slower than decNumber (but I have not+benchmarked this.)++version 0.4.0.4:++* test with GHC 7.8.2++* bundle in decNumber for easier building.++version 0.4.0.2:++* remove version upper bounds++* lower version lower bounds to allow building with GHC 7.4++* add Sunlight tests++version 0.4.0.0:++* removed bindings-dsl; see comments in git log++* made Quad an instance of Eq and Ord++version 0.2.0.2:++* updated .travis.yml for decnumber dependency++* Removed spurious dependencies from .cabal file
+ LICENSE view
@@ -0,0 +1,68 @@+License for deka:++Copyright (c) 2014, Omari Norman++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Omari Norman nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++Deka includes code from the decNumber C library.  The license+for decNumber is as follows:++COPYRIGHT AND PERMISSION NOTICE++Copyright (c) 1995-2005 International Business Machines Corporation and others+All rights reserved.++Permission is hereby granted, free of charge, to any person obtaining a+copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, and/or sell copies of the Software, and to permit persons+to whom the Software is furnished to do so, provided that the above+copyright notice(s) and this permission notice appear in all copies of+the Software and that both the above copyright notice(s) and this+permission notice appear in supporting documentation.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS+OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT+OF THIRD PARTY RIGHTS. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR+HOLDERS INCLUDED IN THIS NOTICE BE LIABLE FOR ANY CLAIM, OR ANY SPECIAL+INDIRECT OR CONSEQUENTIAL DAMAGES, OR ANY DAMAGES WHATSOEVER RESULTING+FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,+NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION+WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.++Except as contained in this notice, the name of a copyright holder+shall not be used in advertising or otherwise to promote the sale, use+or other dealings in this Software without prior written authorization+of the copyright holder.++--------------------------------------------------------------------------------+All trademarks and registered trademarks mentioned herein are the property of their respective owners.
+ README.md view
@@ -0,0 +1,63 @@+# deka++deka provides correctly rounded decimal arithmetic for Haskell.++The core of deka is a binding to the C library mpdecimal.  You need+to install mpdecimal; otherwise, your executables will not link.+mpdecimal is available here:++http://www.bytereef.org/mpdecimal/index.html++mpdecimal has also been packaged for some Linux distributions, such+as Debian (libmpdec-dev) and Arch (mpdecimal).  deka has been tested+with mpdecimal version 2.4.0.++As the author of deka, I have no association with the author of+mpdecimal, and any errors in this library are mine and should be+reported to omari@smileystation.com or to the Github tracker at++http://www.github.com/massysett/deka++You will want to understand the General Decimal Arithmetic+Specification in order to fully understand deka.  The specification+is at++http://speleotrove.com/decimal/decarith.html++and more about decimal arithmetic generally at++http://speleotrove.com/decimal/++## Dependencies++The main deka library depends only on `base`, `bytestring`, and+`parsec`, so it shouldn't be difficult to build.  The tests use+[tasty](http://documentup.com/feuerbach/tasty) and+[QuickCheck](http://hackage.haskell.org/package/QuickCheck).++## Test status++deka is tested using the tests available on the General Decimal+Arithmetic website:++http://speleotrove.com/decimal/dectest.html++Some of these tests currently fail.  The failures are in edge cases+that should not affect most usage.  Diagnosing these failures is on+the TODO list.++## More documentation++Much more documentation is available in the Haddock comments in the+source files.  There is also a file of examples to get you started.+It has copious comments.  It is written in literate Haskell, so the+compiler keeps me honest with the example code.  Unfortunately+Haddock does not play very nice with literate Haskell.  However, the+file is easy to view on Github:++[Examples](lib/Data/Deka/Docs/Examples.lhs)++## License++deka is licensed under the BSD license, see the LICENSE file.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ current-versions.txt view
@@ -0,0 +1,53 @@+This package was tested to work with these dependency+versions and compiler version.+These are the default versions fetched by cabal install.+Tested as of: 2014-07-16 13:56:43.863793 UTC+Path to compiler: ghc-7.8.3+Compiler description: 7.8.3++/opt/ghc/7.8.3/lib/ghc-7.8.3/package.conf.d:+    Cabal-1.18.1.3+    array-0.5.0.0+    base-4.7.0.1+    bin-package-db-0.0.0.0+    binary-0.7.1.0+    rts-1.0+    bytestring-0.10.4.0+    containers-0.5.5.1+    deepseq-1.3.0.2+    directory-1.2.1.0+    filepath-1.3.0.2+    (ghc-7.8.3)+    ghc-prim-0.3.1.0+    haskeline-0.7.1.2+    (haskell2010-1.1.2.0)+    (haskell98-2.0.0.3)+    hoopl-3.10.0.1+    hpc-0.6.0.1+    integer-gmp-0.5.1.0+    old-locale-1.0.0.6+    old-time-1.1.0.2+    pretty-1.1.1.1+    process-1.2.0.0+    template-haskell-2.9.0.0+    terminfo-0.4.0.0+    time-1.4.2+    transformers-0.3.0.0+    unix-2.7.0.1+    xhtml-3000.2.1++/home/massysett/deka/tests/sunlight-19453/db:+    QuickCheck-2.7.6+    deka-0.6.0.2+    deka-tests-0.6.0.2+    mmorph-1.0.3+    mtl-2.2.1+    parsec-3.1.5+    pipes-4.1.2+    primitive-0.5.3.0+    quickpull-0.2.0.0+    random-1.0.1.1+    text-1.1.1.3+    tf-random-0.5+    transformers-0.4.1.0+
+ dectest/Arity.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Use functions in here to test any testcase except toSci,+-- toEng, or apply.  Those have special rules for operand parsing.+module Arity where++import TestLog+import qualified Data.ByteString.Char8 as BS8+import qualified Deka.Dec as D+import qualified Deka.Context as C+import Control.Monad+import Data.Monoid+import Operand+import Result+import Types+import Directives+import TestHelpers++type Unary = D.Dec -> C.Ctx D.Dec+type Binary = D.Dec -> D.Dec -> C.Ctx D.Dec+type Ternary = D.Dec -> D.Dec -> D.Dec -> C.Ctx D.Dec++unary :: Unary -> Test+unary f dirs ops rslt conds = runTestLog $ do+  ic <- parseDirectives dirs+  op <- case ops of+    x:[] -> operand ic x+    _ -> flunk $ "one operand expected, got " <>+      (BS8.pack . show . length $ ops)+  mayRslt <- result rslt+  let k = ic >> f op+      (r, fl) = C.runCtxStatus k+  testConditions conds fl+  testDec r mayRslt+  pass "conditions and result match targets"++binary :: Binary -> Test+binary f dirs ops rslt conds = runTestLog $ do+  ic <- parseDirectives dirs+  (opX, opY) <- case ops of+    x:y:[] -> do+      ox <- operand ic x+      oy <- operand ic y+      return (ox, oy)+    _ -> flunk $ "two operands expected, got " <>+      (BS8.pack . show . length $ ops)+  mayRslt <- result rslt+  let k = ic >> f opX opY+      (r, fl) = C.runCtxStatus k+  testConditions conds fl+  testDec r mayRslt+  pass "conditions and result match targets"++comparer :: (D.Dec -> D.Dec -> Ordering) -> Test+comparer f dirs ops rslt conds = runTestLog $ do+  when (not . null $ conds) . flunk $+    "comparer: conditions not null, which makes no sense "+    <> "for this kind of test."+  ic <- parseDirectives dirs+  (opX, opY) <- case ops of+    x:y:[] -> do+      ox <- operand ic x+      oy <- operand ic y+      return (ox, oy)+    _ -> flunk $ "two operands expected, got " <>+      (BS8.pack . show . length $ ops)+  rsltO <- resultOrd rslt+  let r = f opX opY+  if rsltO == r+    then pass "conditions and result match targets"+    else flunk $ "expected: " <> (BS8.pack . show $ rsltO)+          <> " got: " <> (BS8.pack . show $ r)++binaryTest :: (D.Dec -> D.Dec -> Bool) -> Test+binaryTest f dirs ops rslt conds = runTestLog $ do+  when (not . null $ conds) . flunk $+    "binaryTest: conditions not null, which makes no sense "+    <> "for this kind of test."+  ic <- parseDirectives dirs+  (opX, opY) <- case ops of+    x:y:[] -> do+      ox <- operand ic x+      oy <- operand ic y+      return (ox, oy)+    _ -> flunk $ "two operands expected, got " <>+      (BS8.pack . show . length $ ops)+  rsltB <- resultBool rslt+  let r = f opX opY+  if rsltB == r+    then pass "conditions and result match targets"+    else flunk $ "expected: " <> (BS8.pack . show $ rsltB)+          <> " got: " <> (BS8.pack . show $ r)+++decAndIntegral+  :: (D.Dec -> D.Signed -> C.Ctx D.Dec) -> Test++decAndIntegral f dirs ops rslt conds = runTestLog $ do+  ic <- parseDirectives dirs+  (opX, opY) <- case ops of+    x:y:[] -> do+      ox <- operand ic x+      oy <- operandIntegral y+      return (ox, oy)+    _ -> flunk $ "two operands expected, got " <>+      (BS8.pack . show . length $ ops)+  let k = ic >> f opX opY+      (r, fl) = C.runCtxStatus k+  mayRslt <- result rslt+  testConditions conds fl+  testDec r mayRslt+  pass "conditions and results match targets"++ternary :: Ternary -> Test+ternary f dirs ops rslt conds = runTestLog $ do+  ic <- parseDirectives dirs+  (opX, opY, opZ) <- case ops of+    x:y:z:[] -> do+      ox <- operand ic x+      oy <- operand ic y+      oz <- operand ic z+      return (ox, oy, oz)+    _ -> flunk $ "three operands expected, got " <>+      (BS8.pack . show . length $ ops)+  mayRslt <- result rslt+  let k = ic >> f opX opY opZ+      (r, fl) = C.runCtxStatus k+  testConditions conds fl+  testDec r mayRslt+  pass "conditions and result match targets"+
+ dectest/Conditions.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE OverloadedStrings #-}++module Conditions where++import qualified Data.ByteString.Char8 as BS8+import TestLog+import Data.String+import qualified Deka.Context as C+import Data.Monoid+import Data.Char (toLower)+import Data.List (sort)++-- | Parses and sorts a list of conditions.++parseConditions :: [BS8.ByteString] -> TestLog [C.Flag]+parseConditions = fmap sort . mapM parseCondition++parseCondition :: BS8.ByteString -> TestLog C.Flag+parseCondition str = case lookup s allConditions of+  Nothing -> flunk $ "could not parse condition: " <> str+  Just f -> tell ("parsed condition: " <> str) >> return f+  where+    s = map toLower . BS8.unpack $ str++allConditions :: IsString a => [(a, C.Flag)]+allConditions =+  [ ("clamped", C.clamped)+  , ("conversion_syntax", C.conversionSyntax)+  , ("division_by_zero", C.divisionByZero)+  , ("division_impossible", C.divisionImpossible)+  , ("division_undefined", C.divisionUndefined)+  , ("inexact", C.inexact)++  -- insufficient_storage not present in mpdecimal - not used in the+  -- tests+  -- , ("insufficient_storage", C.insufficientStorage)++  , ("invalid_context", C.invalidContext)+  , ("invalid_operation", C.invalidOperation)++  -- lost_digits - not present in mpdecimal - but also not in the+  -- decNumber tests+  --, ("lost_digits", C.lostDigits)++  , ("overflow", C.overflow)+  , ("rounded", C.rounded)+  , ("subnormal", C.subnormal)+  , ("underflow", C.underflow)+  ]+
+ dectest/Directives.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE OverloadedStrings #-}+module Directives where++import qualified Parse as P+import qualified Deka.Context as C+import Data.Char (toLower)+import qualified Data.ByteString.Char8 as BS8+import Data.Monoid+import TestLog+import Util+import Data.String+import qualified Data.Sequence as S+import Data.Sequence(ViewR(..))++data Directives = Directives+  { dsPrecision :: Maybe P.Value+  , dsRounding :: Maybe P.Value+  , dsEmax :: Maybe P.Value+  , dsEmin :: Maybe P.Value+  , dsExtended :: Maybe P.Value+  , dsClamp :: Maybe P.Value+  , dsVersion :: Maybe P.Value+  } deriving Show++type Getter = Directives -> Maybe P.Value+type Setter = P.Value -> Directives -> Directives++dirFields+  :: IsString a+  => [(a, (Getter, Setter))]+dirFields =+  [ ("precision", (dsPrecision, \v d -> d { dsPrecision = Just v }))+  , ("rounding", (dsRounding, \v d -> d { dsRounding = Just v }))+  , ("maxexponent", (dsEmax, \v d -> d { dsEmax = Just v }))+  , ("minexponent", (dsEmin, \v d -> d { dsEmin = Just v }))+  , ("extended", (dsExtended, \v d -> d { dsExtended = Just v }))+  , ("clamp", (dsClamp, \v d -> d { dsClamp = Just v }))+  , ("version", (dsVersion, \v d -> d { dsVersion = Just v }))+  ]++emptyDirectives :: Directives+emptyDirectives = Directives Nothing Nothing Nothing Nothing+  Nothing Nothing Nothing++plusDirective+  :: (P.Keyword, P.Value)+  -> Directives+  -> TestLog Directives+plusDirective (kw, vl) d = case lookup k dirFields of+  Nothing -> flunk $ "could not find directive: " <> BS8.pack k+  Just p -> add p+  where+    (k, v) = (map toLower . BS8.unpack . P.unKeyword $ kw,+              P.unValue vl)+    add (get, set) = case get d of+      Nothing -> do+        tell $ "using directive " <> BS8.pack k <> " with value " <> v+        return $ set vl d+      Just _ -> do+        tell $ "ignoring old directive " <> BS8.pack k+          <> " with value " <> v+        return d++plusDirectives+  :: S.Seq (P.Keyword, P.Value)+  -> TestLog Directives+plusDirectives = go emptyDirectives+  where+    go ds sq = case S.viewr sq of+      EmptyR -> return ds+      sq' :> p -> do+        ds' <- plusDirective p ds+        go ds' sq'++directivesToCtx :: Directives -> TestLog (C.Ctx ())+directivesToCtx ds = do++  rnd <- case dsRounding ds of+    Nothing -> return (return ())+    Just (P.Value r) -> do+      let dflt = flunk $ "could not set rounding: " <> r+          mayRnd = lookup r allRounds+      rnd <- maybe dflt return mayRnd+      tell $ "setting rounding to " <> r+      return (C.setRound rnd)++  clmp <- case dsClamp ds of+    Nothing -> return (return ())+    Just (P.Value r) -> case readNumberBS r >>= parseBool of+      Nothing -> flunk $ "could not set clamp: " <> r+      Just p -> do+        tell $ "setting clamp to " <> BS8.pack (show p)+        return (C.setClamp p)++  tri <- do+    pcsn <- case dsPrecision ds of+      Nothing -> flunk "precision not present in directives"+      Just (P.Value r) -> case readNumberBS r >>= C.precision of+        Nothing -> flunk $ "could not set precision: " <> r+        Just p -> do+          tell $ "using for precision: " <> r+          return p++    emx <- case dsEmax ds of+      Nothing -> flunk "emax not present in directives"+      Just (P.Value r) -> case readNumberBS r >>= C.emax of+        Nothing -> flunk $ "could not set emax: " <> r+        Just x -> do+          tell $ "using for Emax: " <> r+          return x++    emn <- case dsEmin ds of+      Nothing -> flunk "emin not present in directives"+      Just (P.Value r) -> case readNumberBS r >>= C.emin of+        Nothing -> flunk $ "could not set emin: " <> r+        Just x -> do+          tell $ "using for Emin: " <> r+          return x++    case C.trio pcsn emx emn of+      Nothing -> flunk $ "failed to set trio"+      Just t -> return $ C.setTrio t++  return $ rnd >> clmp >> tri++parseDirectives+  :: S.Seq (P.Keyword, P.Value)+  -> TestLog (C.Ctx ())+parseDirectives sq = plusDirectives sq >>= directivesToCtx++allRounds :: IsString a => [(a, C.Round)]+allRounds =+  [ ("ceiling", C.roundCeiling)+  , ("up", C.roundUp)+  , ("half_up", C.roundHalfUp)+  , ("half_even", C.roundHalfEven)+  , ("half_down", C.roundHalfDown)+  , ("down", C.roundDown)+  , ("floor", C.roundFloor)+  , ("05up", C.round05Up)+  ]+
+ dectest/NumTests.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-}++module NumTests where++import Arity+import Types+import Specials+import Deka.Dec+import qualified Data.ByteString.Char8 as BS8++testLookups :: [(BS8.ByteString, Test)]+testLookups =+  [ ("abs", unary abs)+  , ("add", binary add)+  , ("and", binary and)+  , ("apply", apply)+  -- skip: canonical+  , ("class", decClass)+  , ("compare", binary compare)+  , ("comparesig", binary compareSignal)+  , ("comparetotal", comparer compareTotal)+  , ("comparetotalmag", comparer compareTotalMag)+  -- skip: copy, copyabs, copynegate, copysign+  , ("divide", binary divide)+  , ("divideint", binary divideInteger)+  , ("exp", unary exp)+  , ("fma", ternary fma)+  , ("invert", unary invert)+  , ("ln", unary ln)+  , ("log10", unary log10)+  , ("logb", unary logB)+  , ("max", binary max)+  , ("min", binary min)+  , ("maxmag", binary maxMag)+  , ("minmag", binary minMag)+  , ("minus", unary minus)+  , ("multiply", binary multiply)+  , ("nextminus", unary nextMinus)+  , ("nextplus", unary nextPlus)+  , ("nexttoward", binary nextToward)+  , ("or", binary or)+  , ("plus", unary plus)+  , ("power", binary power)+  , ("quantize", binary quantize)+  , ("reduce", unary reduce)+  , ("remainder", binary remainder)+  , ("remaindernear", binary remainderNear)+  , ("rescale", decAndIntegral rescale)+  , ("rotate", binary rotate)+  , ("samequantum", binaryTest sameQuantum)+  , ("scaleb", binary scaleB)+  , ("shift", binary shift)+  , ("squareroot", unary squareRoot)+  , ("subtract", binary subtract)+  , ("toEng", toEng)+  , ("tointegral", unary toIntegralValue)+  , ("toIntegralx", unary toIntegralExact)+  , ("toSci", toSci)+  -- skip: trim+  , ("xor", binary xor)+  ]
+ dectest/Operand.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings #-}+module Operand where++import TestLog+import qualified Data.ByteString.Char8 as BS8+import qualified Deka.Dec as D+import qualified Deka.Context as C+import Data.Monoid+import Util++-- | Parses an operand.  Do not use this function for @toSci@,+-- @toEng@, or @apply@ as those have special rules for handling the+-- context.+--+-- Bypasses if the operand contains any octothorpe.++operand+  :: C.Ctx ()+  -- ^ Initial context to use+  -> BS8.ByteString+  -- ^ Parse this token+  -> TestLog D.Dec+operand ic bs+  | '#' `BS8.elem` bs =+      bypass $ "operand contains an octothorpe: " <> bs+  | otherwise = do+      tell $ "parsing operand token: " <> bs+      let k = do+            ic+            p <- fmap C.unPrecision C.setMaxPrecision+            s <- D.fromByteString bs+            return (p, s)+      let (p, r) = C.runCtx k+      tell $ "operand parse result: " <> D.toByteString r+        <> " parsed at precision: " <> BS8.pack (show p)+      return r++-- | Parses an operand into a context.  Use this function for+-- @toSci@, @toEng@, and @apply@.  Bypasses if the operand contains+-- any octothorpe.+operandSciEngAp+  :: C.Ctx ()+  -- ^ Initial context to use+  -> BS8.ByteString+  -- ^ Parse this token+  -> TestLog (C.Ctx D.Dec)+operandSciEngAp ic bs+  | '#' `BS8.elem` bs =+      bypass $ "operand contains an octothorpe: " <> bs+  | otherwise = do+      tell $ "parsing operand token: " <> bs+      let k = ic >> D.fromByteString bs+      return k++-- | Parses a signed integral operand.+operandIntegral+  :: BS8.ByteString+  -> TestLog D.Signed+operandIntegral bs+  | '#' `BS8.elem` bs =+      bypass $ "operand contains an octothorpe: " <> bs++  | otherwise = case readNumberBS bs of+      Nothing -> flunk $ "could not parse integral operand: " <> bs+      Just r -> do+        tell $ "parsed integral operand: " <> bs+        return r
+ dectest/Parse.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE OverloadedStrings #-}+module Parse where++import Parse.Tokens+import qualified Data.ByteString.Char8 as BS8++-- | Remove the comments from a line of tokens.  Any unquoted token that+-- starts with two dashes is removed.  Also, any token that comes+-- after such a token is also removed.+removeComments :: [Token] -> [Token]+removeComments toks = go toks+  where+    go [] = []+    go (t:ts)+      | quoted t = t : go ts+      | BS8.take 2 (unToken t) == "--" = []+      | otherwise = t : go ts++newtype Keyword = Keyword { unKeyword :: BS8.ByteString }+  deriving (Eq, Show)++newtype Value = Value { unValue :: BS8.ByteString }+  deriving (Eq, Show)++data TestSpec = TestSpec+  { testId :: BS8.ByteString+  , testOperation :: BS8.ByteString+  , testOperands :: [BS8.ByteString]+  , testResult :: BS8.ByteString+  , testConditions :: [BS8.ByteString]+  } deriving Show++data Instruction+  = Blank+  | Directive Keyword Value+  | Test TestSpec+  deriving Show++data File = File+  { fileName :: BS8.ByteString+  , fileContents :: [Either File Instruction]+  } deriving Show++directive :: [Token] -> (Keyword, Value)+directive ts = case ts of+  x:y:[] -> ( Keyword . BS8.init . unToken $ x,+              Value (unToken y) )+  _ -> error "directive: bad token count"++lineToContent :: [Token] -> IO (Either File Instruction)+lineToContent ts+  | null ts = return . Right $ Blank+  | length ts == 2 && kw == "dectest" = fmap Left $ parseFile fn+  | length ts == 2 = return . Right $ Directive akw avl+  | otherwise = return . Right . Test . mkTestSpec $ ts+  where+    (akw@(Keyword kw), avl@(Value val)) = directive ts+    fn = val `BS8.append` ".decTest"+  +mkTestSpec :: [Token] -> TestSpec+mkTestSpec ts+  | length ts < 5 = error "mkTestSpec: list too short"+  | otherwise = TestSpec+      { testId = unToken . head $ ts+      , testOperation = unToken . head . drop 1 $ ts+      , testOperands = map unToken+          . takeWhile (not . resultsIn)+          . drop 2+          $ ts+      , testResult = unToken+          . safeHead+          . drop 1+          . dropWhile (not . resultsIn)+          . drop 2+          $ ts+      , testConditions = map unToken+          . drop 2+          . dropWhile (not . resultsIn)+          . drop 2+          $ ts+      }+  where+    resultsIn t = unToken t == "->" && not (quoted t)+    safeHead x = case x of+      [] -> error "mkTestSpec: list too short"+      y:_ -> y++rawToContent :: Raw -> IO [Either File Instruction]+rawToContent+  = mapM lineToContent+  . map removeComments+  . map processLine+  . splitLines++parseFile :: BS8.ByteString -> IO File+parseFile fn = do+  rw <- raw (BS8.unpack fn)+  ctnt <- rawToContent rw+  return $ File fn ctnt
+ dectest/Parse/Tokenizer.hs view
@@ -0,0 +1,220 @@+{-# LANGUAGE OverloadedStrings #-}+-- | A finite state machine to break a single line of text into+-- tokens.+--+-- The machine has three main states, some of which have sub-states:+--+-- * inside of a token. Here, the machine can be in a @plain@ (that+-- is, unquoted) word, or it can be inside of a quoted word.  When+-- inside of a quoted word, if a closing quotation mark is seen, the+-- machine transitions to being in a @pending@ state.  The next+-- character determines what happens next: if it's an identical+-- quotation mark, then a single quotation mark is added to the+-- current token, and the machine stays in a quoted word state.  If+-- the character is anything else, the machine outputs the previous+-- token and begins a new one.+--+-- * between tokens.+--+-- * in a comment.  Before a token is output, the tokenizer examines+-- it to determine whether it is both (1) unquoted, and (2) begins+-- with two dashes.  If so, it's a comment token.  The token is not+-- output, and the machine shifts to being in a comment state, which+-- swallows all remaining characters that are input.+--+-- To use the tokenizer:+--+-- * turn it on with 'start'.+--+-- * Feed it characters from the line using 'feed'.  Occasionally+-- this will output a single 'Token'.  It always outputs a new+-- 'Tokenizer' that will accept further characters.+--+-- * when done, be sure to turn it off with 'finish'.  This will+-- eject any characters in the tokenizer that have not been spit out+-- yet.++module Parse.Tokenizer+  ( Tokenizer+  , Token(..)+  , start           -- :: Tokenizer+  , feed            -- :: Char -> Tokenizer -> (Tokenizer, Maybe Token)+  , finish          -- :: Tokenizer -> Maybe Token+  ) where++import qualified Data.ByteString.Char8 as BS8++-- | Set to True when a single close quote character has been+-- parsed.  Since double quote characters indicates an enclosed+-- quote, we don't know until the next character whether to close+-- the quote or just include a quote in the token.+type Pending = Bool++data QuoteType = Single | Double+  deriving (Eq, Show)++toQuot :: QuoteType -> Char+toQuot Single = '\''+toQuot Double = '"'++data InTok+  = PlainWord+  | Quoted QuoteType Pending+  deriving Show++data Accepting+  = InTok InTok BS8.ByteString+  | BetweenToks+  deriving Show++-- The Tokenizer holds a Maybe Accepting, which is Nothing if the+-- Tokenizer is no longer accepting new characters because it is in+-- an comment, or is Just if accepting new characters.++data Tokenizer = Tokenizer (Maybe Accepting)+  deriving Show++data Token = Token+  { unToken :: BS8.ByteString+  , quoted :: Bool+  } deriving (Eq, Ord, Show)++-- | Turns the tokenizer on.++start :: Tokenizer+start = Tokenizer . Just $ BetweenToks++-- | Feeds a character to the tokenizer.+feed :: Char -> Tokenizer -> (Tokenizer, Maybe Token)+feed c (Tokenizer t) = case t of+  Nothing -> (Tokenizer Nothing, Nothing)++  Just a -> case a of+    InTok tokType curr -> case tokType of++      PlainWord ->+        let mnt q = mint (InTok (Quoted q False) BS8.empty)+                          curr False+        in case c of+            '"' -> mnt Double+            '\'' -> mnt Single+            ' ' -> mint BetweenToks curr False+            _ -> stayInTok c curr PlainWord++      Quoted qType pend+        | pend -> acceptQuotedWithPending c curr qType+        | otherwise -> acceptQuotedNoPending c curr qType++    BetweenToks -> case c of+      ' ' -> (Tokenizer (Just BetweenToks), Nothing)+      '"' -> newTok (Left Double)+      '\'' -> newTok (Left Single)+      _ -> newTok (Right c)++-- | Creates a new token, if called for.  Checks to see if the token+-- that would be produced would be a comment token.  If so, do not+-- emit a token, and return a Tokenizer that does not accept new+-- characters.  Otherwise, emit the token, and return an accepting+-- Tokenizer.++mint+  :: Accepting+  -- ^ If a token is produced because the Tokenizer did not output a+  -- comment, this becomes the new state of the Tokenizer.+  -> BS8.ByteString+  -- ^ What to output+  -> Bool+  -- ^ True if the token is quoted; False if not+  -> (Tokenizer, Maybe Token)+mint a o q+  | q = nt+  | otherwise =+      if BS8.take 2 o == "--"+      then (Tokenizer Nothing, Nothing)+      else nt+  where+    nt = (Tokenizer (Just a), Just (Token o q))++-- | Accepts a new character without producing a token.++stayInTok+  :: Char+  -- ^ Character to add to the storehouse of characters in the+  -- current token+  -> BS8.ByteString+  -- ^ Storehouse of current characters+  -> InTok+  -> (Tokenizer, Maybe Token)+  -- ^ snd is always False, fst is a Tokenizer that is InTok+stayInTok c s i = (tzr, Nothing)+  where+    tzr = Tokenizer (Just ac)+    ac = InTok i (s `BS8.snoc` c)++-- | Accepts a character while within a quote and there is not a+-- pending character.++acceptQuotedNoPending+  :: Char+  -- ^ Character to accept+  -> BS8.ByteString+  -- ^ Storehouse of current characters+  -> QuoteType+  -- ^ Type of quote we're currently inside of+  -> (Tokenizer, Maybe Token)+  -- ^ snd is always False, fst is a Tokenizer that is InTok+acceptQuotedNoPending c s q = (tzr, Nothing)+  where+    tzr = Tokenizer (Just ac)+    ac = InTok (Quoted q pnd) s'+    (s', pnd)+      | c == toQuot q = (s, True)+      | otherwise = (s `BS8.snoc` c, False)++-- | Accepts a character while within a quote and there is a pending+-- character.+acceptQuotedWithPending+  :: Char+  -- ^ Character to accept+  -> BS8.ByteString+  -- ^ Storehouse of current characters+  -> QuoteType+  -- ^ Type of quote we're currently inside of+  -> (Tokenizer, Maybe Token)+  -- ^ snd is always False, fst is a Tokenizer that is InTok+acceptQuotedWithPending c s q+  | c == toQuot q = stayInTok c s (Quoted q False)+  | otherwise = case c of+      ' ' -> mnt BetweenToks+      '"' -> mnt (InTok (Quoted Double False) BS8.empty)+      '\'' -> mnt (InTok (Quoted Single False) BS8.empty)+      _ -> mnt (InTok PlainWord (BS8.singleton c))+  where+    mnt a = mint a s True++-- | Starts a new token.+newTok+  :: Either QuoteType Char+  -- ^ If Left, start a new quoted token.  If Right, start a new+  -- plain token with the given character.+  -> (Tokenizer, Maybe Token)+  -- ^ snd is always False, fst if an accepting Tokenizer+newTok e = (Tokenizer (Just (InTok i s)), Nothing)+  where+    (i, s) = case e of+      Left q -> (Quoted q False, BS8.empty)+      Right c -> (PlainWord, BS8.singleton c)++-- | Finishes any remaining tokens in the machine.  Applies 'error'+-- if there is a quoted token in the machine that has not been+-- finished yet.+finish :: Tokenizer -> Maybe Token+finish (Tokenizer ma) = case ma of+  Nothing -> Nothing+  Just a -> case a of+    BetweenToks -> Nothing+    InTok i s -> case i of+      PlainWord -> Just (Token s False)+      Quoted _ pnd+        | pnd -> Just (Token s True)+        | otherwise -> error "finish: quoted token still in machine"
+ dectest/Parse/Tokens.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE OverloadedStrings #-}+module Parse.Tokens+  ( Raw(unRaw)+  , Line(..)+  , T.Token(..)+  , splitLines+  , processLine+  , raw+  ) where++import qualified Data.ByteString.Char8 as BS8+import qualified Parse.Tokenizer as T++-- | Raw file, parsed in from disk.+newtype Raw = Raw { unRaw :: BS8.ByteString }+  deriving Show++raw :: FilePath -> IO Raw+raw = fmap Raw . BS8.readFile++-- | A line from a Raw.  Does not contain any newlines.+newtype Line = Line { unLine :: BS8.ByteString }+  deriving Show++-- | Splits a Raw into a list of Line.  First, eliminates any+-- MS-DOS carriage returns (ASCII character 0d).  Then, uses the+-- ByteString lines function.+splitLines :: Raw -> [Line]+splitLines = map Line . BS8.lines . BS8.filter (/= '\r') . unRaw++--+-- Parsing a Line into Tokens+--++data HighLevelLine = HighLevelLine+  { llState :: T.Tokenizer+  , llToks :: [T.Token]+  } deriving Show++highLevelProc :: HighLevelLine -> Char -> HighLevelLine+highLevelProc h c = HighLevelLine l' ts'+  where+    (l', mayT) = T.feed c (llState h)+    ts' = case mayT of+      Nothing -> llToks h+      Just t' -> t' : llToks h++eject :: HighLevelLine -> [T.Token]+eject h = reverse toks+  where+    toks = case T.finish (llState h) of+      Nothing -> llToks h+      Just t -> t : llToks h++processLine :: Line -> [T.Token]+processLine+  = eject+  . BS8.foldl highLevelProc z+  . unLine+  where+    z = HighLevelLine T.start []++_testProcessLine :: String -> IO ()+_testProcessLine+  = mapM_ BS8.putStrLn+  . map T.unToken+  . processLine+  . Line+  . BS8.pack+
+ dectest/Result.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE OverloadedStrings #-}+module Result where++import TestLog+import qualified Data.ByteString.Char8 as BS8+import qualified Deka.Dec as D+import qualified Deka.Context as C+import Data.Monoid++-- | Parses a result token.  Returns Nothing if the result token was+-- a question mark, as this indicates that the result is undefined.+-- Bypasses if the token contains an octothorpe.  Otherwise, returns+-- the Dec.+--+-- Probably the easiest way to do the comparison is going to be to+-- take the output of the test function, apply @toByteString@ to it,+-- and then test that for equality with the result of applying+-- @toByteString@ to the result returned from here.++result+  :: BS8.ByteString+  -> TestLog (Maybe D.Dec)+result bs+  | '#' `BS8.elem` bs =+      bypass $ "result contains an octothorpe: " <> bs++  | '?' `BS8.elem` bs = do+      tell "result token contains a question mark"+      return Nothing++  | otherwise = do+      tell $ "parsing result token: " <> bs+      let r = C.runCtx (D.fromByteString bs)+      tell $ "result parse result: " <> D.toByteString r+      return . Just $ r++-- | Parses result token where the function is expecting an+-- Ordering.++resultOrd+  :: BS8.ByteString+  -> TestLog Ordering+resultOrd bs+  | '#' `BS8.elem` bs =+      bypass $ "result contains an octothorpe: " <> bs++  | '?' `BS8.elem` bs =+      flunk "result token contains a question mark"++  | otherwise = do+      tell $ "parsing result token: " <> bs+      case bs of+        "-1" -> return LT+        "0" -> return EQ+        "1" -> return GT+        _ -> flunk $ "unrecognized Ord result: " <> bs++resultBool+  :: BS8.ByteString+  -> TestLog Bool+resultBool bs+  | '#' `BS8.elem` bs =+      bypass $ "result contains an octothorpe: " <> bs++  | '?' `BS8.elem` bs =+      flunk "result token contains a question mark"++  | otherwise = do+      tell $ "parsing result token: " <> bs+      case bs of+        "1" -> return True+        "0" -> return False+        _ -> flunk $ "unrecognized Bool result: " <> bs+
+ dectest/Runner.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE OverloadedStrings, BangPatterns #-}+module Runner (runAndExit) where++import qualified Parse as P+import qualified Data.ByteString.Char8 as BS8+import Data.Monoid+import Data.List (intersperse)+import System.Exit+import Data.Foldable (toList)+import qualified Data.Sequence as S+import Data.Sequence ((|>))+import Pipes+import Pipes.Prelude (fold)+import NumTests (testLookups)+import Types++produceFile :: MonadIO m => Pipe BS8.ByteString P.File m ()+produceFile = do+  bs <- await+  f <- liftIO $ P.parseFile bs+  yield f++order :: Monad m => Pipe P.File Order m ()+order = do+  f <- await+  go S.empty (P.fileContents f)+  where+    go !sq ls = case ls of+      [] -> return ()+      x:xs -> case x of+        Left inner -> go S.empty (P.fileContents inner)+        Right i -> case i of+          P.Blank -> go sq xs+          P.Directive k v ->+            let sq' = sq |> (k, v)+            in go sq' xs+          P.Test spec -> do+            yield (Order sq spec)+            go sq xs++output :: Monad m => Pipe Order TestOutput m ()+output = do+  o <- await+  case lookup (P.testOperation . ordSpec $ o) testLookups of+    Nothing -> yield (noOperation . ordSpec $ o)+    Just t -> yield (runTest o t)+  output+++printTest+  :: MonadIO m+  => Pipe TestOutput (Maybe Bool) m ()+printTest = do+  o <- await+  liftIO . BS8.putStr . showResult $ o+  yield (outResult o)+  printTest++pipeline :: MonadIO m => Pipe BS8.ByteString (Maybe Bool) m ()+pipeline =+  produceFile+  >-> order+  >-> output+  >-> printTest++totals :: Monad m => Producer (Maybe Bool) m () -> m Counts+totals = fold tally mempty id++runAndExit :: [String] -> IO ()+runAndExit ss = do+  let bs = map BS8.pack ss+      pip = each bs >-> pipeline+  tot <- totals pip+  putStr . showCounts $ tot+  exit tot++noOperation :: P.TestSpec -> TestOutput+noOperation ts = TestOutput+  { outSpec = ts+  , outResult = Nothing+  , outLog = S.singleton "no matching operation; skipping"+  }++data Order = Order+  { _ordDirectives :: S.Seq (P.Keyword, P.Value)+  , ordSpec :: P.TestSpec+  }++runTest+  :: Order+  -> Test+  -> TestOutput+runTest (Order ds ts) t = TestOutput+  { outSpec = ts+  , outResult = r+  , outLog = l+  }+  where+    (r, l) = t ds (P.testOperands ts) (P.testResult ts)+      (P.testConditions ts)++data TestOutput = TestOutput+  { outSpec :: P.TestSpec+  , outResult :: Maybe Bool+  , outLog :: S.Seq BS8.ByteString+  }++data Counts = Counts+  { _nPass :: !Int+  , nFail :: !Int+  , _nSkip :: !Int+  } deriving Show++tally :: Counts -> Maybe Bool -> Counts+tally (Counts p f s) mb = case mb of+  Nothing -> Counts p f (s + 1)+  Just True -> Counts (p + 1) f s+  Just False -> Counts p (f + 1) s++instance Monoid Counts where+  mempty = Counts 0 0 0+  (Counts x1 y1 z1) `mappend` (Counts x2 y2 z2) =+    Counts (x1 + x2) (y1 + y2) (z1 + z2)++showCounts :: Counts -> String+showCounts (Counts p f s) = unlines+  [ "pass: " ++ show p+  , "fail: " ++ show f+  , "skip: " ++ show s+  , "total: " ++ show (p + f + s)+  ]++exit :: Counts -> IO ()+exit c+  | nFail c > 0 = exitFailure+  | otherwise = exitSuccess++showResult+  :: TestOutput+  -> BS8.ByteString+showResult (TestOutput t r sq) = BS8.unlines $ l1:lr+  where+    l1 = pf <+> showSpec t+    pf = case r of+      Nothing -> "[skip]"+      Just True -> "[pass]"+      Just False -> "[FAIL]"+    lr = map ("    " <>) . toList $ sq++showSpec :: P.TestSpec -> BS8.ByteString+showSpec t =+  P.testId t+  <+> P.testOperation t+  <+> BS8.concat (intersperse " " . P.testOperands $ t)+  <+> "->"+  <+> P.testResult t+  <+> BS8.concat (intersperse " " . P.testConditions $ t)++(<+>) :: BS8.ByteString -> BS8.ByteString -> BS8.ByteString+l <+> r+  | BS8.null l && BS8.null r = ""+  | BS8.null l || BS8.null r = l <> r+  | otherwise = l <> " " <> r+
+ dectest/Specials.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Handling special cases: toSci, toEng, apply, class.++module Specials where++import qualified Data.ByteString.Char8 as BS8+import TestLog+import qualified Deka.Context as C+import qualified Deka.Dec as D+import Types+import Operand+import Directives+import TestHelpers+import Data.Monoid+import Result+import Data.Char (toLower)+import Control.Arrow (first)++toSciOrEng :: (D.Dec -> BS8.ByteString) -> Test+toSciOrEng fn dirs opS rsS cdS = runTestLog $ do+  ic <- parseDirectives dirs+  getOp <- case opS of+    x:[] -> operandSciEngAp ic x+    _ -> flunk $ "expected 1 operand, got " <>+      (BS8.pack . show . length $ opS)+  let (rConv, fl) = C.runCtxStatus getOp+      r = fn rConv+  testConditions cdS fl+  if r == rsS+    then pass $ "string " <> r <> " matches expected result"+    else flunk $ "string " <> r <> " does not match expected "+            <> "result of " <> rsS++toSci :: Test+toSci = toSciOrEng D.toByteString++toEng :: Test+toEng = toSciOrEng D.toEngByteString++apply :: Test+apply dirs opS rsS cdS = runTestLog $ do+  ic <- parseDirectives dirs+  getOp <- case opS of+    x:[] -> operandSciEngAp ic x+    _ -> flunk $ "expected 1 operand, got " <>+      (BS8.pack . show . length $ opS)+  let k = getOp >>= D.plus+      (rConv, fl) = C.runCtxStatus k+      r = D.toByteString rConv+  tgt <- result rsS+  testConditions cdS fl+  case tgt of+    Nothing -> flunk $ "target result of apply is undefined; "+      <> "this makes no sense"+    Just t+      | D.toByteString t == r -> pass "result is as expected"+      | otherwise -> flunk $ "result of " <> r+          <> " does not match expected result of "+          <> D.toByteString t++parseClass :: BS8.ByteString -> TestLog D.Class+parseClass bs = case lookup lwr ls of+  Nothing -> flunk $ "could not parse class: " <> bs+  Just r -> do+    tell $ "parsed class: " <> bs+    return r+  where+    lwr = map toLower . BS8.unpack $ bs+    ls = map (first (map toLower)) D.strToClass++decClass :: Test+decClass dirs opS rsS cdS = runTestLog $ do+  ic <- parseDirectives dirs+  op <- case opS of+    x:[] -> operand ic x+    _ -> flunk $ "expected 1 operand, got " <>+      (BS8.pack . show . length $ opS)+  tgt <- parseClass rsS+  let k = ic >> D.numClass op+      (r, fl) = C.runCtxStatus k+  testConditions cdS fl+  if r == tgt+    then pass "result is as expected"+    else flunk $ "unexpected class: result is " <>+            (BS8.pack . show $ r)
+ dectest/TestHelpers.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE OverloadedStrings #-}+module TestHelpers where++import TestLog+import qualified Data.ByteString.Char8 as BS8+import qualified Deka.Dec as D+import qualified Deka.Context as C+import Data.Monoid+import Conditions+import Data.List (sort)++testConditions+  :: [BS8.ByteString]+  -- ^ List of conditions+  -> C.Flags+  -- ^ Actual conditions from test+  -> TestLog ()+testConditions bs flgs = do+  cs <- parseConditions bs+  let fs = sort . C.unpackFlags $ flgs+  if sort fs == sort cs+    then tell "conditions are as expected"+    else flunk $ "conditions not as expected: " <>+          (BS8.pack . show $ fs)++testDec :: D.Dec -> Maybe D.Dec -> TestLog ()+testDec x y = case y of+  Nothing -> tell "target result is undefined" >> return ()+  Just r ->+    let sx = D.toByteString x+        sr = D.toByteString r+        res | sx == sr = tell "result is as expected"+            | otherwise =+                flunk $ "output: " <> sx <> " expected result: " <> sr+    in res
+ dectest/TestLog.hs view
@@ -0,0 +1,64 @@+module TestLog+  ( TestLog+  , tell+  , bypass+  , flunk+  , Done+  , pass+  , runTestLog+  ) where++import qualified Data.Sequence as S+import Control.Applicative+import Control.Monad+import qualified Data.ByteString.Char8 as BS8+import Data.Monoid++data State a+  = Good a+  | Failed+  | Bypass+  deriving Show++newtype TestLog a = TestLog+  { unTestLog :: (S.Seq BS8.ByteString, State a) }+  deriving Show++instance Monad TestLog where+  return a = TestLog (S.empty, Good a)+  (TestLog (ss, st)) >>= f = TestLog $ case st of+    Failed -> (ss, Failed)+    Bypass -> (ss, Bypass)+    Good a -> let (ss', st') = unTestLog $ f a in+      (ss <> ss', st')++instance Applicative TestLog where+  pure = return+  (<*>) = ap++instance Functor TestLog where+  fmap = liftM++tell :: BS8.ByteString -> TestLog ()+tell bs = TestLog (S.singleton bs, Good ())++bypass :: BS8.ByteString -> TestLog a+bypass bs = TestLog (S.singleton bs, Bypass)++flunk :: BS8.ByteString -> TestLog a+flunk bs = TestLog (S.singleton bs, Failed)++data Done = Done+  deriving Show++pass :: BS8.ByteString -> TestLog Done+pass bs = TestLog (S.singleton bs, Good Done)++runTestLog :: TestLog Done -> (Maybe Bool, S.Seq BS8.ByteString)+runTestLog (TestLog (ss, st)) = (r, ss)+  where+    r = case st of+      Good Done -> Just True+      Failed -> Just False+      Bypass -> Nothing+
+ dectest/Types.hs view
@@ -0,0 +1,36 @@+module Types where++import qualified Data.ByteString.Char8 as BS8+import qualified Parse as P+import Data.Sequence++-- | All tests must conform to this interface.++type Test++  = Seq (P.Keyword, P.Value)+  -- ^ All directives in force when the test is run.  Oldest+  -- directives are on the left side of the Seq; newest ones, on+  -- the right side.++  -> [BS8.ByteString]+  -- ^ Operands++  -> BS8.ByteString+  -- ^ Result++  -> [BS8.ByteString]+  -- ^ Conditions.  These are already sorted.++  -> (Maybe Bool, Seq BS8.ByteString)+  -- ^ The test returns a Maybe Bool to indicate the test result.+  -- Passage is Just True, failure is Just False, skip is Nothing.+  -- Use Nothing for inputs that the implementation does not+  -- support, such as null operands.  For all other failures+  -- (including programmer errors or test configuration errors such+  -- as mismatches in the number of operands), use Just False.+  --+  -- Also returned is a list of ByteString.  These are narratives.+  -- Put one pice of data in each line.  For example  you might+  -- include information on how the operands parsed, how the result+  -- parsed, what information the test function returned, etc.
+ dectest/Util.hs view
@@ -0,0 +1,28 @@+module Util where++import qualified Data.ByteString.Char8 as BS8++switch :: a -> [(Bool, a)] -> a+switch dflt [] = dflt+switch dflt ((bl, a):xs)+  | bl = a+  | otherwise = switch dflt xs++parseBool :: Int -> Maybe Bool+parseBool i+  | i == 0 = Just False+  | i == 1 = Just True+  | otherwise = Nothing++safeRead :: Read a => String -> Maybe a+safeRead a = case reads a of+  (x, ""):[] -> Just x+  _ -> Nothing++readNumber :: Read a => String -> Maybe a+readNumber a = case a of+  [] -> Nothing+  x:xs -> if x == '+' then safeRead xs else safeRead (x:xs)++readNumberBS :: Read a => BS8.ByteString -> Maybe a+readNumberBS bs = readNumber (BS8.unpack bs)
+ dectest/deka-dectest.hs view
@@ -0,0 +1,7 @@+module Main where++import Runner+import System.Environment++main :: IO ()+main = getArgs >>= runAndExit
+ deka-tests.cabal view
@@ -0,0 +1,135 @@+-- This Cabal file generated using the Cartel library.+-- Cartel is available at:+-- http://www.github.com/massysett/cartel+--+-- Script name used to generate: genCabal.hs+-- Generated on: 2014-07-16 09:29:20.116107 EDT+-- Cartel library version: 0.10.0.2+name: deka-tests+version: 0.6.0.2+cabal-version: >= 1.14+build-type: Simple+license: BSD3+license-file: LICENSE+copyright: Copyright 2014 Omari Norman+author: Omari Norman+maintainer: Omari Norman, omari@smileystation.com+stability: Experimental+homepage: https://github.com/massysett/deka+bug-reports: https://github.com/massysett/deka/issues+synopsis: Tests for deka, decimal floating point arithmetic+description:+  deka provides decimal floating point arithmetic.  It is based on+  mpdecimal, the C library used to provide support for the Decimal+  module in Python 3.+  .+  You will need to install mpdecimal to use deka; otherwise your+  executables will not link.  It is available at+  .+   <http://www.bytereef.org/mpdecimal/>+  .+  mpdecimal has also been packaged for some Linux distributions,+  such as Debian (libmpdec-dev - available in Jessie and later) and+  Arch (mpdecimal).+  .+  mpdecimal, in turn, implements the General Decimal Arithmetic+  Specification, which is available at+  .+  <http://speleotrove.com/decimal/>+  .+  For more on deka, please see the Github home page at+  .+  <https://github.com/massysett/deka>+  .+  This package contains only tests, so that other packages+  may also use the tests.+category: Math+tested-with: GHC == 7.4.1, GHC == 7.6.3, GHC == 7.8.3+extra-source-files:+    README.md+  , ChangeLog+  , current-versions.txt+  , minimum-versions.txt++source-repository head+  type: git+  location: https://github.com/massysett/deka.git++Library+  exposed-modules:+      Deka.Dec.Coarbitrary+    , Deka.Dec.Generators+    , Deka.Dec.Shrinkers+    , Deka.Native.Abstract.Coarbitrary+    , Deka.Native.Abstract.Generators+    , Deka.Native.Abstract.Shrinkers+    , Deka.Tests.Util+  hs-source-dirs:+      lib+  build-depends:+      base ((> 4.5.0.0 || == 4.5.0.0) && < 4.8)+    , bytestring ((> 0.9.2.1 || == 0.9.2.1) && < 0.11)+    , deka == 0.6.0.2+    , QuickCheck ((> 2.7.3 || == 2.7.3) && < 2.8)+  ghc-options:+      -Wall+  default-language: Haskell2010++Executable deka-dectest+  build-depends:+      base ((> 4.5.0.0 || == 4.5.0.0) && < 4.8)+    , bytestring ((> 0.9.2.1 || == 0.9.2.1) && < 0.11)+    , deka == 0.6.0.2+    , QuickCheck ((> 2.7.3 || == 2.7.3) && < 2.8)+    , transformers ((> 0.3.0.0 || == 0.3.0.0) && < 0.5)+    , parsec ((> 3.1.2 || == 3.1.2) && < 3.2)+    , containers ((> 0.4.2.1 || == 0.4.2.1) && < 0.6)+    , pipes ((> 4.1.1 || == 4.1.1) && < 4.2)+  hs-source-dirs:+      dectest+  other-modules:+      Arity+    , Conditions+    , Directives+    , NumTests+    , Operand+    , Parse+    , Parse.Tokenizer+    , Parse.Tokens+    , Result+    , Runner+    , Specials+    , TestHelpers+    , TestLog+    , Types+    , Util+  main-is: deka-dectest.hs+  default-language: Haskell2010+  ghc-options:+      -Wall++Test-Suite deka-native+  build-depends:+      base ((> 4.5.0.0 || == 4.5.0.0) && < 4.8)+    , bytestring ((> 0.9.2.1 || == 0.9.2.1) && < 0.11)+    , deka == 0.6.0.2+    , QuickCheck ((> 2.7.3 || == 2.7.3) && < 2.8)+    , quickpull ((> 0.2.0.0 || == 0.2.0.0) && < 0.3)+  type: exitcode-stdio-1.0+  main-is: deka-native.hs+  hs-source-dirs:+      native+    , lib+  other-modules:+      Deka.Dec.Coarbitrary+    , Deka.Dec.Generators+    , Deka.Dec.Shrinkers+    , Deka.Native.Abstract.Coarbitrary+    , Deka.Native.Abstract.Generators+    , Deka.Native.Abstract.Shrinkers+    , Deka.Tests.Util+    , Decrees+    , Properties+  default-language: Haskell2010+  ghc-options:+      -Wall
+ lib/Deka/Dec/Coarbitrary.hs view
@@ -0,0 +1,15 @@+module Deka.Dec.Coarbitrary where++import qualified Deka.Dec as D+import Test.QuickCheck+import Deka.Tests.Util++posNeg :: D.PosNeg -> Gen a -> Gen a+posNeg a = case a of+  D.Pos -> varInt 0+  D.Neg -> varInt 1++sign :: D.Sign -> Gen a -> Gen a+sign a = case a of+  D.Sign0 -> varInt 0+  D.Sign1 -> varInt 1
+ lib/Deka/Dec/Generators.hs view
@@ -0,0 +1,10 @@+module Deka.Dec.Generators where++import Test.QuickCheck+import qualified Deka.Dec as D++posNeg :: Gen D.PosNeg+posNeg = elements [ D.Pos, D.Neg ]++sign :: Gen D.Sign+sign = elements [ D.Sign0, D.Sign1 ]
+ lib/Deka/Dec/Shrinkers.hs view
@@ -0,0 +1,13 @@+module Deka.Dec.Shrinkers where++import qualified Deka.Dec as D++posNeg :: D.PosNeg -> [D.PosNeg]+posNeg x = case x of+  D.Neg -> [D.Pos]+  _ -> []++sign :: D.Sign -> [D.Sign]+sign x = case x of+  D.Sign1 -> [D.Sign0]+  _ -> []
+ lib/Deka/Native/Abstract/Coarbitrary.hs view
@@ -0,0 +1,72 @@+module Deka.Native.Abstract.Coarbitrary where++import qualified Deka.Native.Abstract as D+import Test.QuickCheck+import Deka.Tests.Util+import Deka.Dec.Coarbitrary+import Prelude hiding (exponent)++novem :: D.Novem -> Gen a -> Gen a+novem d = case d of+  D.D1 -> v 0+  D.D2 -> v 1+  D.D3 -> v 2+  D.D4 -> v 3+  D.D5 -> v 4+  D.D6 -> v 5+  D.D7 -> v 6+  D.D8 -> v 7+  D.D9 -> v 8+  where+    v = varInt++decem :: D.Decem -> Gen a -> Gen a+decem d = case d of+  D.D0 -> varInt 0+  D.Nonem n -> varInt 1 . novem n++decuple :: D.Decuple -> Gen a -> Gen a+decuple (D.Decuple n ds) = novem n . coarbitraryList decem ds++aut :: D.Aut -> Gen a -> Gen a+aut a = case a of+  D.Nil -> varInt 0+  D.Plenus d -> varInt 1 . decuple d++firmado :: D.Firmado -> Gen a -> Gen a+firmado a = case a of+  D.Cero -> varInt 0+  D.Completo p d -> varInt 1 . posNeg p . decuple d++coefficient :: D.Coefficient -> Gen a -> Gen a+coefficient (D.Coefficient c) = aut c++exponent :: D.Exponent -> Gen a -> Gen a+exponent (D.Exponent c) = firmado c++diagnostic :: D.Diagnostic -> Gen a -> Gen a+diagnostic (D.Diagnostic d) = decuple d++noisy :: D.Noisy -> Gen a -> Gen a+noisy d = case d of+  D.Quiet -> varInt 0+  D.Signaling -> varInt 1++nonNum :: D.NonNum -> Gen a -> Gen a+nonNum (D.NonNum n d) = noisy n . varD d+  where+    varD x = case x of+      Nothing -> varInt 0+      Just j -> varInt 1 . diagnostic j++value :: D.Value -> Gen a -> Gen a+value v = case v of+  D.Finite c e -> varInt 0 . coefficient c . exponent e+  D.Infinite -> varInt 1+  D.NotANumber n -> varInt 2 . nonNum n++abstract :: D.Abstract -> Gen a -> Gen a+abstract (D.Abstract s v) = sign s . value v++adjustedExp :: D.AdjustedExp -> Gen a -> Gen a+adjustedExp (D.AdjustedExp i) = variant i
+ lib/Deka/Native/Abstract/Generators.hs view
@@ -0,0 +1,53 @@+module Deka.Native.Abstract.Generators where++import Test.QuickCheck+import Deka.Dec.Generators+import qualified Deka.Native.Abstract as A+import Control.Monad+import Prelude hiding (exponent)++novem :: Gen A.Novem+novem = elements+  [ A.D1, A.D2, A.D3, A.D4, A.D5, A.D6, A.D7, A.D8, A.D9 ]++decem :: Gen A.Decem+decem = frequency [(1, return A.D0), (5, fmap A.Nonem novem)]++decuple :: Gen A.Decuple+decuple = liftM2 A.Decuple novem (listOf decem)++aut :: Gen A.Aut+aut = frequency [(1, return A.Nil), (5, fmap A.Plenus decuple)]++firmado :: Gen A.Firmado+firmado = frequency [ (1, return A.Cero),+                      (5, liftM2 A.Completo posNeg decuple) ]++coefficient :: Gen A.Coefficient+coefficient = fmap A.Coefficient aut++exponent :: Gen A.Exponent+exponent = fmap A.Exponent firmado++diagnostic :: Gen A.Diagnostic+diagnostic = fmap A.Diagnostic decuple++noisy :: Gen A.Noisy+noisy = elements [ A.Quiet, A.Signaling ]++nonNum :: Gen A.NonNum+nonNum = liftM2 A.NonNum noisy+  (frequency [(1, return Nothing), (5, fmap Just diagnostic)])++value :: Gen A.Value+value = frequency+  [ (4, liftM2 A.Finite coefficient exponent)+  , (1, return A.Infinite)+  , (1, fmap A.NotANumber nonNum)+  ]++abstract :: Gen A.Abstract+abstract = liftM2 A.Abstract sign value++adjustedExp :: Gen A.AdjustedExp+adjustedExp = fmap A.AdjustedExp arbitrarySizedIntegral
+ lib/Deka/Native/Abstract/Shrinkers.hs view
@@ -0,0 +1,75 @@+module Deka.Native.Abstract.Shrinkers where++import Deka.Dec.Shrinkers+import qualified Deka.Native.Abstract as D+import Test.QuickCheck+import Prelude hiding (exponent)++novem :: D.Novem -> [D.Novem]+novem d = case d of+  D.D1 -> []+  D.D2 -> [D.D1]+  D.D3 -> [D.D1 .. D.D2]+  D.D4 -> [D.D1 .. D.D3]+  D.D5 -> [D.D1 .. D.D4]+  D.D6 -> [D.D1 .. D.D5]+  D.D7 -> [D.D1 .. D.D6]+  D.D8 -> [D.D1 .. D.D7]+  D.D9 -> [D.D1 .. D.D8]++decem :: D.Decem -> [D.Decem]+decem d = case d of+  D.D0 -> []+  D.Nonem nv -> D.D0 : map D.Nonem (novem nv)++decuple :: D.Decuple -> [D.Decuple]+decuple (D.Decuple n d) =+  [ D.Decuple n' d' | n' <- novem n,+                      d' <- shrinkList decem d ]++aut :: D.Aut -> [D.Aut]+aut a = case a of+  D.Nil -> []+  D.Plenus d -> D.Nil : map D.Plenus (decuple d)++firmado :: D.Firmado -> [D.Firmado]+firmado a = case a of+  D.Cero -> []+  D.Completo p d ->+    [ D.Completo p' d' | p' <- posNeg p, d' <- decuple d ]++coefficient :: D.Coefficient -> [D.Coefficient]+coefficient = map D.Coefficient . aut . D.unCoefficient++exponent :: D.Exponent -> [D.Exponent]+exponent = map D.Exponent . firmado . D.unExponent++diagnostic :: D.Diagnostic -> [D.Diagnostic]+diagnostic = map D.Diagnostic . decuple . D.unDiagnostic++noisy :: D.Noisy -> [D.Noisy]+noisy a = case a of+  D.Quiet -> []+  D.Signaling -> [D.Quiet]++nonNum :: D.NonNum -> [D.NonNum]+nonNum (D.NonNum n d) = [ D.NonNum n' d'+  | n' <- noisy n, d' <- shrinkMaybe d ]+  where+    shrinkMaybe m = case m of+      Nothing -> []+      Just x -> Nothing : map Just (diagnostic x)++value :: D.Value -> [D.Value]+value a = case a of+  D.Finite c e -> [ D.Finite c' e' | c' <- coefficient c,+                                     e' <- exponent e ]+  D.Infinite -> []+  D.NotANumber n -> [ D.NotANumber n' | n' <- nonNum n ]++abstract :: D.Abstract -> [D.Abstract]+abstract (D.Abstract s v) =+  [ D.Abstract s' v' | s' <- sign s, v' <- value v ]++adjustedExp :: D.AdjustedExp -> [D.AdjustedExp]+adjustedExp (D.AdjustedExp i) = map D.AdjustedExp $ shrinkIntegral i
+ lib/Deka/Tests/Util.hs view
@@ -0,0 +1,11 @@+module Deka.Tests.Util where++import Test.QuickCheck++varInt :: Int -> Gen b -> Gen b+varInt = variant++coarbitraryList :: (a -> Gen b -> Gen b) -> [a] -> Gen b -> Gen b+coarbitraryList f ls = case ls of+  [] -> varInt 0+  x:xs -> varInt 1 . f x . coarbitraryList f xs
+ minimum-versions.txt view
@@ -0,0 +1,50 @@+This package was tested to work with these dependency+versions and compiler version.+These are the minimum versions given in the .cabal file.+Tested as of: 2014-07-16 13:56:43.863793 UTC+Path to compiler: ghc-7.4.1+Compiler description: 7.4.1++/opt/ghc/7.4.1/lib/ghc-7.4.1/package.conf.d:+    Cabal-1.14.0+    array-0.4.0.0+    base-4.5.0.0+    bin-package-db-0.0.0.0+    binary-0.5.1.0+    bytestring-0.9.2.1+    containers-0.4.2.1+    deepseq-1.3.0.0+    directory-1.1.0.2+    extensible-exceptions-0.1.1.4+    filepath-1.3.0.0+    (ghc-7.4.1)+    ghc-prim-0.2.0.0+    (haskell2010-1.1.0.1)+    (haskell98-2.0.0.1)+    hoopl-3.8.7.3+    hpc-0.5.1.1+    integer-gmp-0.4.0.0+    old-locale-1.0.0.4+    old-time-1.1.0.0+    pretty-1.1.1.0+    process-1.1.0.1+    rts-1.0+    template-haskell-2.7.0.0+    time-1.4+    unix-2.5.1.0++/home/massysett/deka/tests/sunlight-19453/db:+    QuickCheck-2.7.3+    deka-0.6.0.2+    deka-tests-0.6.0.2+    mmorph-1.0.3+    mtl-2.1.3.1+    parsec-3.1.2+    pipes-4.1.1+    primitive-0.5.3.0+    quickpull-0.2.0.0+    random-1.0.1.1+    text-0.11.3.1+    tf-random-0.5+    transformers-0.3.0.0+
+ native/Decrees.hs view
@@ -0,0 +1,15 @@+-- | This module generated by the Quickpull package.+-- Quickpull is available at:+-- <http://www.github.com/massysett/quickpull>++module Decrees where++import Quickpull+import qualified Properties++decrees :: [Decree]+decrees =++  [ Decree ( Meta {modDesc = ModDesc {modPath = "native/Properties.hs", modName = ["Properties"]}, linenum = 9, qName = "prop_abstractToStringToAbstract"} ) ( Single Properties.prop_abstractToStringToAbstract )+  , Decree ( Meta {modDesc = ModDesc {modPath = "native/Properties.hs", modName = ["Properties"]}, linenum = 15, qName = "prop_decToAbstractToDec"} ) ( Single Properties.prop_decToAbstractToDec )+  ]
+ native/Properties.hs view
@@ -0,0 +1,21 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module Properties where++import qualified Deka.Native.Abstract.Generators as G+import qualified Deka.Native as N+import Test.QuickCheck+import qualified Deka.Dec as D++prop_abstractToStringToAbstract =+  forAll G.abstract $ \a ->+  case N.stringToAbstract . N.abstractToString $ a of+    Left _ -> property False+    Right a' -> a === a'++prop_decToAbstractToDec =+  forAll G.abstract $ \a ->+  let (d, flgs) = N.abstractToDec a+      a' = N.decToAbstract d+      (d'', flgs') = N.abstractToDec a'+  in flgs == D.emptyFlags && flgs' == D.emptyFlags+     ==> D.compareTotal d d'' == EQ
+ native/deka-native.hs view
@@ -0,0 +1,7 @@+module Main where++import Decrees+import Quickpull++main :: IO ()+main = defaultMain decrees