deka 0.6.0.0 → 0.6.0.2
raw patch · 54 files changed
+3530/−4978 lines, 54 filesdep −QuickCheckdep −containersdep −dekadep ~basedep ~bytestringdep ~parsecPVP ok
version bump matches the API change (PVP)
Dependencies removed: QuickCheck, containers, deka, pipes, tasty, tasty-quickcheck
Dependency ranges changed: base, bytestring, parsec, transformers
API changes (from Hackage documentation)
Files
- ChangeLog +6/−0
- current-versions.txt +12/−26
- dectest/AllModules.hs +0/−22
- dectest/Arity.hs +0/−131
- dectest/Conditions.hs +0/−50
- dectest/Directives.hs +0/−142
- dectest/NumTests.hs +0/−61
- dectest/Operand.hs +0/−67
- dectest/Parse.hs +0/−99
- dectest/Parse/Tokenizer.hs +0/−220
- dectest/Parse/Tokens.hs +0/−70
- dectest/Result.hs +0/−74
- dectest/Runner.hs +0/−164
- dectest/Specials.hs +0/−85
- dectest/TestHelpers.hs +0/−35
- dectest/TestLog.hs +0/−64
- dectest/Types.hs +0/−36
- dectest/Util.hs +0/−28
- dectest/dectest.hs +0/−7
- deka.cabal +49/−88
- exposed/Deka.hs +173/−0
- exposed/Deka/Abstract.hs +61/−0
- exposed/Deka/Context.hs +112/−0
- exposed/Deka/Dec.hs +123/−0
- exposed/Deka/Docs.hs +24/−0
- exposed/Deka/Docs/Examples.lhs +268/−0
- exposed/Deka/Native.hs +88/−0
- exposed/Deka/Native/Abstract.hs +330/−0
- exposed/Deka/Native/FromString.hs +227/−0
- internal/Deka/Internal/Context.hs +637/−0
- internal/Deka/Internal/Dec/Ctx.hs +364/−0
- internal/Deka/Internal/Dec/CtxFree.hs +148/−0
- internal/Deka/Internal/Mpdec.hsc +838/−0
- internal/Deka/Internal/Unsafe.hs +19/−0
- internal/Deka/Internal/Util/Ctx.hs +48/−0
- lib/Deka.hs +0/−173
- lib/Deka/Context.hs +0/−112
- lib/Deka/Dec.hs +0/−123
- lib/Deka/Docs.hs +0/−24
- lib/Deka/Docs/Examples.lhs +0/−268
- lib/Deka/Internal/Context.hs +0/−637
- lib/Deka/Internal/Dec/Ctx.hs +0/−364
- lib/Deka/Internal/Dec/CtxFree.hs +0/−141
- lib/Deka/Internal/Mpdec.hsc +0/−838
- lib/Deka/Internal/Unsafe.hs +0/−19
- lib/Deka/Internal/Util/Ctx.hs +0/−48
- lib/Deka/Native.hs +0/−88
- lib/Deka/Native/Abstract.hs +0/−330
- lib/Deka/Native/FromString.hs +0/−227
- minimum-versions.txt +3/−20
- native/AllModules.hs +0/−5
- native/Generators.hs +0/−58
- native/Properties.hs +0/−25
- native/native.hs +0/−9
ChangeLog view
@@ -1,3 +1,9 @@+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
current-versions.txt view
@@ -1,14 +1,14 @@ 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-05-20 16:07:05.864819 UTC-Path to compiler: ghc-7.8.2-Compiler description: 7.8.2+Tested as of: 2014-07-16 11:45:23.903792 UTC+Path to compiler: ghc-7.8.3+Compiler description: 7.8.3 -/opt/ghc/7.8.2/lib/ghc-7.8.2/package.conf.d:+/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.0+ base-4.7.0.1 bin-package-db-0.0.0.0 binary-0.7.1.0 rts-1.0@@ -17,8 +17,9 @@ deepseq-1.3.0.2 directory-1.2.1.0 filepath-1.3.0.2- (ghc-7.8.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@@ -29,30 +30,15 @@ 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/sunlight-730/db:- QuickCheck-2.7.3- ansi-terminal-0.6.1.1- ansi-wl-pprint-0.6.7.1- async-2.0.1.5- deka-0.6.0.0- mmorph-1.0.3+/home/massysett/deka/library/sunlight-20573/db:+ deka-0.6.0.2 mtl-2.1.3.1- optparse-applicative-0.8.1 parsec-3.1.5- pipes-4.1.2- primitive-0.5.3.0- random-1.0.1.1- regex-base-0.93.2- regex-tdfa-1.2.0- stm-2.4.3- tagged-0.7.2- tasty-0.8.0.4- tasty-quickcheck-0.8.1- text-1.1.1.2- tf-random-0.5- unbounded-delays-0.1.0.7+ text-1.1.1.3
− dectest/AllModules.hs
@@ -1,22 +0,0 @@-{-# OPTIONS_GHC -fno-warn-unused-imports #-}---- | Lists all modules in the tests directory. A hack to make it--- easy to compile all test modules. By importing this file in the--- main immutability.hs, all modules get compiled.-module AllModules where--import Conditions-import Parse-import Parse.Tokenizer-import Parse.Tokens-import Types-import Runner-import Directives-import TestLog-import Util-import Operand-import Result-import Arity-import TestHelpers-import Specials-import NumTests
− dectest/Arity.hs
@@ -1,131 +0,0 @@-{-# 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
@@ -1,50 +0,0 @@-{-# 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
@@ -1,142 +0,0 @@-{-# 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
@@ -1,61 +0,0 @@-{-# 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
@@ -1,67 +0,0 @@-{-# 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
@@ -1,99 +0,0 @@-{-# 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
@@ -1,220 +0,0 @@-{-# 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
@@ -1,70 +0,0 @@-{-# 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
@@ -1,74 +0,0 @@-{-# 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
@@ -1,164 +0,0 @@-{-# 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
@@ -1,85 +0,0 @@-{-# 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
@@ -1,35 +0,0 @@-{-# 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
@@ -1,64 +0,0 @@-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
@@ -1,36 +0,0 @@-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
@@ -1,28 +0,0 @@-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/dectest.hs
@@ -1,7 +0,0 @@-module Main where--import Runner-import System.Environment--main :: IO ()-main = getArgs >>= runAndExit
deka.cabal view
@@ -1,9 +1,24 @@-name: deka-version: 0.6.0.0-synopsis: Decimal floating point arithmetic-+-- 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:12:04.298707 EDT+-- Cartel library version: 0.10.0.2+name: deka+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: 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.@@ -11,7 +26,7 @@ You will need to install mpdecimal to use deka; otherwise your executables will not link. It is available at .- <http://www.bytereef.org/mpdecimal/>+ <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@@ -25,25 +40,24 @@ For more on deka, please see the Github home page at . <https://github.com/massysett/deka>+ .+ Tests are packaged separately in the deka-tests package.+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 -homepage: http://www.github.com/massysett/deka-license: BSD3-license-file: LICENSE-author: Omari Norman-maintainer: omari@smileystation.com-copyright: 2014 Omari Norman-category: Math-build-type: Simple-extra-source-files: README.md ChangeLog- current-versions.txt minimum-versions.txt-cabal-version: >=1.10-tested-with: GHC==7.4.1 GHC==7.6.3, GHC ==7.8.2+source-repository head+ type: git+ location: https://github.com/massysett/deka.git -library- hs-source-dirs: lib- - exposed-modules: +Library+ exposed-modules: Deka+ , Deka.Abstract , Deka.Context , Deka.Dec , Deka.Docs@@ -51,76 +65,23 @@ , Deka.Native , Deka.Native.Abstract , Deka.Native.FromString- other-modules: Deka.Internal.Context- , Deka.Internal.Dec.CtxFree , Deka.Internal.Dec.Ctx- , Deka.Internal.Unsafe+ , Deka.Internal.Dec.CtxFree , Deka.Internal.Mpdec+ , Deka.Internal.Unsafe , Deka.Internal.Util.Ctx-+ hs-source-dirs:+ exposed+ , internal build-depends:- base >=4.5.0.0 && < 4.8- , bytestring >=0.9.2.1 && < 0.11- , parsec >= 3.1.2 && < 3.2- , transformers >= 0.3.0.0 && < 0.4-- ghc-options: -Wall- default-language: Haskell2010-- extra-libraries: mpdec--Test-Suite dectest- Build-depends:- deka ==0.6.0.0- , base >= 4.5.0.0 && < 4.8- , bytestring >=0.9.2.1 && < 0.11- , transformers >= 0.3.0.0 && < 0.4.0.0- , containers >= 0.4.2.1 && < 0.6- , pipes >= 4.1.1 && < 4.2-- type: exitcode-stdio-1.0- hs-source-dirs: dectest- ghc-options: -Wall- main-is: dectest.hs- other-modules:- AllModules- , Arity- , Conditions- , Directives- , NumTests- , Operand- , Parse- , Parse.Tokenizer- , Parse.Tokens- , Result- , Runner- , Specials- , TestHelpers- , TestLog- , Types- , Util- default-language: Haskell2010- extra-libraries: mpdec--Test-Suite native- Build-depends:- deka ==0.6.0.0- , base >= 4.5.0.0 && < 4.8- , bytestring >=0.9.2.1 && < 0.11- , QuickCheck >= 2.7.3 && < 2.8- , tasty >= 0.8.0.4 && < 0.9- , tasty-quickcheck >= 0.8.0.3 && < 0.9-- type: exitcode-stdio-1.0- hs-source-dirs: native- ghc-options: -Wall- main-is: native.hs- other-modules:- AllModules- , Generators- , Properties+ base ((> 4.5.0.0 || == 4.5.0.0) && < 4.8)+ , bytestring ((> 0.9.2.1 || == 0.9.2.1) && < 0.11)+ , parsec ((> 3.1.2 || == 3.1.2) && < 3.2)+ , transformers ((> 0.3.0.0 || == 0.3.0.0) && < 0.5)+ ghc-options:+ -Wall default-language: Haskell2010- extra-libraries: mpdec-+ extra-libraries:+ mpdec
+ exposed/Deka.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE Safe, DeriveDataTypeable #-}++-- | Simple decimal arithmetic.+--+-- 'Deka' provides a decimal arithmetic type. Using this module, the+-- results are never inexact. Computations will throw exceptions+-- rather than returning an inexact result. That way, you know that+-- any result you have is exactly correct.+--+-- On 64-bit platforms, you are limited to:+--+-- * a coefficient of ((2 * 10 ^ 17) - 1) digits long+--+-- * a maximum exponent of ((1 * 10 ^ 18) - 1)+--+-- * a minimum exponent of -((1 * 10 ^ 18) + 1)+--+-- On 32-bit platforms, you are limited to:+--+-- * a coefficient of 8.5 * 10 ^ 8 digits long+--+-- * a maximum exponent of 4.25 * 10 ^ 8+--+-- * a minimum exponent of -4.25 * 10 ^ 8+--+-- If you exceed these limits, your computation will throw an+-- exception.+--+-- 'Deka' represents only finite values. There are no infinities or+-- not-a-number values allowed.+--+-- For more control over your arithmetic, see "Deka.Dec", but+-- for many routine uses this module is sufficient and is more+-- succinct because, unlike 'Dec', 'Deka' is a member of the 'Num'+-- typeclass.++module Deka+ ( Deka+ , unDeka+ , DekaT(..)+ , integralToDeka+ , strToDeka+ , quadToDeka+ , DekaError(..)+ ) where++import Control.Exception+import Data.Typeable+import Deka.Dec hiding (compare)+import qualified Deka.Dec as D+import qualified Data.ByteString.Char8 as BS8++-- | Thrown by arithmetic functions in the Num class, as this is the+-- only way to indicate errors.+data DekaError+ = Flagged Flags+ -- ^ A computation set flags. This will happen if, for example,+ -- you calculate a result that is out of range.+ deriving (Show, Typeable)++instance Exception DekaError++-- | Deka wraps a 'Dec'. Only finite 'Dec' may become a 'Deka';+-- no infinities or NaN values are allowed.+--+-- 'Deka' is a member of 'Num', making it easy to use for+-- elementary arithmetic. Any time you perform arithmetic, the+-- results are always exact. The arithmetic functions will throw+-- exceptions rather than give you an inexact result.+--+-- 'Deka' is not a member 'Fractional' because it is generally+-- impossible to perform division without getting inexact results,+-- and 'Deka' never holds inexact results.+newtype Deka = Deka { unDeka :: Dec }+ deriving Show++eval :: Ctx a -> a+eval c+ | fl == emptyFlags = r+ | otherwise = throw . Flagged $ fl+ where+ (r, fl) = runCtxStatus c++-- | Eq compares by value. For instance, @3.5 == 3.500@.+instance Eq Deka where+ Deka x == Deka y = case eval k of+ EQ -> True+ _ -> False+ where+ k = do+ d <- D.compare x y+ let f | isZero d = EQ+ | isPositive d = GT+ | otherwise = LT+ return f++-- | Ord compares by value. For instance, @compare 3.5 3.500 ==+-- EQ@.+instance Ord Deka where+ compare (Deka x) (Deka y) = eval $ do+ d <- D.compare x y+ let f | isZero d = EQ+ | isPositive d = GT+ | otherwise = LT+ return f++-- | Many of the 'Num' functions will throw 'DekaError' if their+-- arguments are out of range or if they produce results that are+-- out of range or inexact. For functions that don't throw, you can+-- use 'integralToDeka' rather than 'fromInteger', or you can use+-- "Deka.Dec" instead of 'Deka'.+instance Num Deka where+ Deka x + Deka y = Deka . eval $ D.add x y+ Deka x - Deka y = Deka . eval $ D.subtract x y+ Deka x * Deka y = Deka . eval $ D.multiply x y+ negate = Deka . eval . D.minus . unDeka+ abs = Deka . eval . D.abs . unDeka+ signum (Deka x)+ | f isZero = fromInteger 0+ | f isNegative = fromInteger (-1)+ | otherwise = fromInteger 1+ where+ f g = g x+ fromInteger = Deka . eval . fromByteString . BS8.pack . show++-- | Decimals with a total ordering.+newtype DekaT = DekaT { unDekaT :: Deka }+ deriving Show++-- | Eq compares by a total ordering.+instance Eq DekaT where+ DekaT (Deka x) == DekaT (Deka y)+ | r == EQ = True+ | otherwise = False+ where+ r = compareTotal x y++-- | Ord compares by a total ordering.+instance Ord DekaT where+ compare (DekaT (Deka x)) (DekaT (Deka y)) = compareTotal x y+++-- | Convert any integral to a 'Deka'. Returns 'Nothing' if the+-- integer is too big to fit into a 'Deka'.+integralToDeka :: (Integral a, Show a) => a -> Maybe Deka+integralToDeka i+ | fl == emptyFlags = Just . Deka $ d+ | otherwise = Nothing+ where+ (d, fl) = runCtxStatus . fromByteString . BS8.pack . show $ i++-- | Convert a string to a Deka. You can use ordinary numeric+-- strings, such as @3.25@, or exponential notation, like @325E-2@.+-- More information on your choices is at:+--+-- <http://speleotrove.com/decimal/daconvs.html#reftonum>+--+-- You cannot use strings that represent an NaN or an infinity. If+-- you do that, or use an otherwise invalid string, this function+-- returns 'Nothing'.+strToDeka :: String -> Maybe Deka+strToDeka s+ | not (emptyFlags == fl) = Nothing+ | not (isFinite r) = Nothing+ | otherwise = Just (Deka r)+ where+ (r, fl) = runCtxStatus . fromByteString . BS8.pack $ s++-- | Change a 'Dec' to a 'Deka'. Only succeeds for finite 'Dec'.+quadToDeka :: Dec -> Maybe Deka+quadToDeka d+ | isFinite d = Just $ Deka d+ | otherwise = Nothing
+ exposed/Deka/Abstract.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings, BangPatterns #-}+-- | Abstract representation of numbers.+--+-- The General Decimal Arithmetic Specification gives an abstract+-- representation of each number. This information is taken from+-- the General Decimal Arithmetic specification at+--+-- <http://speleotrove.com/decimal/damodel.html>+--+-- A number may be /finite/, in+-- which case it has three components: a /sign/, which must be zero+-- (for zero or positive numbers) or one (for negative zero and+-- negative numbers), an integral /coefficient/, which is always+-- zero or positive, and a signed integral /exponent/, which+-- indicates the power of ten by which the number is multiplied.+-- The value of a finite number if given by+--+-- > (-1) ^ sign * coefficient * 10 ^ exponent+--+-- In addition to finite numbers, a number may also be one of three+-- /special values/:+--+-- * /infinity/ - numbers infinitely large in magnitude+--+-- * /quiet NaN/ - an undefined result which does not cause an+-- 'invalidOperation' condition.+--+-- * /signaling NaN/ - an undefined result which will usually cause+-- an 'invalidOperation' condition.+--+-- When a number has one of these special values, its /coefficient/+-- and /exponent/ are undefined. An NaN, however, may have+-- additional /diagnostic information/, which is a positive integer.+--+-- All special values have a sign. The sign of an infinity is+-- significant. The sign of an NaN has no meaning, though it may be+-- considered as part of the diagnostic information.+--+-- This module allows you to represent a number in abstract terms.+-- It's abstract in the sense that you cannot use the abstract form+-- to perform arithmetic. It is useful, however, because you might+-- want to manipulate the abstract form in your own programs--to+-- make a pretty printer with digit grouping, for example.+--+-- You can transform an abstract form to a 'Dec' losslessly by using+-- 'abstractToByteString'. This gives you a string in scientific+-- notation, as specified in @to-scientific-string@ in the+-- specification. There is a one-to-one mapping of abstract+-- representations to @scientific-string@ representations. You can+-- also transform a 'Dec' to an 'Abstract' losslessly by using+-- 'abstractFromByteString'. This operation will not fail if it is+-- using output from 'toByteString'; but it might fail otherwise, if+-- the input is malformed.+--+-- All typeclass instances in this module are derived; so while the+-- 'Ord' instance might be useful to use 'Abstract' as the key in a+-- Map, don't expect it to tell you anything about how to 'Abstract' are+-- situated on the number line.++module Deka.Abstract where+
+ exposed/Deka/Context.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE Safe #-}+module Deka.Context+ ( ++ -- * Integer type+ Signed++ -- * Ctx+ , Ctx++ -- * Flags+ , Flag+ , Flags+ , allFlag+ , fullFlags+ , emptyFlags+ , packFlags+ , unpackFlags++ -- ** Individual flags+ , clamped+ , conversionSyntax+ , divisionByZero+ , divisionImpossible+ , divisionUndefined+ , fpuError+ , inexact+ , invalidContext+ , invalidOperation+ , mallocError+ , notImplemented+ , overflow+ , rounded+ , subnormal+ , underflow++ -- * Traps+ , getTraps+ , setTraps++ -- * Status+ , getStatus+ , setStatus+ + -- * Digits+ , Precision+ , precision+ , unPrecision+ , getPrecision+ , setMaxPrecision++ -- * Rounding+ -- ** Rounding types+ , Round+ , roundCeiling+ , roundUp+ , roundHalfUp+ , roundHalfEven+ , roundHalfDown+ , roundDown+ , roundFloor+ , round05Up+ , roundTruncate++ -- ** Getting and setting+ , getRound+ , setRound++ -- * Emax and Emin+ -- ** Emax+ , Emax+ , unEmax+ , emax+ , getEmax++ -- ** Emin+ , Emin+ , unEmin+ , emin+ , getEmin++ -- * Trio+ , Trio+ , trioPrecision+ , trioEmax+ , trioEmin+ , trio+ , setTrio+ , getTrio++ -- * Clamp+ , getClamp+ , setClamp++ -- * Correct rounding+ , getAllCorrectRound+ , setAllCorrectRound++ -- * Initializers+ , Initializer(..)+ , initCtx++ -- * Running a Ctx+ , runCtxInit+ , runCtx+ , runCtxStatus+ , local++ ) where++import Deka.Internal.Context+import Deka.Internal.Mpdec (Signed)
+ exposed/Deka/Dec.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE Safe #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- | Decimal arithmetic.+--+-- Much documentation is copied from documentation for the decNumber+-- C library, available at+--+-- <http://speleotrove.com/decimal/dnnumb.html>+module Deka.Dec+ ( Dec++ -- * Context+ , module Deka.Context++ -- * String Conversions+ , fromByteString+ , toByteString+ , toEngByteString++ -- * Arithmetic+ , add+ , subtract+ , multiply+ , fma+ , divide+ , divideInteger+ , remainder+ , remainderNear++ -- * Signs and absolute value+ , abs+ , plus+ , minus++ -- * Comparisons+ , compare+ , compareSignal+ , compareTotal+ , compareTotalMag+ , max+ , maxMag+ , min+ , minMag++ -- * Increments+ , nextMinus+ , nextPlus+ , nextToward++ -- * Exponent testing and adjustment+ , sameQuantum+ , quantize+ , rescale+ , scaleB++ -- * Digit-wise and logical+ , and+ , or+ , xor+ , shift+ , rotate+ , invert++ -- * Trailing zeroes+ , reduce++ -- * Integral rounding+ , toIntegralExact+ , toIntegralValue++ -- * Logarithms, exponents, roots+ , exp+ , ln+ , logB+ , log10+ , power+ , squareRoot++ -- * Identification+ , PosNeg(..)+ , Number(..)+ , Class(..)+ , strToClass+ , numClass+ , isNormal+ , isSubnormal+ , isFinite+ , isInfinite+ , isNaN+ , isNegative+ , isPositive+ , isSigned+ , isQNaN+ , isSNaN+ , isSpecial+ , isZero+ , isZeroCoeff+ , isOddCoeff+ , Sign(..)+ , sign+ , EvenOdd(..)+ , evenOdd++ -- * Version+ , version++ ) where++import Deka.Internal.Dec.CtxFree+import Deka.Internal.Dec.Ctx+import Deka.Internal.Mpdec+import Deka.Context+import Data.ByteString.Char8 as BS8+import Prelude (Show(..), (.))++-- | Same as+--+-- @+-- 'BS8.unpack' . 'toByteString'+-- @+instance Show Dec where+ show = BS8.unpack . toByteString+
+ exposed/Deka/Docs.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE Safe #-}+-- | Documentation for Deka.+--+-- At the moment, documentation is scattered about. Some of it is+-- in the main README.md, which is in the source code tree and is+-- viewable in Github at+--+-- <http://github.com/massysett/deka/blob/master/README.md>+--+-- Of course much of it is in the Haddock comments in the source+-- code itself.+--+-- There is also a module here, "Deka.Docs.Examples". It is in+-- literate Haskell and has many comments. Unfortunately Haddock+-- does not play well with Literate Haskell. However, the style of+-- the file would not play well with Haddock anyway so I'm not sure+-- I would ever switch back to regular Haskell for that file.+--+-- So if you link to the file from the Haddock docs, you will just+-- get a blank page. Fortunately it is easily readable in Github:+--+-- <http://github.com/massysett/deka/blob/master/lib/Deka/Docs/Examples.hs>++module Deka.Docs where
+ exposed/Deka/Docs/Examples.lhs view
@@ -0,0 +1,268 @@+Examples for the Deka library+=============================++For very simple arithmetic, just import `Deka`. It contains a+`Deka` type, which is an instance of Num. For more control over your+arithmetic, import `Deka.Fixed.Quad`. Be aware that `Quad` exports some+functions that clash with Prelude names, so you might want to do a+qualified `import`; however we will just import them unqualified+here.++> -- Examples will deliberately shadow some names+> {-# OPTIONS_GHC -fno-warn-name-shadowing #-}+> {-# LANGUAGE Safe #-}+>+> -- | If you are viewing this module in Haddock and expecting to+> -- see examples, you won't see anything. The file is written in+> -- literate Haskell, so the idea is that you will look at the+> -- source itself. You can look at the source in Haddock, but it+> -- will probably be poorly formatted because HsColour formats it+> -- rather oddly by default. The easiest way to see it+> -- is on Github:+> --+> -- <https://github.com/massysett/deka/blob/master/lib/Deka/Docs/Examples.lhs>+> module Deka.Docs.Examples where++> import Deka+> import Deka.Dec+> import Data.Maybe++We need Char8 ByteStrings when working with the `Deka.Dec` module:++> import qualified Data.ByteString.Char8 as BS8++> examples :: IO ()+> examples = do {++Why is decimal arithmetic important? The webpages here discuss the+issue at great length:++http://speleotrove.com/decimal/++But in a nutshell, the floats that are built in to nearly every+computer language, including Haskell, are approximate. That's OK+for many purposes. It's not OK if you need exact results, such as+for financial purposes.++For example, on my machine this will not output 0.3 but instead will+output 0.3 plus a small fraction:++> print $ 0.1 + 0.1 + (0.1 :: Double);++This sort of imprecision adds up quickly and makes your life as a+programmer harder in many ways. It also produces results that are+simply incorrect if you needed an exact answer.++For simple arithmetic like this, deka provides the `Deka` type. It is+an instance of `Num`. Results with the `Deka` type are never, ever+rounded. There are limits on the size of numbers you can use; these+limits are huge and should not affect most uses. They are+documented in the `Deka` module.++All numbers in deka are stored as a "coefficient" and an "exponent".+The coefficient is an integer, and the exponent is an+integer that may be negative, zero, or positive. Here, the+coefficient is always 12345, but the exponent varies:++ Number Exponent+ 12345 0+ 123.45 -2+ 0.12345 -5+ 0.00012345 -8++Some numbers can only accurately be written down using scientific+notation if we want to reflect how many digits are in the+coefficient. We can do this with E notation, where the coefficient+is followed by the exponent. To get the original number, if the+coefficient is c and the exponent is e, do++ c * 10 ^ e++So, for example, you can say that `12345e0` and `1234500e-2` are the+same number, but they have different coefficients.++For more about decimal arithmetic, you will really want to read++http://speleotrove.com/decimal/decarith.html++It's written in a very clear style.++OK, so back to `Deka`. We said that `print $ 0.1 + 0.1 + 0.1` yields+an inaccurate result. How to do it with `Deka`?++First we have to create a `Deka`. `Deka` is not an instance of+`Read`. However you can use `strToDeka`, which has the type++ strToDeka :: String -> Maybe Deka++If you give a bad input string, you get `Nothing`; otherwise you get+a `Just` with your `Deka`. The input string can be in regular or+scientific notation.++So, the following snippet will not give you incorrectly rounded+results:++> let { oneTenth = fromJust . strToDeka $ "0.1" };+> print $ oneTenth + oneTenth + oneTenth;++`Deka` is not an instance of other numeric typeclasses, such as+`Real` or `Fractional`. That's because `Deka` never ever rounds, no+matter what. For `Deka` to be a member of `Fractional`, it would+need to implement division, and division without rounding can't do+very much.++Sometimes it will be impossible for `Deka` to do its math without+rounding. In that case, the functions in the `Deka` module will+apply `error` and quit. That way you are assured that if you have a+result, it is not rounded.+++More flexibility with the `Deka.Dec` module+=================================================++Though the `Deka` type provides you with some flexibility--and it's+easy to use because it's an instance of `Num`--sometimes you need more+flexibility. If you want to perform division, for example, `Deka` is+no good. For more flexibility, but more cumbersome use, turn to the+`Deka.Dec` module.++The main type of the `Deka.Dec` module is called `Dec`, as in+"Decimal". It exposes the full power of the mpdecimal library. The+disadvantage is that many computations must be performed in the+`Ctx` monad. This monad carries the state that decNumber needs to+do its work. It provides you with a lot of information about any+errors that have occurred during computations.++If you are getting into the `Deka.Dec` module, you really need to read the+decimal arithmetic specification at++http://speleotrove.com/decimal/decarith.html++Context+-------++This specification provides that many computations occur within a+so-called "context", which holds information that affects the+computation, such as how to round inexact results. The context also+holds information about any errors that have happened so far, such+as division by zero, and can tell you other information such as+whether any computations performed so far have calculated an inexact+result.++The context of the decimal arithmetic specification is represented+in Deka by the `Ctx` type. `Ctx` provides computations with the+context that they need, and it allows computations to record errors+that may arise. `Ctx` is a `Monad` so you can use the usual monad+functions and `do` notation to combine your computations.+`Deka.Context`, which is re-exported by `Deka.Dec`, has functions+you can use to change the context's rounding, see what errors have+been set, and clear errors. Once an error flag is set, you have to+clear it; the functions in `Quad` won't clear it for you. However,+computations can proceed normally even if an error flag was set in a+previous computation.++After building up a computation in the `Ctx` monad, you need a way+to get the results and use them elsewhere in your program. For this+you use the `runQuad` function:++ runCtx :: Ctx a -> a++Not all computations need a context. For example, `compareTotal`+does not need a context, and it can never return an error.++Example - using `do` notation+-----------------------------++Following is an example of how you would add one tenth using the+Quad type:++> let { oneTenth = runCtx . fromByteString . BS8.pack $ "0.1" };+> BS8.putStrLn . toByteString . runCtx $ do+> r1 <- add oneTenth oneTenth+> add r1 oneTenth+> ;++As you can see this is much more cumbersome than using `Deka`. But+it does give you the full power of mpdecimal.++Rounding+--------++One reason to use the `Deka.Dec` module is because you want greater+control over rounding. There are many varieties of rounding+available, which you can set. This can be useful with division, for+example, where you will not get exact results. All results are+computed to 34 digits of precision.++> let tenSixths = runCtx $ do+> setRound roundDown+> ten <- fromByteString . BS8.pack $ "10"+> three <- fromByteString . BS8.pack $ "6"+> divide ten three+> ;++Perhaps you want to round the result to a particular number of+decimal places. You do this with the `quantize` function. It takes+two `Quad`: one that you want to round, and another that has the+number of decimal places you want to round to.++> putStrLn "This is 10 / 6, rounded to two places:";+> BS8.putStrLn . toByteString . runCtx $ do+> twoPlaces <- fromByteString . BS8.pack $ "1e-2"+> quantize tenSixths twoPlaces+> ;++By default, rounding is done using the `roundHalfEven` method. You+can set a different rounding method if you wish; the rounding+methods are listed in the Haddock documentation for `Deka.Context`.++> putStrLn "This is 10 / 6, rounded using the 'roundDown' method.";+> BS8.putStrLn . toByteString . runCtx $ do+> twoPlaces <- fromByteString . BS8.pack $ "1e-2"+> setRound roundDown+> quantize tenSixths twoPlaces+> ;+++Flags+-----++A computation may set any number of flags. These are listed in the+`Deka.Context` module. They indicate errors (like division by zero)+or give information (such as the fact that a computation was+inexact.) Functions in `Deka.Context` manipulate which flags are+currently set. Though computations set flags, they never clear+them. You have to clear them yourself.++To see which flags are set, use `getStatus`:++> let (r, fl) = runCtx $ do+> big1 <- fromByteString . BS8.pack $ "987e3000"+> nan <- fromByteString . BS8.pack $ "sNaN"+> rslt <- multiply big1 nan+> fl <- getStatus+> return $ (toByteString rslt, fl)+> ; +> putStr "result: ";+> BS8.putStrLn r;+> putStr "flags set: ";+> print fl;++The above example also shows that computations may return a Quad+that is not finite--that is, it might be inifite, or it might be a+Not-a-Number, or NaN. In contrast, computations using the Deka type+never return non-finite values.++Conclusion+----------++That should be enough to get you started. If you find any bug no+matter how small--even just a typo in the documentation--report it+to me at omari@smileystation.com or file a ticket or a pull request+in Github:++https://github.com/massysett/deka++No bug is too small!++> };
+ exposed/Deka/Native.hs view
@@ -0,0 +1,88 @@+-- | Representation of numbers in native Haskell types.+--+-- Since deka is a binding to the mpdecimal C library, the data+-- types are held as pointers to data which are managed by C+-- functions. Therefore there is no direct access to what is inside+-- of the the 'Deka.Dec' data type. Modules in "Deka.Native"+-- provide Haskell types mirroring the abstract representations+-- given in the General Decimal Arithmetic Specification. This is+-- useful if you want to manipulate the data in an abstract way.+-- For example, perhaps you want to perform arithmetic on a value,+-- transform it to abstract form, add digit grouping characters, and+-- then use your own functions to pretty print the result.+--+-- The General Decimal Arithmetic Specification gives an abstract+-- representation of each number. This information is taken from+-- the General Decimal Arithmetic specification at+--+-- <http://speleotrove.com/decimal/damodel.html>+--+-- A number may be /finite/, in+-- which case it has three components: a /sign/, which must be zero+-- (for zero or positive numbers) or one (for negative zero and+-- negative numbers), an integral /coefficient/, which is always+-- zero or positive, and a signed integral /exponent/, which+-- indicates the power of ten by which the number is multiplied.+-- The value of a finite number if given by+--+-- > (-1) ^ sign * coefficient * 10 ^ exponent+--+-- In addition to finite numbers, a number may also be one of three+-- /special values/:+--+-- * /infinity/ - numbers infinitely large in magnitude+--+-- * /quiet NaN/ - an undefined result which does not cause an+-- 'invalidOperation' condition.+--+-- * /signaling NaN/ - an undefined result which will usually cause+-- an 'invalidOperation' condition.+--+-- When a number has one of these special values, its /coefficient/+-- and /exponent/ are undefined. An NaN, however, may have+-- additional /diagnostic information/, which is a positive integer.+--+-- All special values have a sign. The sign of an infinity is+-- significant. The sign of an NaN has no meaning, though it may be+-- considered as part of the diagnostic information.+--+-- You can transform an abstract form to a 'Dec' losslessly by using+-- 'abstractToByteString'. This gives you a string in scientific+-- notation, as specified in @to-scientific-string@ in the+-- specification. There is a one-to-one mapping of abstract+-- representations to @scientific-string@ representations. You can+-- also transform a 'Dec' to an 'Abstract' losslessly by using+-- 'abstractFromByteString'. This operation will not fail if it is+-- using output from 'toByteString'; but it might fail otherwise, if+-- the input is malformed.+--+-- All standard typeclass instances in these modules are derived; so+-- while the 'Ord' instance might be useful to use 'Abstract' as the+-- key in a Map, don't expect it to tell you anything about how+-- 'Abstract' are situated on the number line.+module Deka.Native+ ( -- * Digits and groups of digits+ Novem(..)+ , Decem(..)+ , Decuple(..)+ , Aut(..)+ , Firmado(..)++ -- * Elements of abstract numbers+ , Coefficient(..)+ , Exponent(..)+ , Diagnostic(..)+ , Noisy(..)+ , NonNum(..)+ , Value(..)+ , Abstract(..)++ -- * Transformations+ , abstractToString+ , abstractToDec+ , stringToAbstract+ , decToAbstract+ ) where++import Deka.Native.Abstract+import Deka.Native.FromString (stringToAbstract, decToAbstract)
+ exposed/Deka/Native/Abstract.hs view
@@ -0,0 +1,330 @@+{-# LANGUAGE OverloadedStrings, BangPatterns #-}++module Deka.Native.Abstract where++import Deka.Dec+import Prelude hiding (exponent)+import Control.Monad+import Data.List (foldl')+import qualified Data.ByteString.Char8 as BS8++-- # Types++-- | A digit from one to nine. Useful to represent a most+-- significant digit, or MSD, as an MSD cannot be the digit zero.+data Novem = D1 | D2 | D3 | D4 | D5 | D6 | D7 | D8 | D9+ deriving (Eq, Ord, Show, Enum, Bounded)++novemToChar :: Novem -> Char+novemToChar n = case n of+ { D1 -> '1'; D2 -> '2'; D3 -> '3'; D4 -> '4'; D5 -> '5';+ D6 -> '6'; D7 -> '7'; D8 -> '8'; D9 -> '9' }++charToNovem :: Char -> Maybe Novem+charToNovem c = case c of+ { '1' -> Just D1; '2' -> Just D2; '3' -> Just D3;+ '4' -> Just D4; '5' -> Just D5; '6' -> Just D6; '7' -> Just D7;+ '8' -> Just D8; '9' -> Just D9; _ -> Nothing }++novemToInt :: Integral a => Novem -> a+novemToInt d = case d of+ { D1 -> 1; D2 -> 2; D3 -> 3; D4 -> 4; D5 -> 5; D6 -> 6;+ D7 -> 7; D8 -> 8; D9 -> 9 }++intToNovem :: Integral a => a -> Maybe Novem+intToNovem a = case a of+ { 1 -> Just D1; 2 -> Just D2; 3 -> Just D3; 4 -> Just D4;+ 5 -> Just D5; 6 -> Just D6;+ 7 -> Just D7; 8 -> Just D8; 9 -> Just D9; _ -> Nothing }++-- | A digit from zero to nine.+data Decem+ = D0+ | Nonem Novem+ deriving (Eq, Ord, Show)++decemToChar :: Decem -> Char+decemToChar d = case d of+ { D0 -> '0'; Nonem n -> novemToChar n }++charToDecem :: Char -> Maybe Decem+charToDecem c = case c of+ { '0' -> Just D0; _ -> fmap Nonem (charToNovem c) }++decemToInt :: Integral a => Decem -> a+decemToInt d = case d of+ { D0 -> 0; Nonem n -> novemToInt n }++decemToNovem :: Decem -> Maybe Novem+decemToNovem d = case d of+ Nonem n -> Just n+ _ -> Nothing++intToDecem :: Integral a => a -> Maybe Decem+intToDecem i = case i of+ { 0 -> Just D0; _ -> fmap Nonem $ intToNovem i }++intToDecemList :: Integral a => a -> (Sign, [Decem])+intToDecemList x = (sgn, ls)+ where+ sgn | x < 0 = Sign1+ | otherwise = Sign0+ ls = reverse . go . Prelude.abs $ x+ go !i =+ let (d, m) = i `divMod` 10+ r = maybe (error "intToDecemList: error") id+ . intToDecem $ m+ in if i == 0+ then []+ else r : go d++decemListToInt :: Integral a => [Decem] -> a+decemListToInt ds = foldl' f 0 . indices $ ds+ where+ indices = zip (iterate pred (length ds - 1))+ f acc (ix, d) = acc + decemToInt d * 10 ^ ix++-- | A non-empty set of digits. The MSD must be from 1 to 9.++data Decuple = Decuple Novem [Decem]+ deriving (Eq, Ord, Show)++decupleToString :: Decuple -> String+decupleToString (Decuple msd rest) =+ novemToChar msd : map decemToChar rest++stringToDecuple :: String -> Maybe Decuple+stringToDecuple str = case str of+ [] -> Nothing+ x:xs -> liftM2 Decuple (charToNovem x) (mapM charToDecem xs)++decupleToInt :: Integral a => Decuple -> a+decupleToInt (Decuple n ds) =+ let len = length ds+ go !soFar !i digs = case digs of+ [] -> soFar+ x:xs ->+ let nxt = i - 1+ thisSum = soFar + decemToInt x * 10 ^ nxt+ in go thisSum nxt xs+ in novemToInt n * (10 ^ len) + go 0 len ds++uncons :: [a] -> Maybe (a, [a])+uncons a = case a of+ [] -> Nothing+ x:xs -> Just (x, xs)++intToDecuple :: Integral a => a -> Maybe (Sign, Decuple)+intToDecuple x = do+ let (sgn, ds) = intToDecemList x+ (d1, dr) <- uncons ds+ let nv = maybe (error "intToDecuple: MSD is not zero") id+ . decemToNovem $ d1+ return (sgn, Decuple nv dr)++decemListToDecuple :: [Decem] -> Maybe Decuple+decemListToDecuple ds = case dropWhile (== D0) ds of+ [] -> Nothing+ x:xs -> Just $ Decuple d1 xs+ where+ d1 = maybe (error "decemListToDecuple: bad MSD") id+ . decemToNovem $ x+++-- | Either a set of digits, or zero. Unsigned.++data Aut+ = Nil+ -- ^ Zero+ | Plenus Decuple+ -- ^ Non-zero+ deriving (Eq, Ord, Show)++autToString :: Aut -> String+autToString a = case a of+ Nil -> "0"+ Plenus ds -> decupleToString ds++stringToAut :: String -> Maybe Aut+stringToAut s = case s of+ "0" -> Just Nil+ _ -> fmap Plenus $ stringToDecuple s++autToInt :: Integral a => Aut -> a+autToInt a = case a of+ Nil -> 0+ Plenus d -> decupleToInt d++-- | Fails if the argument is less than zero.+intToAut :: Integral a => a -> Maybe Aut+intToAut a = case intToDecuple a of+ Nothing -> Just Nil+ Just (s, d) -> case s of+ Sign1 -> Nothing+ _ -> return . Plenus $ d++decemListToAut :: [Decem] -> Aut+decemListToAut ds = case dropWhile (== D0) ds of+ [] -> Nil+ x:xs -> Plenus $ Decuple d1 xs+ where+ d1 = maybe (error "decemListToAut: bad MSD") id+ . decemToNovem $ x++-- | Either a set of digits, or zero. Signed.++data Firmado+ = Cero+ -- ^ Zero+ | Completo PosNeg Decuple+ -- ^ Non-zero+ deriving (Eq, Ord, Show)++firmadoToString :: Firmado -> String+firmadoToString x = case x of+ Cero -> "0"+ Completo p d -> sgn : decupleToString d+ where+ sgn = case p of { Pos -> '+'; Neg -> '-' }++stringToFirmado :: String -> Maybe Firmado+stringToFirmado s+ | s == "0" = Just Cero+ | otherwise = do+ (sgn, rst) <- case s of+ "" -> Nothing+ x:xs -> case x of+ '+' -> return (Pos, xs)+ '-' -> return (Neg, xs)+ _ -> Nothing+ dec <- stringToDecuple rst+ return $ Completo sgn dec++firmadoToInt :: Integral a => Firmado -> a+firmadoToInt x = case x of+ Cero -> 0+ Completo p d -> apply . decupleToInt $ d+ where+ apply = case p of { Pos -> id; Neg -> negate }++intToFirmado :: Integral a => a -> Firmado+intToFirmado i = case intToDecuple i of+ Nothing -> Cero+ Just (sgn, d) -> Completo p d+ where+ p = case sgn of { Sign0 -> Pos; Sign1 -> Neg }+++--+-- Types in Abstract+--++-- | The coefficient in a number; not used in infinities or NaNs.+newtype Coefficient = Coefficient { unCoefficient :: Aut }+ deriving (Eq, Ord, Show)++-- | The exponent in a number.+newtype Exponent = Exponent { unExponent :: Firmado }+ deriving (Eq, Ord, Show)++-- | The diagnostic information in an NaN.+newtype Diagnostic = Diagnostic { unDiagnostic :: Decuple }+ deriving (Eq, Ord, Show)++-- | Whether an NaN is quiet or signaling.+data Noisy = Quiet | Signaling+ deriving (Eq, Ord, Show)++-- | Not a Number.+data NonNum = NonNum+ { noisy :: Noisy+ , diagnostic :: Maybe Diagnostic+ } deriving (Eq, Ord, Show)++-- | All data in an abstract number except for the sign.+data Value+ = Finite Coefficient Exponent+ | Infinite+ | NotANumber NonNum+ deriving (Eq, Ord, Show)++-- | Abstract representation of all numbers covered by the General+-- Decimal Arithmetic Specification.+data Abstract = Abstract+ { sign :: Sign+ , value :: Value+ } deriving (Eq, Ord, Show)++signToString :: Sign -> String+signToString s = case s of+ Sign0 -> ""+ Sign1 -> "-"++-- | Adjusted exponent. Roughly speaking this represents the+-- coefficient and exponent of an abstract decimal, adjusted so+-- there is a decimal point between the most significant digit of+-- the coefficient and the remaning digits.+newtype AdjustedExp = AdjustedExp { unAdjustedExp :: Integer }+ deriving (Eq, Ord, Show)++-- | Computes an adjusted exponent. The length of a zero+-- coefficient is one.+adjustedExp :: Coefficient -> Exponent -> AdjustedExp+adjustedExp coe ex = AdjustedExp $ e + (c - 1)+ where+ e = firmadoToInt . unExponent $ ex+ c = fromIntegral $ case unCoefficient coe of+ Nil -> 1+ Plenus (Decuple _ ds) -> length ds + 1++fmtAdjustedExp :: AdjustedExp -> String+fmtAdjustedExp (AdjustedExp i) = 'E' : sgn : digs+ where+ sgn | i < 0 = '-'+ | otherwise = '+'+ digs = show . Prelude.abs $ i++finiteToString :: Coefficient -> Exponent -> String+finiteToString c e = coe ++ ae+ where+ coe = case unCoefficient c of+ Nil -> "0"+ Plenus (Decuple n ds)+ | null ds -> [novemToChar n]+ | otherwise -> novemToChar n : '.' : map decemToChar ds+ ae = fmtAdjustedExp $ adjustedExp c e++nanToString :: NonNum -> String+nanToString (NonNum n d) = pfx ++ "NaN" ++ dia+ where+ pfx = case n of { Quiet -> ""; Signaling -> "s" }+ dia = maybe "" (decupleToString . unDiagnostic) d++fmtValue :: Value -> String+fmtValue v = case v of+ Finite c e -> finiteToString c e+ Infinite -> "Infinity"+ NotANumber n -> nanToString n++-- | Transform an 'Abstract' to a 'String'. This conforms to the+-- @to-scientific-string@ transformation given in the General+-- Decimal Arithmetic Specification at+--+-- <http://speleotrove.com/decimal/daconvs.html#reftostr>+--+-- with one exception: the specification provides that some finite+-- numbers are represented without exponential notation.+-- 'abstractToString' /always/ uses exponential notation on finite+-- numbers.+abstractToString :: Abstract -> String+abstractToString (Abstract s v) = sgn ++ fmtValue v+ where+ sgn = case s of { Sign0 -> ""; Sign1 -> "-" }++-- | Transforms an 'Abstract' to a 'Dec'. Result is computed in a+-- context using the 'Pedantic' initializer. Result is returned+-- along with any status flags arising from the computation.+abstractToDec :: Abstract -> (Dec, Flags)+abstractToDec = runCtxStatus . fromByteString+ . BS8.pack . abstractToString+
+ exposed/Deka/Native/FromString.hs view
@@ -0,0 +1,227 @@+-- | Uses the specification for string conversions given in the+-- General Decimal Arithmetic Specification to convert strings to an+-- abstract syntax tree. The specification for string conversions+-- is at+--+-- <http://speleotrove.com/decimal/daconvs.html>+--+-- The functions and types in this module fall into two groups. The+-- first group converts a string to a 'NumericString', which is an+-- abstract representation of the grammar given in the General+-- Decimal Arithmetic Specification. These functions use Parsec to+-- parse the string. The second group transforms the+-- 'NumericString' to an 'A.Abstract', a form which more closely+-- aligns with the abstract representation given at+--+-- <http://speleotrove.com/decimal/damodel.html>.+--+-- You can transform an 'A.Abstract' to a numeric string; no+-- functions are provided to transform a 'NumericString' directly+-- back to a string.+module Deka.Native.FromString where++import Data.Char (toLower)+import Control.Applicative+import Text.Parsec.String+import Text.Parsec.Prim (tokenPrim, try, parse)+import Text.Parsec.Pos+import Text.Parsec.Char (char, string)+import Text.Parsec.Combinator (many1, eof)+import qualified Deka.Native.Abstract as A+import Deka.Native.Abstract+ (Decem(..), Novem(..), decemListToInt)+import Deka.Dec (Sign(..))+import qualified Deka.Dec as D+import qualified Data.ByteString.Char8 as BS8++sign :: Parser Sign+sign = tokenPrim show next f+ where+ next pos c _ = updatePosChar pos c+ f c = case c of+ '-' -> Just Sign1+ '+' -> Just Sign0+ _ -> Nothing++optSign :: Parser Sign+optSign = do+ s <- optional sign+ return $ maybe Sign0 id s++digit :: Parser Decem+digit = tokenPrim show next f+ where+ next pos c _ = updatePosChar pos c+ f c = case c of+ { '0' -> Just D0; '1' -> Just $ Nonem D1; '2' -> Just $ Nonem D2;+ '3' -> Just $ Nonem D3; '4' -> Just $ Nonem D4;+ '5' -> Just $ Nonem D5; '6' -> Just $ Nonem D6;+ '7' -> Just $ Nonem D7; '8' -> Just $ Nonem D8;+ '9' -> Just $ Nonem D9; _ -> Nothing }++indicator :: Parser ()+indicator = () <$ char 'e'++digits :: Parser [Decem]+digits = many1 digit++data DecimalPart+ = WholeFrac [Decem] [Decem]+ | WholeOnly [Decem]+ deriving (Eq, Ord, Show)++decimalPart :: Parser DecimalPart+decimalPart = do+ ds1 <- optional digits+ case ds1 of+ Nothing -> do+ _ <- char '.'+ fmap WholeOnly digits+ Just ds -> do+ dot <- optional (char '.')+ case dot of+ Just _ -> do+ ds2 <- many digit+ return $ WholeFrac ds ds2+ Nothing -> return $ WholeOnly ds++data ExponentPart = ExponentPart+ { expSign :: Sign+ , expDigits :: [Decem]+ } deriving (Eq, Ord, Show)++exponentPart :: Parser ExponentPart+exponentPart = do+ indicator+ sgn <- optSign+ ds <- digits+ return $ ExponentPart sgn ds++infinity :: Parser ()+infinity = try $ do+ _ <- string "inf"+ _ <- optional (string "inity")+ return ()++nanId :: Parser A.Noisy+nanId = try (string "nan" >> return A.Quiet)+ <|> try (string "snan" >> return A.Signaling)++data NaN = NaN A.Noisy [Decem]+ deriving (Eq, Ord, Show)++nan :: Parser NaN+nan = liftA2 NaN nanId (many digit)++data NumericValue+ = NVDec DecimalPart (Maybe ExponentPart)+ | Infinity+ deriving (Eq, Ord, Show)++numericValue :: Parser NumericValue+numericValue =+ (Infinity <$ infinity)+ <|> liftA2 NVDec decimalPart (optional exponentPart)++data NumericString = NumericString+ { nsSign :: Sign+ , nsValue :: Either NumericValue NaN+ } deriving (Eq, Ord, Show)++numericString :: Parser NumericString+numericString = liftA2 NumericString optSign ei+ where+ ei = (fmap Left numericValue <|> fmap Right nan)++parseNumericString :: String -> Either String NumericString+parseNumericString s =+ case parse (numericString <* eof) "" (map toLower s) of+ Left e -> Left (show e)+ Right g -> Right g++numericStringToAbstract :: NumericString -> A.Abstract+numericStringToAbstract (NumericString sgn ei) = A.Abstract sgn val+ where+ val = case ei of+ Left nv -> case nv of+ NVDec dp me -> uncurry A.Finite $ finiteToAbstract dp me+ Infinity -> A.Infinite+ Right nn -> A.NotANumber . nanToAbstract $ nn++nanToAbstract+ :: NaN+ -> A.NonNum+nanToAbstract (NaN nsy ds) = A.NonNum nsy . fmap A.Diagnostic+ . A.decemListToDecuple $ ds++finiteToAbstract+ :: DecimalPart+ -> Maybe ExponentPart+ -> (A.Coefficient, A.Exponent)+finiteToAbstract dp mep = (coe, ex)+ where+ ex = abstractExponent . actualExponent dp+ . givenExponent $ mep+ coe = abstractCoeff dp+ ++-- | A numeric value for the exponent that was given in the input+-- string.++givenExponent :: Maybe ExponentPart -> Integer+givenExponent me = case me of+ Nothing -> 0+ Just (ExponentPart s ds) -> getSgn $ decemListToInt ds+ where+ getSgn = case s of+ Sign0 -> id+ Sign1 -> negate++-- | The number of digits after the decimal point, subtracted from+-- the numeric value for the exponent given in the string++actualExponent+ :: DecimalPart+ -> Integer+ -- ^ Output from 'givenExponent'+ -> Integer+actualExponent d i = case d of+ WholeFrac _ ds -> i - fromIntegral (length ds)+ _ -> i++-- The value of the abstract exponent.++abstractExponent+ :: Integer+ -- ^ The output from 'actualExponent'+ -> A.Exponent+abstractExponent = A.Exponent . A.intToFirmado++abstractCoeff :: DecimalPart -> A.Coefficient+abstractCoeff d =+ let ds = case d of+ WholeFrac d1 d2 -> d1 ++ d2+ WholeOnly d1 -> d1+ in A.Coefficient $ A.decemListToAut ds++stringToAbstract++ :: String+ -- ^ Input string++ -> Either String A.Abstract+ -- ^ Returns a Right with the abstract representation of the input+ -- string, if the input conformed to the numeric string+ -- specification given in the General Decimal Arithmetic+ -- Specification. Otherwise, returns a Left with an error+ -- message.++stringToAbstract = fmap numericStringToAbstract . parseNumericString++-- | Transforms a 'Dec' to an 'Abstract'.+decToAbstract :: D.Dec -> A.Abstract+decToAbstract = either (error msg) id . stringToAbstract+ . BS8.unpack . D.toByteString+ where+ msg = "decToAbstract: error: could not parse output from "+ ++ "toByteString"
+ internal/Deka/Internal/Context.hs view
@@ -0,0 +1,637 @@+{-# LANGUAGE Trustworthy, DeriveDataTypeable #-}+module Deka.Internal.Context where++import Foreign.C+import Foreign.Safe+import Control.Applicative+import Control.Monad+import Control.Exception+import Data.Typeable+import Deka.Internal.Mpdec+import System.IO.Unsafe (unsafePerformIO)++-- | The Ctx monad+--+-- The General Decimal Arithmetic specification states that most+-- computations occur within a @context@, which affects the manner+-- in which computations are done (for instance, the context+-- determines the rounding algorithm). The context also carries+-- the flags that computations can set (for instance, a computation might+-- set a flag to indicate that the result is rounded or inexact or+-- was a division by zero.) The Ctx monad carries this context.++newtype Ctx a = Ctx { unCtx :: Ptr C'mpd_context_t -> IO a }++instance Functor Ctx where+ fmap = liftM++instance Applicative Ctx where+ pure = return+ (<*>) = ap++instance Monad Ctx where+ return a = Ctx $ \_ -> return a+ Ctx a >>= f = Ctx $ \p -> do+ r1 <- a p+ let b = unCtx $ f r1+ b p+ fail s = Ctx $ \_ -> fail s++-- # Rounding++newtype Round = Round { _unRound :: CInt }+ deriving (Eq, Ord)++-- | Round toward positive infinity.+roundCeiling :: Round+roundCeiling = Round c'MPD_ROUND_CEILING++-- | Round away from zero.+roundUp :: Round+roundUp = Round c'MPD_ROUND_UP++-- | @0.5@ rounds up+roundHalfUp :: Round+roundHalfUp = Round c'MPD_ROUND_HALF_UP++-- | @0.5@ rounds to nearest even+roundHalfEven :: Round+roundHalfEven = Round c'MPD_ROUND_HALF_EVEN++-- | @0.5@ rounds down+roundHalfDown :: Round+roundHalfDown = Round c'MPD_ROUND_HALF_DOWN++-- | Round toward zero - truncate+roundDown :: Round+roundDown = Round c'MPD_ROUND_DOWN++-- | Round toward negative infinity.+roundFloor :: Round+roundFloor = Round c'MPD_ROUND_FLOOR++-- | Round for reround+round05Up :: Round+round05Up = Round c'MPD_ROUND_05UP++-- | Truncate, but set infinities.+roundTruncate :: Round+roundTruncate = Round c'MPD_ROUND_TRUNC++instance Show Round where+ show r+ | r == roundCeiling = "ceiling"+ | r == roundUp = "up"+ | r == roundHalfUp = "half up"+ | r == roundHalfEven = "half even"+ | r == roundHalfDown = "half down"+ | r == roundDown = "down"+ | r == roundFloor = "floor"+ | r == round05Up = "05up"+ | r == roundTruncate = "truncate"+ | otherwise = error "show: unknown rounding value"++getRound :: Ctx Round+getRound = Ctx $ fmap Round . peek . p'mpd_context_t'round++setRound :: Round -> Ctx ()+setRound (Round r) = Ctx $ \ptr -> poke (p'mpd_context_t'round ptr) r++-- # Precision++-- | Sets the precision to be used for all operations. The result+-- of an operation is rounded to this length if necessary.+newtype Precision = Precision { unPrecision :: Signed }+ deriving (Eq, Ord, Show)++instance Bounded Precision where+ minBound = Precision 1+ maxBound = Precision c'MPD_MAX_PREC++-- | Creates a 'Precision' that you can then set with+-- 'setTrio'. Returns 'Nothing' if the argument is out of+-- range. The minimum possible value is always 1; the maximum+-- possible value is platform dependent and is revealed by+-- 'maxBound'.+precision :: Signed -> Maybe Precision+precision i+ | i < 1 = Nothing+ | i > c'MPD_MAX_PREC = Nothing+ | otherwise = Just . Precision $ i++-- | Sets the precision to the maximum possible, respecting that+-- @'Emax' > 5 * 'Precision'@. Returns the new 'Precision'.++setMaxPrecision :: Ctx Precision+setMaxPrecision = do+ Emax x <- getEmax+ let p' = Precision $ x `div` 5+ setPrecision p'+ return p'++setPrecision :: Precision -> Ctx ()+setPrecision (Precision d) = Ctx $ \ptr ->+ poke (p'mpd_context_t'prec ptr) d++getPrecision :: Ctx Precision+getPrecision = Ctx $ fmap Precision . peek . p'mpd_context_t'prec++-- # Emax, Emin++-- | Maximum adjusted exponent. The adjusted exponent is calculated+-- as though the number were expressed in scientific notation. If+-- the adjusted exponent would be larger than 'Emax' then an+-- overflow results.+--+-- The minimum possible value is always 0; the+-- maximum possible value is platform dependent and is revealed by+-- 'maxBound'.+newtype Emax = Emax { unEmax :: Signed }+ deriving (Eq, Ord, Show)++instance Bounded Emax where+ minBound = Emax 0+ maxBound = Emax c'MPD_MAX_EMAX++-- | Minimum adjusted exponent. The adjusted exponent is calculated+-- as though the number were expressed in scientific notation. If+-- the adjusted exponent would be smaller than 'Emin' then the+-- result is subnormal. If the result is also inexact, an underflow+-- results. If subnormal results are allowed (see 'setClamp') the+-- smallest possible exponent is 'Emin' minus 'Precision' plus @1@.+--+-- The minimum possible value is platform dependent+-- and is revealed by 'minBound'; the maximum possible value is+-- always 0.+newtype Emin = Emin { unEmin :: Signed }+ deriving (Eq, Ord, Show)++instance Bounded Emin where+ minBound = Emin c'MPD_MIN_EMIN+ maxBound = Emin 0++-- | Returns an 'Emax' for use in 'setTrio'. Fails if argument is+-- out of range.+emax :: Signed -> Maybe Emax+emax i+ | r < minBound = Nothing+ | r > maxBound = Nothing+ | otherwise = Just r+ where+ r = Emax i++-- | Returns an 'Emin' for use in 'setTrio'. Fails if argument is+-- out of range.+emin :: Signed -> Maybe Emin+emin i+ | r < minBound = Nothing+ | r > maxBound = Nothing+ | otherwise = Just r+ where+ r = Emin i++getEmax :: Ctx Emax+getEmax = Ctx $ fmap Emax . peek . p'mpd_context_t'emax++setEmax :: Emax -> Ctx ()+setEmax (Emax i) = Ctx $ \ptr -> poke (p'mpd_context_t'emax ptr) i++getEmin :: Ctx Emin+getEmin = Ctx $ fmap Emin . peek . p'mpd_context_t'emin++setEmin :: Emin -> Ctx ()+setEmin (Emin i) = Ctx $ \ptr -> poke (p'mpd_context_t'emin ptr) i++-- # Trio++-- | In addition to the limits on 'Precision', 'Emax', and 'Emin',+-- there are also requirements on the relationship between these+-- three variables:+--+-- * @'Emax' > 5 * 'Precision'@ +--+-- * either @'Emin' == 1 - 'Emax'@ or @'Emin' == -'Emax'@+--+-- The 'Trio' enforces this relationship.+--+-- It is also recommended that @'Emax' > 10 * 'Precision'@, but+-- since this is not required the 'Trio' does not enforce it.++data Trio = Trio+ { trioPrecision :: Precision+ , trioEmax :: Emax+ , trioEmin :: Emin+ } deriving Show++-- | Make a new 'Trio'. Fails if the values are out of range.++trio :: Precision -> Emax -> Emin -> Maybe Trio+trio pp@(Precision p) px@(Emax x) pn@(Emin n)+ | not $ x > 5 * p = Nothing+ | not $ n == 1 - x || n == negate x = Nothing+ | otherwise = Just $ Trio pp px pn++setTrio :: Trio -> Ctx ()+setTrio (Trio p x n) =+ setPrecision p >> setEmax x >> setEmin n++getTrio :: Ctx Trio+getTrio = liftM3 Trio getPrecision getEmax getEmin++-- # Clamp++getClamp :: Ctx Bool+getClamp = Ctx $ fmap (/= 0) . peek . p'mpd_context_t'clamp++-- | Controls explicit exponent clamping. When False, a result+-- exponent is limited to a maximum of emax and a minimum of emin+-- (for example, the exponent of a zero result will be clamped to be+-- in this range). When True, a result exponent has the same minimum+-- but is limited to a maximum of emax-(digits-1). As well as+-- clamping zeros, this may cause the coefficient of a result to be+-- padded with zeros on the right in order to bring the exponent+-- within range.+--+-- Also when True, this limits the length of NaN payloads to+-- 'Precision' - 1 when constructing a NaN by conversion from a+-- string.++setClamp :: Bool -> Ctx ()+setClamp b = Ctx f+ where+ f ptr = poke (p'mpd_context_t'clamp ptr) v+ v = if b then 1 else 0+++-- # Flags++-- | Indicates error conditions. This type serves two purposes:+-- computations set flags to indicate errors, and flags indicate+-- which errors you want to have raise a signal. See 'getStatus',+-- 'setStatus', 'getTraps', and 'setTraps'.+--+-- 'Flag' is an instance of 'Exception' so that you can throw it if+-- you want; however, none of the functions in the @deka@ package+-- throw.+newtype Flag = Flag { unFlag :: Word32 }+ deriving (Eq, Ord, Typeable)++instance Exception Flag++instance Show Flag where+ show f+ | f == conversionSyntax = "Conversion syntax"+ | f == divisionByZero = "Division by zero"+ | f == divisionImpossible = "Division impossible"+ | f == divisionUndefined = "Division undefined"+ | f == inexact = "Inexact"+ | f == invalidContext = "Invalid context"+ | f == invalidOperation = "Invalid operation"+ | f == mallocError = "malloc error"+ | f == fpuError = "FPU error"+ | f == notImplemented = "Not implemented"+ | f == overflow = "Overflow"+ | f == clamped = "Clamped"+ | f == rounded = "Rounded"+ | f == subnormal = "Subnormal"+ | f == underflow = "Underflow"+ | otherwise = error "show flag: unrecognized flag"++-- | A container of 'Flag'.+newtype Flags = Flags { unFlags :: Word32 }+ deriving (Eq, Typeable)++instance Show Flags where+ show = show . unpackFlags++instance Exception Flags++-- | A list of all possible 'Flag', in order.+allFlag :: [Flag]+allFlag =+ [ clamped+ , conversionSyntax+ , divisionByZero+ , divisionImpossible+ , divisionUndefined+ , fpuError+ , inexact+ , invalidContext+ , invalidOperation+ , mallocError+ , notImplemented+ , overflow+ , rounded+ , subnormal+ , underflow+ ]++-- | All possible 'Flag' are set.+fullFlags :: Flags+fullFlags = packFlags allFlag++-- | No 'Flag' are set.+emptyFlags :: Flags+emptyFlags = Flags 0++-- | Flags will always be unpacked in order.+unpackFlags :: Flags -> [Flag]+unpackFlags (Flags i) = f allFlag+ where+ f [] = []+ f (Flag x:xs)+ | x .&. i /= 0 = Flag x : f xs+ | otherwise = f xs++packFlags :: [Flag] -> Flags+packFlags = Flags . foldl (.|.) 0 . map unFlag++-- | A source string (for instance, in 'fromByteString') contained+-- errors.+conversionSyntax :: Flag+conversionSyntax = Flag c'MPD_Conversion_syntax++-- | A non-zero dividend is divided by zero. Unlike @0/0@, it has a+-- defined result (a signed Infinity).+divisionByZero :: Flag+divisionByZero = Flag c'MPD_Division_by_zero++-- | Sometimes raised by 'divideInteger' and 'remainder'.+divisionImpossible :: Flag+divisionImpossible = Flag c'MPD_Division_impossible++-- | @0/0@ is undefined. It sets this flag and returns a quiet NaN.+divisionUndefined :: Flag+divisionUndefined = Flag c'MPD_Division_undefined++-- | One or more non-zero coefficient digits were discarded during+-- rounding.+inexact :: Flag+inexact = Flag c'MPD_Inexact++-- | The Context for computations was invalid; this error should+-- never occur because @deka@ keeps you from setting an invalid+-- context.+invalidContext :: Flag+invalidContext = Flag c'MPD_Invalid_context++-- | Raised on a variety of invalid operations, such as an attempt+-- to use 'compareSignal' on an operand that is an NaN.+invalidOperation :: Flag+invalidOperation = Flag c'MPD_Invalid_operation++mallocError :: Flag+mallocError = Flag c'MPD_Malloc_error++fpuError :: Flag+fpuError = Flag c'MPD_Fpu_error++notImplemented :: Flag+notImplemented = Flag c'MPD_Not_implemented++-- | The exponent of a result is too large to be represented.+overflow :: Flag+overflow = Flag c'MPD_Overflow++clamped :: Flag+clamped = Flag c'MPD_Clamped++rounded :: Flag+rounded = Flag c'MPD_Rounded++subnormal :: Flag+subnormal = Flag c'MPD_Subnormal++-- | A result is both subnormal and inexact.+underflow :: Flag+underflow = Flag c'MPD_Underflow++-- # Traps++-- ## Set++-- | If you set a trap, a computation will immediately raise+-- @SIGFPE@ if the corresponding error arises. (Currently this+-- behavior cannot be configured to do something else.)+-- 'setTraps' clears all existing traps and sets them to the new+-- ones you specify.+--+-- By setting a flag here, SIGFPE is raised if any subsequent+-- computations raise the corresponding error condition. Setting a+-- flag with this function or with 'setTrap' never, by itself,+-- causes SIGFPE to be raised; it is raised only by a subsequent+-- computation. So, if you set a flag using this function or+-- 'setTrap' and the corresponding status flag is already set,+-- SIGFPE will be raised only if a subsequent computation raises+-- that error condition.+setTraps :: Flags -> Ctx ()+setTraps fs = Ctx $ \ptr -> do+ let pTr = p'mpd_context_t'traps ptr+ poke pTr (unFlags fs) ++-- | Gets all currently set traps.+getTraps :: Ctx Flags+getTraps = Ctx $ \ptr -> do+ ts <- peek (p'mpd_context_t'traps ptr)+ return $ Flags ts++-- # Status++-- ## Set++-- | Sets status flags. All existing status flags are cleared and+-- replaced with the ones you indicate here.+setStatus :: Flags -> Ctx ()+setStatus fs = Ctx $ \ptr ->+ poke (p'mpd_context_t'status ptr) (unFlags fs)++-- | All currently set status flags.+getStatus :: Ctx Flags+getStatus = Ctx $ \ptr -> do+ let pSt = p'mpd_context_t'status ptr+ ts <- peek pSt+ return $ Flags ts++-- # Initializers++-- | Before running computations in a context. the context must be+-- initialized with certain settings, such as the rounding mode,+-- precision, and maximum adjusted exponent. An 'Initializer'+-- contains all these settings.+--+-- On 64-bit platforms, the maximums are:+--+-- * 'Precision' of ((1 * 10 ^ 18) - 1)+-- * 'Emax' of ((1 * 10 ^ 18) - 1)+-- * 'Emin' of -((1 * 10 ^ 18) - 1)+--+-- On 32-bit platforms, the maximums are:+--+-- * 'Precision' of 4.25 * 10 ^ 8+-- * 'Emax' of 4.25 * 10 ^ 8+-- * 'Emin' of -4.25 * 10 ^ 8++data Initializer+ = Max+ -- ^ Sets:+ --+ -- * 'Precision' to the maximum available+ -- * 'Emax' to the maximum available+ -- * 'Emin' to the minimum available+ -- * 'Round' to 'roundHalfEven'+ -- * Traps to 'invalidOperation', 'divisionByZero', 'overflow',+ -- 'underflow'+ -- * No status flags are set+ -- * No newtrap is set+ -- * 'setClamp' is False+ -- * 'setAllCorrectRound' is True+ --+ -- As noted in the documentation for 'Trio', the specification+ -- requires that @'Emax' > 5 * 'Precision'@; 'Max' does /not/+ -- respect this.++ | Default+ -- ^ Same as 'Max', except:+ --+ -- * Precision is @2 * MPD_RDIGITS@++ | Basic+ -- ^ Same as 'Max', except:+ --+ -- * 'Precision' is 9+ -- * Traps to 'invalidOperation', 'divisionByZero', 'overflow',+ -- 'underflow', and 'clamped'++ | Pedantic+ -- ^ Sets the maximum allowable figures, while respecting the+ -- restriction that stated in the specification and the @mpdecimal@+ -- documentation, which is that @'Emax' > 5 * 'Precision'@. Also,+ -- sets no traps. This sets:+ --+ -- * 'Emax' to the maximum available+ -- * 'Emin' to the minimum available+ --+ -- * 'Precision' is set to @'Emax' `div` 5@. On 64-bit platforms,+ -- this is ((2 * 10 ^ 17) - 1); on 32-bit platforms, this is 8.5 *+ -- 10 ^ 8.+ --+ -- * 'Round' to 'roundHalfEven'+ -- * No traps are set+ -- * No status flags are set+ -- * No newtrap is set+ -- * 'setClamp' is False+ -- * 'setAllCorrectRound' is True++ | Decimal32+ -- ^ Sets:+ --+ -- * 'Precision' to @7@+ -- * 'Emax' to @96@+ -- * 'Emin' to @-95@+ -- * Rounding to 'roundHalfEven'+ -- * No traps are enabled+ -- * No status flags are set+ -- 'newTrap' is clear+ -- * 'setClamp' is True+ -- * 'setAllCorrectRound' is True++ | Decimal64+ -- ^ Same as 'Decimal32', except:+ --+ -- * 'Precision' is @16@+ -- * 'Emax' is @384@+ -- * 'Emin' is @-383@++ | Decimal128+ -- ^ Same as 'Decimal32', except:+ --+ -- * 'Precision' is @34@+ -- * 'Emax' is @6144@+ -- * 'Emin' is @-6143@++-- | Re-initialize a 'Ctx' using the given Initializer.+initCtx :: Initializer -> Ctx ()+initCtx i = Ctx $ \p ->+ case i of+ Max -> c'mpd_maxcontext p+ Default -> c'mpd_defaultcontext p+ Basic -> c'mpd_basiccontext p+ Pedantic -> unCtx pedantic p+ Decimal32 -> c'mpd_ieee_context p 32 >> return ()+ Decimal64 -> c'mpd_ieee_context p 64 >> return ()+ Decimal128 -> c'mpd_ieee_context p 128 >> return ()++clearStatus :: Ctx ()+clearStatus = Ctx $ \p -> poke (p'mpd_context_t'status p) 0++clearNewtrap :: Ctx ()+clearNewtrap = Ctx $ \p -> poke (p'mpd_context_t'newtrap p) 0++pedantic :: Ctx ()+pedantic = do+ setEmax maxBound+ setEmin minBound+ let pc = Precision $ ((unEmax maxBound) `div` 5)+ setPrecision pc+ setRound roundHalfEven+ setTraps emptyFlags+ clearStatus+ clearNewtrap+ setClamp False+ setAllCorrectRound True++-- # allCorrectRound++-- | By default, most functions are correctly rounded. By setting+-- allCorrectRound, correct rounding is additionally enabled for+-- exp, ln, and log10. In this case, all functions except pow and+-- invroot return correctly rounded results.+getAllCorrectRound :: Ctx Bool+getAllCorrectRound = Ctx $ fmap (/= 0) . peek . p'mpd_context_t'allcr++setAllCorrectRound :: Bool -> Ctx ()+setAllCorrectRound b = Ctx f+ where+ f ptr = poke (p'mpd_context_t'allcr ptr) v+ v = if b then 1 else 0++-- # Runners++-- | Runs a Ctx computation; begins with the given Initializer to+-- set up the context.+runCtxInit :: Initializer -> Ctx a -> a+runCtxInit i (Ctx f) = unsafePerformIO $ do+ fp <- mallocForeignPtrBytes c'mpd_context_t'sizeOf+ withForeignPtr fp $ \ptr -> do+ _ <- unCtx (initCtx i) ptr+ f ptr++-- | Runs a Ctx computation using the 'Pedantic' Initializer.+runCtx :: Ctx a -> a+runCtx = runCtxInit Pedantic++-- | Like 'runCtx' but also returns any status flags resulting from+-- the computation.+runCtxStatus :: Ctx a -> (a, Flags)+runCtxStatus c = runCtx $ do+ r <- c+ f <- getStatus+ return (r, f)++-- # Local++-- | Runs a Ctx computation within the existing Ctx. The existing+-- Ctx is copied to form a new Ctx; then the child computation is+-- run without affecting the parent Ctx.++local+ :: Ctx a+ -- ^ Run this computation. It is initialized with the current+ -- Ctx, but does not affect the current Ctx.+ -> Ctx a+ -- ^ Returns the result of the child computation.+local (Ctx l) = Ctx $ \parent ->+ allocaBytes (c'mpd_context_t'sizeOf) $ \child ->+ copyBytes child parent c'mpd_context_t'sizeOf >>+ l child+
+ internal/Deka/Internal/Dec/Ctx.hs view
@@ -0,0 +1,364 @@+{-# LANGUAGE Safe, OverloadedStrings #-}+module Deka.Internal.Dec.Ctx where++import qualified Data.ByteString.Char8 as BS8+import Deka.Internal.Context+import Deka.Internal.Mpdec+import Deka.Internal.Util.Ctx+import Data.String++-- | Converts a character string to a 'Dec'. Implements the+-- _to-number_ conversion from the General Decimal Arithmetic+-- specification.+--+-- The conversion is exact provided that the numeric string has no+-- more significant digits than are specified in the 'Precision' in+-- the 'Ctx' and the adjusted exponent is in the range specified by+-- 'Emin' and 'Emax' in the 'Ctx'. If there are more than+-- 'Precision' digits in the string, or the exponent is out of+-- range, the value will be rounded as necessary using the 'Round'+-- rounding mode. The 'Precision' therefore both determines the+-- maximum precision for unrounded numbers and defines the minimum+-- size of the 'Dec' structure required.+--+-- Possible errors are 'conversionSyntax' (the string does not have+-- the syntax of a number, which depends on 'setExtended' in the+-- 'Ctx'), 'overflow' (the adjusted exponent of the number is larger+-- than 'Emax'), or 'underflow' (the adjusted exponent is less than+-- 'Emin' and the conversion is not exact). If any of these+-- conditions are set, the number structure will have a defined+-- value as described in the arithmetic specification (this may be a+-- subnormal or infinite value).++fromByteString :: BS8.ByteString -> Ctx Dec+fromByteString bs = Ctx $ \pCtx ->+ newDec $ \dn ->+ BS8.useAsCString bs $ \cstr ->+ c'mpd_set_string dn cstr pCtx++-- | Returns the absolute value. The same effect as 'plus' unless+-- the operand is negative, in which case it is the same as 'minus'.+abs :: Dec -> Ctx Dec+abs = unary c'mpd_abs++-- | Addition.+add :: Dec -> Dec -> Ctx Dec+add = binary c'mpd_add++-- | Digit-wise logical @and@.+and :: Dec -> Dec -> Ctx Dec+and = binary c'mpd_and++-- | @compare x y@ returns @-1@ if a is less than b, 0 if a is equal+-- to b, and 1 if a is greater than b. 'invalidOperation' is set if+-- at least one of the operands is a signaling NaN.+compare :: Dec -> Dec -> Ctx Dec+compare = binary c'mpd_compare++-- | Identical to 'Deka.Dec.compare' except that all NaNs+-- (including quiet NaNs) set the 'invalidOperation' condition.+compareSignal :: Dec -> Dec -> Ctx Dec+compareSignal = binary c'mpd_compare_signal++-- | Division.+divide :: Dec -> Dec -> Ctx Dec+divide = binary c'mpd_div++-- | Returns the integer part of the result of division. It must be+-- possible to express the result as an integer. That is, it must+-- have no more digits than 'Precision' in the 'Ctx'. If it does+-- then 'divisionImpossible' is raised.+divideInteger :: Dec -> Dec -> Ctx Dec+divideInteger = binary c'mpd_divint++-- | Exponentiation. Result is rounded if necessary using the+-- 'Precision' in the 'Ctx' and using the 'roundHalfEven' rounding+-- method.+--+-- Finite results will always be full precision and inexact, except+-- when rhs is a zero or -Infinity (giving 1 or 0 respectively).+-- Inexact results will almost always be correctly rounded, but may+-- be up to 1 ulp (unit in last place) in error in rare cases.+--+-- This is a mathematical function; the @10 ^ 6@ restrictions on+-- precision and range apply as described above.+exp :: Dec -> Ctx Dec+exp = unary c'mpd_exp++-- | @fma x y z@ multiplies @x@ by @y@ and then adds @z@ to that+-- intermediate result. It is equivalent to a multiplication+-- followed by an addition except that the intermediate result is+-- not rounded and will not cause overflow or underflow. That is,+-- only the final result is rounded and checked.+--+-- This is a mathematical function; the @10 ^ 6@ restrictions on+-- precision and range apply as described above.+fma :: Dec -> Dec -> Dec -> Ctx Dec+fma = ternary c'mpd_fma++-- | Digit-wise inversion (a @0@ becomes a @1@ and vice versa).+invert :: Dec -> Ctx Dec+invert = unary c'mpd_invert++-- | Natural logarithm. Results are correctly rounded if+-- 'setAllCorrectRound' is True.+ln :: Dec -> Ctx Dec+ln = unary c'mpd_ln++-- | Returns the adjusted exponent of the operand, according to the+-- rules for @logB@ of IEEE 754. This returns the exponent of the+-- operand as though its decimal point had been moved to follow the+-- first digit while keeping the same value. The result is not+-- limited by 'Emin' or 'Emax'.++-- | If operand is an NaN, the general rules apply. If operand is+-- infinite, the result is +Infinity. If operand is zero, result is+-- -Infinity and 'invalidOperation' is set. Otherwise, the result+-- is the same as the adjusted exponent of the operand, or+-- @floor(log10(a))@ where @a@ is the operand.+logB :: Dec -> Ctx Dec+logB = unary c'mpd_logb++-- | Base 10 logarithm. Results are correctly rounded if+-- 'setAllCorrectRound' is True.+log10 :: Dec -> Ctx Dec+log10 = unary c'mpd_log10++-- | Compares two numbers numerically and returns the larger. If+-- the numbers compare equal then number is chosen with regard to+-- sign and exponent. Unusually, if one operand is a quiet NaN and+-- the other a number, then the number is returned.+max :: Dec -> Dec -> Ctx Dec+max = binary c'mpd_max++-- | Compares the magnitude of two numbers numerically and sets+-- number to the larger. It is identical to 'Deka.Dec.max' except+-- that the signs of the operands are ignored and taken to be 0+-- (non-negative).+maxMag :: Dec -> Dec -> Ctx Dec+maxMag = binary c'mpd_max_mag++-- | Compares two numbers numerically and sets number to the+-- smaller. If the numbers compare equal then number is chosen with+-- regard to sign and exponent. Unusually, if one operand is a quiet+-- NaN and the other a number, then the number is returned.+min :: Dec -> Dec -> Ctx Dec+min = binary c'mpd_min++-- | Compares the magnitude of two numbers numerically and sets+-- number to the smaller. It is identical to 'Deka.Dec.min' except+-- that the signs of the operands are ignored and taken to be 0+-- (non-negative).+minMag :: Dec -> Dec -> Ctx Dec+minMag = binary c'mpd_min_mag++-- | Returns the result of subtracting the operand from zero. hat+-- is, it is negated, following the usual arithmetic rules; this may+-- be used for implementing a prefix minus operation.+minus :: Dec -> Ctx Dec+minus = unary c'mpd_minus++-- | Multiplication.+multiply :: Dec -> Dec -> Ctx Dec+multiply = binary c'mpd_mul++-- | Digit-wise logical inclusive or.+or :: Dec -> Dec -> Ctx Dec+or = binary c'mpd_or++-- | Returns the result of adding the operand to zero. This takes+-- place according to the settings given in the 'Ctx', following the+-- usual arithmetic rules. This may therefore be used for rounding+-- or for implementing a prefix plus operation.+plus :: Dec -> Ctx Dec+plus = unary c'mpd_plus++-- | @power b e@ returns @b@ raised to the power of @e@. Integer+-- powers are exact, provided that the result is finite and fits+-- into 'Precision'.+--+-- Results are not correctly rounded, even if 'setAllCorrectRound'+-- is True. The error of the function is less than @1ULP + t@,+-- where @t@ has a maximum of @0.1ULP@, but is almost always less+-- than @0.001ULP@.++power :: Dec -> Dec -> Ctx Dec+power = binary c'mpd_pow++-- | @quantize a b@ returns the number that is equal in value to+-- @a@, but has the exponent of @b@.+quantize :: Dec -> Dec -> Ctx Dec+quantize = binary c'mpd_quantize++-- overflow/underflow checks, returns @a@ in its simplest form with+-- all trailing zeros removed.+reduce :: Dec -> Ctx Dec+reduce = unary c'mpd_reduce++-- | @remainder a b@ returns the remainder of @a / b@.+remainder :: Dec -> Dec -> Ctx Dec+remainder = binary c'mpd_rem++-- | @remainderNear a b@ returns @a - b * n@, where @n@ is the+-- integer nearest the exact value of @a / b@. If two integers are+-- equally near then the even one is chosen.+remainderNear :: Dec -> Dec -> Ctx Dec+remainderNear = binary c'mpd_rem_near++-- | @rescale a b@ returns the number that is equal in value+-- to @a@, but has the exponent @b@. Special numbers are copied+-- without signaling. This function is not part of the General+-- Decimal Arithmetic Specification. It+-- is also not equivalent to the rescale function that was removed+-- from the specification.++rescale :: Dec -> Signed -> Ctx Dec+rescale a b = Ctx $ \p -> newDec $ \r ->+ withDec a $ \pa ->+ c'mpd_rescale r pa b p++-- | @rotate x y@ returns @x@ rotated by @y@ places. @y@ must be in+-- the range [-'Precision', 'Precision']. A negative @y@ indicates a+-- right rotation, a positive @y@ a left rotation.++rotate :: Dec -> Dec -> Ctx Dec+rotate = binary c'mpd_rotate++-- | @scaleB a b@ - b must be an integer with exponent 0. If @a@ is+-- infinite, returns @a@. Otherwise, returns @a@ with the+-- value of @b@ added to the exponent.++scaleB :: Dec -> Dec -> Ctx Dec+scaleB = binary c'mpd_scaleb++-- | @shift a b@ returns @a@ shifted by @b@ places. @b@ must be in+-- the range [-'Precision', 'Precision']. A negative @b@ indicates a+-- right shift, a positive @b@ a left shift. Digits that do not fit+-- are discarded.++shift :: Dec -> Dec -> Ctx Dec+shift = binary c'mpd_shift++-- | Returns the square root. This function is always correctly+-- rounded using the 'roundHalfEven' method.++squareRoot :: Dec -> Ctx Dec+squareRoot = unary c'mpd_sqrt++-- | Returns the reciprocal of the square root. This function+-- always uses 'roundHalfEven'. Results are not correctly rounded+-- even if 'setAllCorrectRound' is True.++inverseSquareRoot :: Dec -> Ctx Dec+inverseSquareRoot = unary c'mpd_invroot+++-- | Subtraction.++subtract :: Dec -> Dec -> Ctx Dec+subtract = binary c'mpd_sub++-- | Round to an integer, using the rounding mode of the context.+-- Only a signaling NaN causes an 'invalidOperation'+-- condition.++toIntegralExact :: Dec -> Ctx Dec+toIntegralExact = unary c'mpd_round_to_intx++-- | Like 'toIntegralExact', but 'inexact' and 'rounded' are never+-- set.+toIntegralValue :: Dec -> Ctx Dec+toIntegralValue = unary c'mpd_round_to_int++floor :: Dec -> Ctx Dec+floor = unary c'mpd_floor++ceiling :: Dec -> Ctx Dec+ceiling = unary c'mpd_ceil++truncate :: Dec -> Ctx Dec+truncate = unary c'mpd_trunc++-- | Digit-wise logical exclusive or.++xor :: Dec -> Dec -> Ctx Dec+xor = binary c'mpd_xor++-- | Returns the closest representable number that is smaller than+-- the operand.+nextMinus :: Dec -> Ctx Dec+nextMinus = unary c'mpd_next_minus++-- | Returns the closest representable number that is larger than+-- the operand.+nextPlus :: Dec -> Ctx Dec+nextPlus = unary c'mpd_next_plus++-- | @nextToward a b@ returns the representable number closest to+-- @a@ in the direction of @b@.++nextToward :: Dec -> Dec -> Ctx Dec+nextToward = binary c'mpd_next_toward++toBool :: Integral a => a -> Bool+toBool i+ | i == 0 = False+ | otherwise = True++-- | False if the decimal is special or zero, or the exponent is+-- less than 'Emin'. True otherwise.++isNormal :: Dec -> Ctx Bool+isNormal d = Ctx $ \p ->+ withDec d $ \pd ->+ c'mpd_isnormal pd p >>= \i ->+ return (toBool i)++-- | False if the decimal is special or zero, or the exponent is+-- greater or equal to 'Emin'. True otherwise.+isSubnormal :: Dec -> Ctx Bool+isSubnormal d = Ctx $ \p ->+ withDec d $ \pd ->+ c'mpd_issubnormal pd p >>= \i ->+ return (toBool i)++data PosNeg = Pos | Neg+ deriving (Eq, Ord, Show)++data Number+ = Infinity+ | Normal+ | Subnormal+ | Zero+ deriving (Eq, Ord, Show)++data Class+ = SNaN+ | NaN+ | Number PosNeg Number+ deriving (Eq, Ord, Show)++strToClass :: IsString a => [(a, Class)]+strToClass =+ [ ("sNaN", SNaN)+ , ("NaN", NaN)+ , ("-Infinity", Number Neg Infinity)+ , ("-Normal", Number Neg Normal)+ , ("-Subnormal", Number Neg Subnormal)+ , ("-Zero", Number Neg Zero)+ , ("+Zero", Number Pos Zero)+ , ("+Subnormal", Number Pos Subnormal)+ , ("+Normal", Number Pos Normal)+ , ("+Infinity", Number Pos Infinity)+ ]++-- | Determines the 'Class' of a 'Dec'.++numClass :: Dec -> Ctx Class+numClass d = Ctx $ \pCtx ->+ withDec d $ \pd ->+ c'mpd_class pd pCtx >>= \chars ->+ BS8.packCString chars >>= \bs ->+ return . maybe (error "numClass: class not found") id+ . lookup bs $ strToClass+
+ internal/Deka/Internal/Dec/CtxFree.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE EmptyDataDecls, Trustworthy #-}++module Deka.Internal.Dec.CtxFree where++import Foreign.Safe+import qualified Data.ByteString.Char8 as BS8+import Prelude+import Foreign.C.Types+import Deka.Internal.Mpdec+import System.IO.Unsafe (unsafePerformIO)++numToOrd :: (Num a, Ord a) => a -> Ordering+numToOrd a+ | a < 0 = LT+ | a > 0 = GT+ | otherwise = EQ++-- | @compareTotal x y@ compares to numbers using the IEEE 754 total+-- ordering. If @x@ is less+-- than @y@, returns @-1@. If they are equal (that is, when+-- subtracted the result would be 0), returns @0@. If @y@ is+-- greater than @x@, returns @1@. +--+-- Here is the total ordering:+--+-- @-NaN < -sNaN < -Infinity < -finites < -0 < +0 < +finites+-- < +Infinity < +SNaN < +NaN@+--+-- Also, @1.000@ < @1.0@ (etc.) and NaNs are ordered by payload.+compareTotal :: Dec -> Dec -> Ordering+compareTotal x y = unsafePerformIO $+ withDec x $ \px ->+ withDec y $ \py ->+ c'mpd_cmp_total px py >>= \i ->+ return (numToOrd i)++-- | Same as 'compareTotal' except that the signs of the operands+-- are ignored and taken to be 0 (non-negative).++compareTotalMag :: Dec -> Dec -> Ordering+compareTotalMag x y = unsafePerformIO $+ withDec x $ \px ->+ withDec y $ \py ->+ c'mpd_cmp_total_mag px py >>= \i ->+ return (numToOrd i)++-- | Converts a number to engineering notation.+toEngByteString :: Dec -> BS8.ByteString+toEngByteString dn = unsafePerformIO $+ withDec dn $ \pDn ->+ c'mpd_to_eng pDn capitalize >>= \bytes ->+ BS8.packCString bytes >>= \bs ->+ free bytes >>= \_ ->+ return bs++-- | Converts a number to scientific notation.+toByteString :: Dec -> BS8.ByteString+toByteString dn = unsafePerformIO $+ withDec dn $ \pDn ->+ c'mpd_to_sci pDn capitalize >>= \bytes ->+ BS8.packCString bytes >>= \bs ->+ free bytes >>= \_ ->+ return bs++-- | True if both operands have the same exponent; False otherwise.+sameQuantum :: Dec -> Dec -> Bool+sameQuantum x y = unsafePerformIO $+ withDec x $ \px ->+ withDec y $ \py ->+ c'mpd_same_quantum px py >>= \r ->+ return $ if r == 0 then False else True++version :: BS8.ByteString+version = c'MPD_VERSION++testBool+ :: (CMpd -> IO CInt)+ -> Dec+ -> Bool+testBool f d = unsafePerformIO $+ withDec d $ \pd ->+ f pd >>= \bl ->+ return (toBool bl)++isFinite :: Dec -> Bool+isFinite = testBool c'mpd_isfinite++isInfinite :: Dec -> Bool+isInfinite = testBool c'mpd_isinfinite++isNaN :: Dec -> Bool+isNaN = testBool c'mpd_isnan++isNegative :: Dec -> Bool+isNegative = testBool c'mpd_isnegative++isPositive :: Dec -> Bool+isPositive = testBool c'mpd_ispositive++isSigned :: Dec -> Bool+isSigned = testBool c'mpd_issigned++isQNaN :: Dec -> Bool+isQNaN = testBool c'mpd_isqnan++isSNaN :: Dec -> Bool+isSNaN = testBool c'mpd_issnan++isSpecial :: Dec -> Bool+isSpecial = testBool c'mpd_isspecial++isZero :: Dec -> Bool+isZero = testBool c'mpd_iszero++isZeroCoeff :: Dec -> Bool+isZeroCoeff = testBool c'mpd_iszerocoeff++isOddCoeff :: Dec -> Bool+isOddCoeff = testBool c'mpd_isoddcoeff++-- | The sign of a number.+data Sign+ = Sign0+ -- ^ A sign of zero; used for positive numbers and for zero.++ | Sign1+ -- ^ A sign of one; used for negative numbers and the negative+ -- zero.+ deriving (Eq, Ord, Show)++sign :: Dec -> Sign+sign d = unsafePerformIO $+ withDec d $ \pd ->+ c'mpd_sign pd >>= \i ->+ return $ if i == 0 then Sign0 else Sign1++data EvenOdd = Even | Odd+ deriving (Eq, Show)++evenOdd :: Dec -> (Maybe EvenOdd)+evenOdd d = unsafePerformIO $+ withDec d $ \pd ->+ c'mpd_isinteger pd >>= \isint ->+ if isint /= 0+ then c'mpd_isodd pd >>= \oddR ->+ return $ if oddR == 0 then Just Even else Just Odd+ else return Nothing+
+ internal/Deka/Internal/Mpdec.hsc view
@@ -0,0 +1,838 @@+{-# LANGUAGE EmptyDataDecls, Safe #-}+{-# LANGUAGE OverloadedStrings #-}+#include <mpdecimal.h>++#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)++module Deka.Internal.Mpdec+ ( + -- * Context+ Signed+ , Unsigned+ , C'mpd_context_t+ , c'MPD_VERSION+ , c'MPD_SSIZE_MAX+ , c'MPD_SSIZE_MIN+ , c'MPD_MAX_PREC+ , c'MPD_MAX_EMAX+ , c'MPD_MIN_EMIN+ , c'MPD_ROUND_UP+ , c'MPD_ROUND_DOWN+ , c'MPD_ROUND_CEILING+ , c'MPD_ROUND_FLOOR+ , c'MPD_ROUND_HALF_UP+ , c'MPD_ROUND_HALF_DOWN+ , c'MPD_ROUND_HALF_EVEN+ , c'MPD_ROUND_05UP+ , c'MPD_ROUND_TRUNC+ , c'mpd_context_t'sizeOf+ , p'mpd_context_t'prec+ , p'mpd_context_t'emax+ , p'mpd_context_t'emin+ , p'mpd_context_t'traps+ , p'mpd_context_t'status+ , p'mpd_context_t'newtrap+ , p'mpd_context_t'round+ , p'mpd_context_t'clamp+ , p'mpd_context_t'allcr+ , c'MPD_Clamped+ , c'MPD_Conversion_syntax+ , c'MPD_Division_by_zero+ , c'MPD_Division_impossible+ , c'MPD_Division_undefined+ , c'MPD_Fpu_error+ , c'MPD_Inexact+ , c'MPD_Invalid_context+ , c'MPD_Invalid_operation+ , c'MPD_Malloc_error+ , c'MPD_Not_implemented+ , c'MPD_Overflow+ , c'MPD_Rounded+ , c'MPD_Subnormal+ , c'MPD_Underflow+ , c'mpd_maxcontext+ , c'mpd_defaultcontext+ , c'mpd_basiccontext+ , c'mpd_ieee_context++ -- * Mpdec+ , CMpd+ , Mpd+ , Dec+ , withDec+ , newDec+ , newDec2+ , c'divmod+ , c'mpd_fma+ , c'mpd_powmod+ , c'mpd_adjexp+ , capitalize+ , c'mpd_to_sci+ , c'mpd_to_eng+ , c'mpd_set_string+ , c'mpd_compare_total+ , c'mpd_cmp_total+ , c'mpd_compare_total_mag+ , c'mpd_cmp_total_mag+ , c'mpd_same_quantum+ , c'mpd_class+ , c'mpd_isnormal+ , c'mpd_issubnormal+ , c'mpd_sign+ , c'mpd_arith_sign+ , c'mpd_trail_zeros+ , c'mpd_del+ , c'mpd_copy+ , c'mpd_copy_abs+ , c'mpd_copy_negate+ , c'mpd_invert+ , c'mpd_logb+ , c'mpd_abs+ , c'mpd_exp+ , c'mpd_ln+ , c'mpd_log10+ , c'mpd_minus+ , c'mpd_next_minus+ , c'mpd_next_plus+ , c'mpd_plus+ , c'mpd_reduce+ , c'mpd_round_to_intx+ , c'mpd_round_to_int+ , c'mpd_trunc+ , c'mpd_floor+ , c'mpd_ceil+ , c'mpd_sqrt+ , c'mpd_invroot+ , c'mpd_and+ , c'mpd_copy_sign+ , c'mpd_or+ , c'mpd_rotate+ , c'mpd_scaleb+ , c'mpd_shift+ , c'mpd_xor+ , c'mpd_compare+ , c'mpd_compare_signal+ , c'mpd_add+ , c'mpd_sub+ , c'mpd_div+ , c'mpd_divint+ , c'mpd_max+ , c'mpd_max_mag+ , c'mpd_min+ , c'mpd_min_mag+ , c'mpd_mul+ , c'mpd_next_toward+ , c'mpd_pow+ , c'mpd_quantize+ , c'mpd_rescale+ , c'mpd_rem+ , c'mpd_rem_near+ , c'mpd_isfinite+ , c'mpd_isinfinite+ , c'mpd_isinteger+ , c'mpd_isnan+ , c'mpd_isnegative+ , c'mpd_ispositive+ , c'mpd_isqnan+ , c'mpd_issnan+ , c'mpd_issigned+ , c'mpd_isspecial+ , c'mpd_iszero+ , c'mpd_iszerocoeff+ , c'mpd_isoddcoeff+ , c'mpd_isodd+ , c'mpd_iseven+ ) where++import Foreign.Safe+import Foreign.C+import Control.Monad+import Data.String++c'MPD_VERSION :: IsString a => a+c'MPD_VERSION = #const_str MPD_VERSION++-- | An unsigned integer. Its size is platform dependent.+type Unsigned = #type mpd_size_t++-- | A signed integer. Its size is platform dependent.+type Signed = #type mpd_ssize_t++c'MPD_SSIZE_MAX :: Signed+c'MPD_SSIZE_MAX = #const MPD_SSIZE_MAX++-- Must convert the constant to an Integer first; it will overflow+-- otherwise. GHC's NegativeLiterals extension solves this problem,+-- but it is not available on GHC < 7.8.+c'MPD_SSIZE_MIN :: Signed+c'MPD_SSIZE_MIN = fromInteger $ #const MPD_SSIZE_MIN++c'MPD_MAX_PREC :: Signed+c'MPD_MAX_PREC = #const MPD_MAX_PREC++c'MPD_MAX_EMAX :: Signed+c'MPD_MAX_EMAX = #const MPD_MAX_EMAX++c'MPD_MIN_EMIN :: Signed+c'MPD_MIN_EMIN = #const MPD_MIN_EMIN++c'MPD_ROUND_UP :: CInt+c'MPD_ROUND_UP = #const MPD_ROUND_UP++c'MPD_ROUND_DOWN :: CInt+c'MPD_ROUND_DOWN = #const MPD_ROUND_DOWN++c'MPD_ROUND_CEILING :: CInt+c'MPD_ROUND_CEILING = #const MPD_ROUND_CEILING++c'MPD_ROUND_FLOOR :: CInt+c'MPD_ROUND_FLOOR = #const MPD_ROUND_FLOOR++c'MPD_ROUND_HALF_UP :: CInt+c'MPD_ROUND_HALF_UP = #const MPD_ROUND_HALF_UP++c'MPD_ROUND_HALF_DOWN :: CInt+c'MPD_ROUND_HALF_DOWN = #const MPD_ROUND_HALF_DOWN++c'MPD_ROUND_HALF_EVEN :: CInt+c'MPD_ROUND_HALF_EVEN = #const MPD_ROUND_HALF_EVEN++c'MPD_ROUND_05UP :: CInt+c'MPD_ROUND_05UP = #const MPD_ROUND_05UP++c'MPD_ROUND_TRUNC :: CInt+c'MPD_ROUND_TRUNC = #const MPD_ROUND_TRUNC++data C'mpd_context_t++c'mpd_context_t'sizeOf :: Int+c'mpd_context_t'sizeOf = #size mpd_context_t++p'mpd_context_t'prec :: Ptr C'mpd_context_t -> Ptr Signed+p'mpd_context_t'prec = #ptr mpd_context_t, prec++p'mpd_context_t'emax :: Ptr C'mpd_context_t -> Ptr Signed+p'mpd_context_t'emax = #ptr mpd_context_t, emax++p'mpd_context_t'emin :: Ptr C'mpd_context_t -> Ptr Signed+p'mpd_context_t'emin = #ptr mpd_context_t, emin++p'mpd_context_t'traps :: Ptr C'mpd_context_t -> Ptr Word32+p'mpd_context_t'traps = #ptr mpd_context_t, traps++p'mpd_context_t'status :: Ptr C'mpd_context_t -> Ptr Word32+p'mpd_context_t'status = #ptr mpd_context_t, status++p'mpd_context_t'newtrap :: Ptr C'mpd_context_t -> Ptr Word32+p'mpd_context_t'newtrap = #ptr mpd_context_t, newtrap++p'mpd_context_t'round :: Ptr C'mpd_context_t -> Ptr CInt+p'mpd_context_t'round = #ptr mpd_context_t, round++p'mpd_context_t'clamp :: Ptr C'mpd_context_t -> Ptr CInt+p'mpd_context_t'clamp = #ptr mpd_context_t, clamp++p'mpd_context_t'allcr :: Ptr C'mpd_context_t -> Ptr CInt+p'mpd_context_t'allcr = #ptr mpd_context_t, allcr++c'MPD_Clamped :: Word32+c'MPD_Clamped = #const MPD_Clamped++c'MPD_Conversion_syntax :: Word32+c'MPD_Conversion_syntax = #const MPD_Conversion_syntax++c'MPD_Division_by_zero :: Word32+c'MPD_Division_by_zero = #const MPD_Division_by_zero++c'MPD_Division_impossible :: Word32+c'MPD_Division_impossible = #const MPD_Division_impossible++c'MPD_Division_undefined :: Word32+c'MPD_Division_undefined = #const MPD_Division_undefined++c'MPD_Fpu_error :: Word32+c'MPD_Fpu_error = #const MPD_Fpu_error++c'MPD_Inexact :: Word32+c'MPD_Inexact = #const MPD_Inexact++c'MPD_Invalid_context :: Word32+c'MPD_Invalid_context = #const MPD_Invalid_context++c'MPD_Invalid_operation :: Word32+c'MPD_Invalid_operation = #const MPD_Invalid_operation++c'MPD_Malloc_error :: Word32+c'MPD_Malloc_error = #const MPD_Malloc_error++c'MPD_Not_implemented :: Word32+c'MPD_Not_implemented = #const MPD_Not_implemented++c'MPD_Overflow :: Word32+c'MPD_Overflow = #const MPD_Overflow++c'MPD_Rounded :: Word32+c'MPD_Rounded = #const MPD_Rounded++c'MPD_Subnormal :: Word32+c'MPD_Subnormal = #const MPD_Subnormal++c'MPD_Underflow :: Word32+c'MPD_Underflow = #const MPD_Underflow++foreign import ccall unsafe "mpd_maxcontext" c'mpd_maxcontext+ :: Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_defaultcontext" c'mpd_defaultcontext+ :: Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_basiccontext" c'mpd_basiccontext+ :: Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_ieee_context" c'mpd_ieee_context+ :: Ptr C'mpd_context_t+ -> CInt+ -> IO CInt++--+-- mpd_t+--++data C'mpd_t++newtype CMpd = CMpd { _unCMpd :: Ptr C'mpd_t }+newtype Mpd = Mpd { unMpd :: Ptr C'mpd_t }++-- | A decimal value. A decimal consists of:+--+-- * an integral /coefficient/,+--+-- * an /exponent/, and+--+-- * a /sign/.+--+-- A decimal may also be a /special value/, which can be:+--+-- * /NaN/ (Not a Number), which may be either /quiet/+-- (propagates quietly through operations) or /signaling/ (raises+-- the /Invalid operation/ condition when encountered), or+--+-- * /Infinity/, either positive or negative.++newtype Dec = Dec { _unDec :: ForeignPtr C'mpd_t }++withDec :: Dec -> (CMpd -> IO a) -> IO a+withDec (Dec fp) f =+ withForeignPtr fp $ \ptr ->+ f (CMpd ptr)++-- Irregular arithmetics++foreign import ccall unsafe "mpd_divmod" c'divmod+ :: Mpd+ -> Mpd+ -> CMpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_fma" c'mpd_fma+ :: Mpd+ -> CMpd+ -> CMpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_powmod" c'mpd_powmod+ :: Mpd+ -> CMpd+ -> CMpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_adjexp" c'mpd_adjexp+ :: CMpd+ -> IO Signed++-- Output to string++foreign import ccall unsafe "mpd_to_sci" c'mpd_to_sci+ :: CMpd+ -> CInt+ -> IO (Ptr CChar)++-- | Set to 1 to capitalize the exponent character; otherwise, if it+-- is 0, the exponent character is lower case.+capitalize :: CInt+capitalize = 1++foreign import ccall unsafe "mpd_to_eng" c'mpd_to_eng+ :: CMpd+ -> CInt+ -> IO (Ptr CChar)++foreign import ccall unsafe "mpd_set_string" c'mpd_set_string+ :: Mpd+ -> Ptr CChar+ -> Ptr C'mpd_context_t+ -> IO ()++-- comparisons++-- compare_total is context free+foreign import ccall unsafe "mpd_compare_total" c'mpd_compare_total+ :: Mpd+ -> CMpd+ -> CMpd+ -> IO CInt++foreign import ccall unsafe "mpd_cmp_total" c'mpd_cmp_total+ :: CMpd+ -> CMpd+ -> IO CInt++-- total_mag is context free+foreign import ccall unsafe "mpd_compare_total_mag" c'mpd_compare_total_mag+ :: Mpd+ -> CMpd+ -> CMpd+ -> IO CInt++foreign import ccall unsafe "mpd_cmp_total_mag" c'mpd_cmp_total_mag+ :: CMpd+ -> CMpd+ -> IO CInt++foreign import ccall unsafe "mpd_same_quantum" c'mpd_same_quantum+ :: CMpd+ -> CMpd+ -> IO CInt++-- Tests++foreign import ccall unsafe "mpd_class" c'mpd_class+ :: CMpd+ -> Ptr C'mpd_context_t+ -> IO (Ptr CChar)++foreign import ccall unsafe "mpd_isnormal" c'mpd_isnormal+ :: CMpd+ -> Ptr C'mpd_context_t+ -> IO CInt++foreign import ccall unsafe "mpd_issubnormal" c'mpd_issubnormal+ :: CMpd+ -> Ptr C'mpd_context_t+ -> IO CInt++foreign import ccall unsafe "mpd_sign" c'mpd_sign+ :: CMpd+ -> IO Word8++foreign import ccall unsafe "mpd_arith_sign" c'mpd_arith_sign+ :: CMpd+ -> IO CInt++foreign import ccall unsafe "mpd_trail_zeros" c'mpd_trail_zeros+ :: CMpd+ -> IO Signed++-- Memory handling+foreign import ccall unsafe "mpd_qnew" c'mpd_qnew+ :: IO (Mpd)++newDec :: (Mpd -> IO ()) -> IO Dec+newDec f = do+ p <- c'mpd_qnew+ when (unMpd p == nullPtr) $ error "newMpd: failure"+ fp <- newForeignPtr fp'mpd_del (unMpd p)+ withForeignPtr fp $ \x1 ->+ f (Mpd x1)+ return $ Dec fp++newDec2 :: (Mpd -> Mpd -> IO ()) -> IO (Dec, Dec)+newDec2 f = do+ p1 <- c'mpd_qnew+ when (unMpd p1 == nullPtr) $ error "newMpd: failure"+ p2 <- c'mpd_qnew+ when (unMpd p2 == nullPtr) $ error "newMpd: failure"+ fp1 <- newForeignPtr fp'mpd_del (unMpd p1)+ fp2 <- newForeignPtr fp'mpd_del (unMpd p2)+ withForeignPtr fp1 $ \x1 ->+ withForeignPtr fp2 $ \x2 ->+ f (Mpd x1) (Mpd x2)+ return (Dec fp1, Dec fp2)+++foreign import ccall unsafe "mpd_del" c'mpd_del+ :: Mpd+ -> IO ()++foreign import ccall unsafe "&mpd_del" fp'mpd_del+ :: FunPtr (Ptr C'mpd_t -> IO ())++-- Imported from mkmpd++foreign import ccall unsafe "mpd_copy" c'mpd_copy+ :: Mpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_copy_abs" c'mpd_copy_abs+ :: Mpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_copy_negate" c'mpd_copy_negate+ :: Mpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_invert" c'mpd_invert+ :: Mpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_logb" c'mpd_logb+ :: Mpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_abs" c'mpd_abs+ :: Mpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_exp" c'mpd_exp+ :: Mpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_ln" c'mpd_ln+ :: Mpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_log10" c'mpd_log10+ :: Mpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_minus" c'mpd_minus+ :: Mpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_next_minus" c'mpd_next_minus+ :: Mpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_next_plus" c'mpd_next_plus+ :: Mpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_plus" c'mpd_plus+ :: Mpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_reduce" c'mpd_reduce+ :: Mpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_round_to_intx" c'mpd_round_to_intx+ :: Mpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_round_to_int" c'mpd_round_to_int+ :: Mpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_trunc" c'mpd_trunc+ :: Mpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_floor" c'mpd_floor+ :: Mpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_ceil" c'mpd_ceil+ :: Mpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_sqrt" c'mpd_sqrt+ :: Mpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_invroot" c'mpd_invroot+ :: Mpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()+++foreign import ccall unsafe "mpd_and" c'mpd_and+ :: Mpd+ -> CMpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_copy_sign" c'mpd_copy_sign+ :: Mpd+ -> CMpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_or" c'mpd_or+ :: Mpd+ -> CMpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_rotate" c'mpd_rotate+ :: Mpd+ -> CMpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_scaleb" c'mpd_scaleb+ :: Mpd+ -> CMpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_shift" c'mpd_shift+ :: Mpd+ -> CMpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_xor" c'mpd_xor+ :: Mpd+ -> CMpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_compare" c'mpd_compare+ :: Mpd+ -> CMpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_compare_signal" c'mpd_compare_signal+ :: Mpd+ -> CMpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_add" c'mpd_add+ :: Mpd+ -> CMpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_sub" c'mpd_sub+ :: Mpd+ -> CMpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_div" c'mpd_div+ :: Mpd+ -> CMpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_divint" c'mpd_divint+ :: Mpd+ -> CMpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_max" c'mpd_max+ :: Mpd+ -> CMpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_max_mag" c'mpd_max_mag+ :: Mpd+ -> CMpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_min" c'mpd_min+ :: Mpd+ -> CMpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_min_mag" c'mpd_min_mag+ :: Mpd+ -> CMpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_mul" c'mpd_mul+ :: Mpd+ -> CMpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_next_toward" c'mpd_next_toward+ :: Mpd+ -> CMpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_pow" c'mpd_pow+ :: Mpd+ -> CMpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_quantize" c'mpd_quantize+ :: Mpd+ -> CMpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_rescale" c'mpd_rescale+ :: Mpd+ -> CMpd+ -> Signed+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_rem" c'mpd_rem+ :: Mpd+ -> CMpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_rem_near" c'mpd_rem_near+ :: Mpd+ -> CMpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++foreign import ccall unsafe "mpd_isfinite" c'mpd_isfinite+ :: CMpd+ -> IO CInt++foreign import ccall unsafe "mpd_isinfinite" c'mpd_isinfinite+ :: CMpd+ -> IO CInt++foreign import ccall unsafe "mpd_isinteger" c'mpd_isinteger+ :: CMpd+ -> IO CInt++foreign import ccall unsafe "mpd_isnan" c'mpd_isnan+ :: CMpd+ -> IO CInt++foreign import ccall unsafe "mpd_isnegative" c'mpd_isnegative+ :: CMpd+ -> IO CInt++foreign import ccall unsafe "mpd_ispositive" c'mpd_ispositive+ :: CMpd+ -> IO CInt++foreign import ccall unsafe "mpd_isqnan" c'mpd_isqnan+ :: CMpd+ -> IO CInt++foreign import ccall unsafe "mpd_issnan" c'mpd_issnan+ :: CMpd+ -> IO CInt++foreign import ccall unsafe "mpd_issigned" c'mpd_issigned+ :: CMpd+ -> IO CInt++foreign import ccall unsafe "mpd_isspecial" c'mpd_isspecial+ :: CMpd+ -> IO CInt++foreign import ccall unsafe "mpd_iszero" c'mpd_iszero+ :: CMpd+ -> IO CInt++foreign import ccall unsafe "mpd_iszerocoeff" c'mpd_iszerocoeff+ :: CMpd+ -> IO CInt++foreign import ccall unsafe "mpd_isoddcoeff" c'mpd_isoddcoeff+ :: CMpd+ -> IO CInt++foreign import ccall unsafe "mpd_isodd" c'mpd_isodd+ :: CMpd+ -> IO CInt++foreign import ccall unsafe "mpd_iseven" c'mpd_iseven+ :: CMpd+ -> IO CInt++-- Handlers++
+ internal/Deka/Internal/Unsafe.hs view
@@ -0,0 +1,19 @@+module Deka.Internal.Unsafe where++import System.IO.Unsafe (unsafePerformIO)++unsafe0 :: IO a -> a+unsafe0 = unsafePerformIO++unsafe1 :: (a -> IO b) -> a -> b+unsafe1 f a = unsafePerformIO (f a)++unsafe2 :: (a -> b -> IO c) -> a -> b -> c+unsafe2 f a b = unsafePerformIO (f a b)++unsafe3 :: (a -> b -> c -> IO d) -> a -> b -> c -> d+unsafe3 f a b c = unsafePerformIO (f a b c)++unsafe4 :: (a -> b -> c -> d -> IO e) -> a -> b -> c -> d -> e+unsafe4 f a b c d = unsafePerformIO (f a b c d)+
+ internal/Deka/Internal/Util/Ctx.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE Safe #-}+module Deka.Internal.Util.Ctx where++import Deka.Internal.Mpdec+import Deka.Internal.Context+import Foreign.Safe++type Unary+ = Mpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++unary :: Unary -> Dec -> Ctx Dec+unary f d = Ctx $ \p ->+ newDec $ \nw ->+ withDec d $ \old ->+ f nw old p++type Binary+ = Mpd+ -> CMpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++binary :: Binary -> Dec -> Dec -> Ctx Dec+binary f a b = Ctx $ \p ->+ newDec $ \nw ->+ withDec a $ \pa ->+ withDec b $ \pb ->+ f nw pa pb p++type Ternary+ = Mpd+ -> CMpd+ -> CMpd+ -> CMpd+ -> Ptr C'mpd_context_t+ -> IO ()++ternary :: Ternary -> Dec -> Dec -> Dec -> Ctx Dec+ternary f a b c = Ctx $ \p ->+ newDec $ \n ->+ withDec a $ \pa ->+ withDec b $ \pb ->+ withDec c $ \pc ->+ f n pa pb pc p
− lib/Deka.hs
@@ -1,173 +0,0 @@-{-# LANGUAGE Safe, DeriveDataTypeable #-}---- | Simple decimal arithmetic.------ 'Deka' provides a decimal arithmetic type. Using this module, the--- results are never inexact. Computations will throw exceptions--- rather than returning an inexact result. That way, you know that--- any result you have is exactly correct.------ On 64-bit platforms, you are limited to:------ * a coefficient of ((2 * 10 ^ 17) - 1) digits long------ * a maximum exponent of ((1 * 10 ^ 18) - 1)------ * a minimum exponent of -((1 * 10 ^ 18) + 1)------ On 32-bit platforms, you are limited to:------ * a coefficient of 8.5 * 10 ^ 8 digits long------ * a maximum exponent of 4.25 * 10 ^ 8------ * a minimum exponent of -4.25 * 10 ^ 8------ If you exceed these limits, your computation will throw an--- exception.------ 'Deka' represents only finite values. There are no infinities or--- not-a-number values allowed.------ For more control over your arithmetic, see "Deka.Dec", but--- for many routine uses this module is sufficient and is more--- succinct because, unlike 'Dec', 'Deka' is a member of the 'Num'--- typeclass.--module Deka- ( Deka- , unDeka- , DekaT(..)- , integralToDeka- , strToDeka- , quadToDeka- , DekaError(..)- ) where--import Control.Exception-import Data.Typeable-import Deka.Dec hiding (compare)-import qualified Deka.Dec as D-import qualified Data.ByteString.Char8 as BS8---- | Thrown by arithmetic functions in the Num class, as this is the--- only way to indicate errors.-data DekaError- = Flagged Flags- -- ^ A computation set flags. This will happen if, for example,- -- you calculate a result that is out of range.- deriving (Show, Typeable)--instance Exception DekaError---- | Deka wraps a 'Dec'. Only finite 'Dec' may become a 'Deka';--- no infinities or NaN values are allowed.------ 'Deka' is a member of 'Num', making it easy to use for--- elementary arithmetic. Any time you perform arithmetic, the--- results are always exact. The arithmetic functions will throw--- exceptions rather than give you an inexact result.------ 'Deka' is not a member 'Fractional' because it is generally--- impossible to perform division without getting inexact results,--- and 'Deka' never holds inexact results.-newtype Deka = Deka { unDeka :: Dec }- deriving Show--eval :: Ctx a -> a-eval c- | fl == emptyFlags = r- | otherwise = throw . Flagged $ fl- where- (r, fl) = runCtxStatus c---- | Eq compares by value. For instance, @3.5 == 3.500@.-instance Eq Deka where- Deka x == Deka y = case eval k of- EQ -> True- _ -> False- where- k = do- d <- D.compare x y- let f | isZero d = EQ- | isPositive d = GT- | otherwise = LT- return f---- | Ord compares by value. For instance, @compare 3.5 3.500 ==--- EQ@.-instance Ord Deka where- compare (Deka x) (Deka y) = eval $ do- d <- D.compare x y- let f | isZero d = EQ- | isPositive d = GT- | otherwise = LT- return f---- | Many of the 'Num' functions will throw 'DekaError' if their--- arguments are out of range or if they produce results that are--- out of range or inexact. For functions that don't throw, you can--- use 'integralToDeka' rather than 'fromInteger', or you can use--- "Deka.Dec" instead of 'Deka'.-instance Num Deka where- Deka x + Deka y = Deka . eval $ D.add x y- Deka x - Deka y = Deka . eval $ D.subtract x y- Deka x * Deka y = Deka . eval $ D.multiply x y- negate = Deka . eval . D.minus . unDeka- abs = Deka . eval . D.abs . unDeka- signum (Deka x)- | f isZero = fromInteger 0- | f isNegative = fromInteger (-1)- | otherwise = fromInteger 1- where- f g = g x- fromInteger = Deka . eval . fromByteString . BS8.pack . show---- | Decimals with a total ordering.-newtype DekaT = DekaT { unDekaT :: Deka }- deriving Show---- | Eq compares by a total ordering.-instance Eq DekaT where- DekaT (Deka x) == DekaT (Deka y)- | r == EQ = True- | otherwise = False- where- r = compareTotal x y---- | Ord compares by a total ordering.-instance Ord DekaT where- compare (DekaT (Deka x)) (DekaT (Deka y)) = compareTotal x y----- | Convert any integral to a 'Deka'. Returns 'Nothing' if the--- integer is too big to fit into a 'Deka'.-integralToDeka :: (Integral a, Show a) => a -> Maybe Deka-integralToDeka i- | fl == emptyFlags = Just . Deka $ d- | otherwise = Nothing- where- (d, fl) = runCtxStatus . fromByteString . BS8.pack . show $ i---- | Convert a string to a Deka. You can use ordinary numeric--- strings, such as @3.25@, or exponential notation, like @325E-2@.--- More information on your choices is at:------ <http://speleotrove.com/decimal/daconvs.html#reftonum>------ You cannot use strings that represent an NaN or an infinity. If--- you do that, or use an otherwise invalid string, this function--- returns 'Nothing'.-strToDeka :: String -> Maybe Deka-strToDeka s- | not (emptyFlags == fl) = Nothing- | not (isFinite r) = Nothing- | otherwise = Just (Deka r)- where- (r, fl) = runCtxStatus . fromByteString . BS8.pack $ s---- | Change a 'Dec' to a 'Deka'. Only succeeds for finite 'Dec'.-quadToDeka :: Dec -> Maybe Deka-quadToDeka d- | isFinite d = Just $ Deka d- | otherwise = Nothing
− lib/Deka/Context.hs
@@ -1,112 +0,0 @@-{-# LANGUAGE Safe #-}-module Deka.Context- ( -- -- * Integer type- Signed-- -- * Ctx- , Ctx-- -- * Flags- , Flag- , Flags- , allFlag- , fullFlags- , emptyFlags- , packFlags- , unpackFlags-- -- ** Individual flags- , clamped- , conversionSyntax- , divisionByZero- , divisionImpossible- , divisionUndefined- , fpuError- , inexact- , invalidContext- , invalidOperation- , mallocError- , notImplemented- , overflow- , rounded- , subnormal- , underflow-- -- * Traps- , getTraps- , setTraps-- -- * Status- , getStatus- , setStatus- - -- * Digits- , Precision- , precision- , unPrecision- , getPrecision- , setMaxPrecision-- -- * Rounding- -- ** Rounding types- , Round- , roundCeiling- , roundUp- , roundHalfUp- , roundHalfEven- , roundHalfDown- , roundDown- , roundFloor- , round05Up- , roundTruncate-- -- ** Getting and setting- , getRound- , setRound-- -- * Emax and Emin- -- ** Emax- , Emax- , unEmax- , emax- , getEmax-- -- ** Emin- , Emin- , unEmin- , emin- , getEmin-- -- * Trio- , Trio- , trioPrecision- , trioEmax- , trioEmin- , trio- , setTrio- , getTrio-- -- * Clamp- , getClamp- , setClamp-- -- * Correct rounding- , getAllCorrectRound- , setAllCorrectRound-- -- * Initializers- , Initializer(..)- , initCtx-- -- * Running a Ctx- , runCtxInit- , runCtx- , runCtxStatus- , local-- ) where--import Deka.Internal.Context-import Deka.Internal.Mpdec (Signed)
− lib/Deka/Dec.hs
@@ -1,123 +0,0 @@-{-# LANGUAGE Safe #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- | Decimal arithmetic.------ Much documentation is copied from documentation for the decNumber--- C library, available at------ <http://speleotrove.com/decimal/dnnumb.html>-module Deka.Dec- ( Dec-- -- * Context- , module Deka.Context-- -- * String Conversions- , fromByteString- , toByteString- , toEngByteString-- -- * Arithmetic- , add- , subtract- , multiply- , fma- , divide- , divideInteger- , remainder- , remainderNear-- -- * Signs and absolute value- , abs- , plus- , minus-- -- * Comparisons- , compare- , compareSignal- , compareTotal- , compareTotalMag- , max- , maxMag- , min- , minMag-- -- * Increments- , nextMinus- , nextPlus- , nextToward-- -- * Exponent testing and adjustment- , sameQuantum- , quantize- , rescale- , scaleB-- -- * Digit-wise and logical- , and- , or- , xor- , shift- , rotate- , invert-- -- * Trailing zeroes- , reduce-- -- * Integral rounding- , toIntegralExact- , toIntegralValue-- -- * Logarithms, exponents, roots- , exp- , ln- , logB- , log10- , power- , squareRoot-- -- * Identification- , PosNeg(..)- , Number(..)- , Class(..)- , strToClass- , numClass- , isNormal- , isSubnormal- , isFinite- , isInfinite- , isNaN- , isNegative- , isPositive- , isSigned- , isQNaN- , isSNaN- , isSpecial- , isZero- , isZeroCoeff- , isOddCoeff- , Sign(..)- , sign- , EvenOdd(..)- , evenOdd-- -- * Version- , version-- ) where--import Deka.Internal.Dec.CtxFree-import Deka.Internal.Dec.Ctx-import Deka.Internal.Mpdec-import Deka.Context-import Data.ByteString.Char8 as BS8-import Prelude (Show(..), (.))---- | Same as------ @--- 'BS8.unpack' . 'toByteString'--- @-instance Show Dec where- show = BS8.unpack . toByteString-
− lib/Deka/Docs.hs
@@ -1,24 +0,0 @@-{-# LANGUAGE Safe #-}--- | Documentation for Deka.------ At the moment, documentation is scattered about. Some of it is--- in the main README.md, which is in the source code tree and is--- viewable in Github at------ <http://github.com/massysett/deka/blob/master/README.md>------ Of course much of it is in the Haddock comments in the source--- code itself.------ There is also a module here, "Deka.Docs.Examples". It is in--- literate Haskell and has many comments. Unfortunately Haddock--- does not play well with Literate Haskell. However, the style of--- the file would not play well with Haddock anyway so I'm not sure--- I would ever switch back to regular Haskell for that file.------ So if you link to the file from the Haddock docs, you will just--- get a blank page. Fortunately it is easily readable in Github:------ <http://github.com/massysett/deka/blob/master/lib/Deka/Docs/Examples.hs>--module Deka.Docs where
− lib/Deka/Docs/Examples.lhs
@@ -1,268 +0,0 @@-Examples for the Deka library-=============================--For very simple arithmetic, just import `Deka`. It contains a-`Deka` type, which is an instance of Num. For more control over your-arithmetic, import `Deka.Fixed.Quad`. Be aware that `Quad` exports some-functions that clash with Prelude names, so you might want to do a-qualified `import`; however we will just import them unqualified-here.--> -- Examples will deliberately shadow some names-> {-# OPTIONS_GHC -fno-warn-name-shadowing #-}-> {-# LANGUAGE Safe #-}->-> -- | If you are viewing this module in Haddock and expecting to-> -- see examples, you won't see anything. The file is written in-> -- literate Haskell, so the idea is that you will look at the-> -- source itself. You can look at the source in Haddock, but it-> -- will probably be poorly formatted because HsColour formats it-> -- rather oddly by default. The easiest way to see it-> -- is on Github:-> ---> -- <https://github.com/massysett/deka/blob/master/lib/Deka/Docs/Examples.lhs>-> module Deka.Docs.Examples where--> import Deka-> import Deka.Dec-> import Data.Maybe--We need Char8 ByteStrings when working with the `Deka.Dec` module:--> import qualified Data.ByteString.Char8 as BS8--> examples :: IO ()-> examples = do {--Why is decimal arithmetic important? The webpages here discuss the-issue at great length:--http://speleotrove.com/decimal/--But in a nutshell, the floats that are built in to nearly every-computer language, including Haskell, are approximate. That's OK-for many purposes. It's not OK if you need exact results, such as-for financial purposes.--For example, on my machine this will not output 0.3 but instead will-output 0.3 plus a small fraction:--> print $ 0.1 + 0.1 + (0.1 :: Double);--This sort of imprecision adds up quickly and makes your life as a-programmer harder in many ways. It also produces results that are-simply incorrect if you needed an exact answer.--For simple arithmetic like this, deka provides the `Deka` type. It is-an instance of `Num`. Results with the `Deka` type are never, ever-rounded. There are limits on the size of numbers you can use; these-limits are huge and should not affect most uses. They are-documented in the `Deka` module.--All numbers in deka are stored as a "coefficient" and an "exponent".-The coefficient is an integer, and the exponent is an-integer that may be negative, zero, or positive. Here, the-coefficient is always 12345, but the exponent varies:-- Number Exponent- 12345 0- 123.45 -2- 0.12345 -5- 0.00012345 -8--Some numbers can only accurately be written down using scientific-notation if we want to reflect how many digits are in the-coefficient. We can do this with E notation, where the coefficient-is followed by the exponent. To get the original number, if the-coefficient is c and the exponent is e, do-- c * 10 ^ e--So, for example, you can say that `12345e0` and `1234500e-2` are the-same number, but they have different coefficients.--For more about decimal arithmetic, you will really want to read--http://speleotrove.com/decimal/decarith.html--It's written in a very clear style.--OK, so back to `Deka`. We said that `print $ 0.1 + 0.1 + 0.1` yields-an inaccurate result. How to do it with `Deka`?--First we have to create a `Deka`. `Deka` is not an instance of-`Read`. However you can use `strToDeka`, which has the type-- strToDeka :: String -> Maybe Deka--If you give a bad input string, you get `Nothing`; otherwise you get-a `Just` with your `Deka`. The input string can be in regular or-scientific notation.--So, the following snippet will not give you incorrectly rounded-results:--> let { oneTenth = fromJust . strToDeka $ "0.1" };-> print $ oneTenth + oneTenth + oneTenth;--`Deka` is not an instance of other numeric typeclasses, such as-`Real` or `Fractional`. That's because `Deka` never ever rounds, no-matter what. For `Deka` to be a member of `Fractional`, it would-need to implement division, and division without rounding can't do-very much.--Sometimes it will be impossible for `Deka` to do its math without-rounding. In that case, the functions in the `Deka` module will-apply `error` and quit. That way you are assured that if you have a-result, it is not rounded.---More flexibility with the `Deka.Dec` module-=================================================--Though the `Deka` type provides you with some flexibility--and it's-easy to use because it's an instance of `Num`--sometimes you need more-flexibility. If you want to perform division, for example, `Deka` is-no good. For more flexibility, but more cumbersome use, turn to the-`Deka.Dec` module.--The main type of the `Deka.Dec` module is called `Dec`, as in-"Decimal". It exposes the full power of the mpdecimal library. The-disadvantage is that many computations must be performed in the-`Ctx` monad. This monad carries the state that decNumber needs to-do its work. It provides you with a lot of information about any-errors that have occurred during computations.--If you are getting into the `Deka.Dec` module, you really need to read the-decimal arithmetic specification at--http://speleotrove.com/decimal/decarith.html--Context----------This specification provides that many computations occur within a-so-called "context", which holds information that affects the-computation, such as how to round inexact results. The context also-holds information about any errors that have happened so far, such-as division by zero, and can tell you other information such as-whether any computations performed so far have calculated an inexact-result.--The context of the decimal arithmetic specification is represented-in Deka by the `Ctx` type. `Ctx` provides computations with the-context that they need, and it allows computations to record errors-that may arise. `Ctx` is a `Monad` so you can use the usual monad-functions and `do` notation to combine your computations.-`Deka.Context`, which is re-exported by `Deka.Dec`, has functions-you can use to change the context's rounding, see what errors have-been set, and clear errors. Once an error flag is set, you have to-clear it; the functions in `Quad` won't clear it for you. However,-computations can proceed normally even if an error flag was set in a-previous computation.--After building up a computation in the `Ctx` monad, you need a way-to get the results and use them elsewhere in your program. For this-you use the `runQuad` function:-- runCtx :: Ctx a -> a--Not all computations need a context. For example, `compareTotal`-does not need a context, and it can never return an error.--Example - using `do` notation--------------------------------Following is an example of how you would add one tenth using the-Quad type:--> let { oneTenth = runCtx . fromByteString . BS8.pack $ "0.1" };-> BS8.putStrLn . toByteString . runCtx $ do-> r1 <- add oneTenth oneTenth-> add r1 oneTenth-> ;--As you can see this is much more cumbersome than using `Deka`. But-it does give you the full power of mpdecimal.--Rounding-----------One reason to use the `Deka.Dec` module is because you want greater-control over rounding. There are many varieties of rounding-available, which you can set. This can be useful with division, for-example, where you will not get exact results. All results are-computed to 34 digits of precision.--> let tenSixths = runCtx $ do-> setRound roundDown-> ten <- fromByteString . BS8.pack $ "10"-> three <- fromByteString . BS8.pack $ "6"-> divide ten three-> ;--Perhaps you want to round the result to a particular number of-decimal places. You do this with the `quantize` function. It takes-two `Quad`: one that you want to round, and another that has the-number of decimal places you want to round to.--> putStrLn "This is 10 / 6, rounded to two places:";-> BS8.putStrLn . toByteString . runCtx $ do-> twoPlaces <- fromByteString . BS8.pack $ "1e-2"-> quantize tenSixths twoPlaces-> ;--By default, rounding is done using the `roundHalfEven` method. You-can set a different rounding method if you wish; the rounding-methods are listed in the Haddock documentation for `Deka.Context`.--> putStrLn "This is 10 / 6, rounded using the 'roundDown' method.";-> BS8.putStrLn . toByteString . runCtx $ do-> twoPlaces <- fromByteString . BS8.pack $ "1e-2"-> setRound roundDown-> quantize tenSixths twoPlaces-> ;---Flags--------A computation may set any number of flags. These are listed in the-`Deka.Context` module. They indicate errors (like division by zero)-or give information (such as the fact that a computation was-inexact.) Functions in `Deka.Context` manipulate which flags are-currently set. Though computations set flags, they never clear-them. You have to clear them yourself.--To see which flags are set, use `getStatus`:--> let (r, fl) = runCtx $ do-> big1 <- fromByteString . BS8.pack $ "987e3000"-> nan <- fromByteString . BS8.pack $ "sNaN"-> rslt <- multiply big1 nan-> fl <- getStatus-> return $ (toByteString rslt, fl)-> ; -> putStr "result: ";-> BS8.putStrLn r;-> putStr "flags set: ";-> print fl;--The above example also shows that computations may return a Quad-that is not finite--that is, it might be inifite, or it might be a-Not-a-Number, or NaN. In contrast, computations using the Deka type-never return non-finite values.--Conclusion-------------That should be enough to get you started. If you find any bug no-matter how small--even just a typo in the documentation--report it-to me at omari@smileystation.com or file a ticket or a pull request-in Github:--https://github.com/massysett/deka--No bug is too small!--> };
− lib/Deka/Internal/Context.hs
@@ -1,637 +0,0 @@-{-# LANGUAGE Trustworthy, DeriveDataTypeable #-}-module Deka.Internal.Context where--import Foreign.C-import Foreign.Safe-import Control.Applicative-import Control.Monad-import Control.Exception-import Data.Typeable-import Deka.Internal.Mpdec-import System.IO.Unsafe (unsafePerformIO)---- | The Ctx monad------ The General Decimal Arithmetic specification states that most--- computations occur within a @context@, which affects the manner--- in which computations are done (for instance, the context--- determines the rounding algorithm). The context also carries--- the flags that computations can set (for instance, a computation might--- set a flag to indicate that the result is rounded or inexact or--- was a division by zero.) The Ctx monad carries this context.--newtype Ctx a = Ctx { unCtx :: Ptr C'mpd_context_t -> IO a }--instance Functor Ctx where- fmap = liftM--instance Applicative Ctx where- pure = return- (<*>) = ap--instance Monad Ctx where- return a = Ctx $ \_ -> return a- Ctx a >>= f = Ctx $ \p -> do- r1 <- a p- let b = unCtx $ f r1- b p- fail s = Ctx $ \_ -> fail s---- # Rounding--newtype Round = Round { _unRound :: CInt }- deriving (Eq, Ord)---- | Round toward positive infinity.-roundCeiling :: Round-roundCeiling = Round c'MPD_ROUND_CEILING---- | Round away from zero.-roundUp :: Round-roundUp = Round c'MPD_ROUND_UP---- | @0.5@ rounds up-roundHalfUp :: Round-roundHalfUp = Round c'MPD_ROUND_HALF_UP---- | @0.5@ rounds to nearest even-roundHalfEven :: Round-roundHalfEven = Round c'MPD_ROUND_HALF_EVEN---- | @0.5@ rounds down-roundHalfDown :: Round-roundHalfDown = Round c'MPD_ROUND_HALF_DOWN---- | Round toward zero - truncate-roundDown :: Round-roundDown = Round c'MPD_ROUND_DOWN---- | Round toward negative infinity.-roundFloor :: Round-roundFloor = Round c'MPD_ROUND_FLOOR---- | Round for reround-round05Up :: Round-round05Up = Round c'MPD_ROUND_05UP---- | Truncate, but set infinities.-roundTruncate :: Round-roundTruncate = Round c'MPD_ROUND_TRUNC--instance Show Round where- show r- | r == roundCeiling = "ceiling"- | r == roundUp = "up"- | r == roundHalfUp = "half up"- | r == roundHalfEven = "half even"- | r == roundHalfDown = "half down"- | r == roundDown = "down"- | r == roundFloor = "floor"- | r == round05Up = "05up"- | r == roundTruncate = "truncate"- | otherwise = error "show: unknown rounding value"--getRound :: Ctx Round-getRound = Ctx $ fmap Round . peek . p'mpd_context_t'round--setRound :: Round -> Ctx ()-setRound (Round r) = Ctx $ \ptr -> poke (p'mpd_context_t'round ptr) r---- # Precision---- | Sets the precision to be used for all operations. The result--- of an operation is rounded to this length if necessary.-newtype Precision = Precision { unPrecision :: Signed }- deriving (Eq, Ord, Show)--instance Bounded Precision where- minBound = Precision 1- maxBound = Precision c'MPD_MAX_PREC---- | Creates a 'Precision' that you can then set with--- 'setTrio'. Returns 'Nothing' if the argument is out of--- range. The minimum possible value is always 1; the maximum--- possible value is platform dependent and is revealed by--- 'maxBound'.-precision :: Signed -> Maybe Precision-precision i- | i < 1 = Nothing- | i > c'MPD_MAX_PREC = Nothing- | otherwise = Just . Precision $ i---- | Sets the precision to the maximum possible, respecting that--- @'Emax' > 5 * 'Precision'@. Returns the new 'Precision'.--setMaxPrecision :: Ctx Precision-setMaxPrecision = do- Emax x <- getEmax- let p' = Precision $ x `div` 5- setPrecision p'- return p'--setPrecision :: Precision -> Ctx ()-setPrecision (Precision d) = Ctx $ \ptr ->- poke (p'mpd_context_t'prec ptr) d--getPrecision :: Ctx Precision-getPrecision = Ctx $ fmap Precision . peek . p'mpd_context_t'prec---- # Emax, Emin---- | Maximum adjusted exponent. The adjusted exponent is calculated--- as though the number were expressed in scientific notation. If--- the adjusted exponent would be larger than 'Emax' then an--- overflow results.------ The minimum possible value is always 0; the--- maximum possible value is platform dependent and is revealed by--- 'maxBound'.-newtype Emax = Emax { unEmax :: Signed }- deriving (Eq, Ord, Show)--instance Bounded Emax where- minBound = Emax 0- maxBound = Emax c'MPD_MAX_EMAX---- | Minimum adjusted exponent. The adjusted exponent is calculated--- as though the number were expressed in scientific notation. If--- the adjusted exponent would be smaller than 'Emin' then the--- result is subnormal. If the result is also inexact, an underflow--- results. If subnormal results are allowed (see 'setClamp') the--- smallest possible exponent is 'Emin' minus 'Precision' plus @1@.------ The minimum possible value is platform dependent--- and is revealed by 'minBound'; the maximum possible value is--- always 0.-newtype Emin = Emin { unEmin :: Signed }- deriving (Eq, Ord, Show)--instance Bounded Emin where- minBound = Emin c'MPD_MIN_EMIN- maxBound = Emin 0---- | Returns an 'Emax' for use in 'setTrio'. Fails if argument is--- out of range.-emax :: Signed -> Maybe Emax-emax i- | r < minBound = Nothing- | r > maxBound = Nothing- | otherwise = Just r- where- r = Emax i---- | Returns an 'Emin' for use in 'setTrio'. Fails if argument is--- out of range.-emin :: Signed -> Maybe Emin-emin i- | r < minBound = Nothing- | r > maxBound = Nothing- | otherwise = Just r- where- r = Emin i--getEmax :: Ctx Emax-getEmax = Ctx $ fmap Emax . peek . p'mpd_context_t'emax--setEmax :: Emax -> Ctx ()-setEmax (Emax i) = Ctx $ \ptr -> poke (p'mpd_context_t'emax ptr) i--getEmin :: Ctx Emin-getEmin = Ctx $ fmap Emin . peek . p'mpd_context_t'emin--setEmin :: Emin -> Ctx ()-setEmin (Emin i) = Ctx $ \ptr -> poke (p'mpd_context_t'emin ptr) i---- # Trio---- | In addition to the limits on 'Precision', 'Emax', and 'Emin',--- there are also requirements on the relationship between these--- three variables:------ * @'Emax' > 5 * 'Precision'@ ------ * either @'Emin' == 1 - 'Emax'@ or @'Emin' == -'Emax'@------ The 'Trio' enforces this relationship.------ It is also recommended that @'Emax' > 10 * 'Precision'@, but--- since this is not required the 'Trio' does not enforce it.--data Trio = Trio- { trioPrecision :: Precision- , trioEmax :: Emax- , trioEmin :: Emin- } deriving Show---- | Make a new 'Trio'. Fails if the values are out of range.--trio :: Precision -> Emax -> Emin -> Maybe Trio-trio pp@(Precision p) px@(Emax x) pn@(Emin n)- | not $ x > 5 * p = Nothing- | not $ n == 1 - x || n == negate x = Nothing- | otherwise = Just $ Trio pp px pn--setTrio :: Trio -> Ctx ()-setTrio (Trio p x n) =- setPrecision p >> setEmax x >> setEmin n--getTrio :: Ctx Trio-getTrio = liftM3 Trio getPrecision getEmax getEmin---- # Clamp--getClamp :: Ctx Bool-getClamp = Ctx $ fmap (/= 0) . peek . p'mpd_context_t'clamp---- | Controls explicit exponent clamping. When False, a result--- exponent is limited to a maximum of emax and a minimum of emin--- (for example, the exponent of a zero result will be clamped to be--- in this range). When True, a result exponent has the same minimum--- but is limited to a maximum of emax-(digits-1). As well as--- clamping zeros, this may cause the coefficient of a result to be--- padded with zeros on the right in order to bring the exponent--- within range.------ Also when True, this limits the length of NaN payloads to--- 'Precision' - 1 when constructing a NaN by conversion from a--- string.--setClamp :: Bool -> Ctx ()-setClamp b = Ctx f- where- f ptr = poke (p'mpd_context_t'clamp ptr) v- v = if b then 1 else 0----- # Flags---- | Indicates error conditions. This type serves two purposes:--- computations set flags to indicate errors, and flags indicate--- which errors you want to have raise a signal. See 'getStatus',--- 'setStatus', 'getTraps', and 'setTraps'.------ 'Flag' is an instance of 'Exception' so that you can throw it if--- you want; however, none of the functions in the @deka@ package--- throw.-newtype Flag = Flag { unFlag :: Word32 }- deriving (Eq, Ord, Typeable)--instance Exception Flag--instance Show Flag where- show f- | f == conversionSyntax = "Conversion syntax"- | f == divisionByZero = "Division by zero"- | f == divisionImpossible = "Division impossible"- | f == divisionUndefined = "Division undefined"- | f == inexact = "Inexact"- | f == invalidContext = "Invalid context"- | f == invalidOperation = "Invalid operation"- | f == mallocError = "malloc error"- | f == fpuError = "FPU error"- | f == notImplemented = "Not implemented"- | f == overflow = "Overflow"- | f == clamped = "Clamped"- | f == rounded = "Rounded"- | f == subnormal = "Subnormal"- | f == underflow = "Underflow"- | otherwise = error "show flag: unrecognized flag"---- | A container of 'Flag'.-newtype Flags = Flags { unFlags :: Word32 }- deriving (Eq, Typeable)--instance Show Flags where- show = show . unpackFlags--instance Exception Flags---- | A list of all possible 'Flag', in order.-allFlag :: [Flag]-allFlag =- [ clamped- , conversionSyntax- , divisionByZero- , divisionImpossible- , divisionUndefined- , fpuError- , inexact- , invalidContext- , invalidOperation- , mallocError- , notImplemented- , overflow- , rounded- , subnormal- , underflow- ]---- | All possible 'Flag' are set.-fullFlags :: Flags-fullFlags = packFlags allFlag---- | No 'Flag' are set.-emptyFlags :: Flags-emptyFlags = Flags 0---- | Flags will always be unpacked in order.-unpackFlags :: Flags -> [Flag]-unpackFlags (Flags i) = f allFlag- where- f [] = []- f (Flag x:xs)- | x .&. i /= 0 = Flag x : f xs- | otherwise = f xs--packFlags :: [Flag] -> Flags-packFlags = Flags . foldl (.|.) 0 . map unFlag---- | A source string (for instance, in 'fromByteString') contained--- errors.-conversionSyntax :: Flag-conversionSyntax = Flag c'MPD_Conversion_syntax---- | A non-zero dividend is divided by zero. Unlike @0/0@, it has a--- defined result (a signed Infinity).-divisionByZero :: Flag-divisionByZero = Flag c'MPD_Division_by_zero---- | Sometimes raised by 'divideInteger' and 'remainder'.-divisionImpossible :: Flag-divisionImpossible = Flag c'MPD_Division_impossible---- | @0/0@ is undefined. It sets this flag and returns a quiet NaN.-divisionUndefined :: Flag-divisionUndefined = Flag c'MPD_Division_undefined---- | One or more non-zero coefficient digits were discarded during--- rounding.-inexact :: Flag-inexact = Flag c'MPD_Inexact---- | The Context for computations was invalid; this error should--- never occur because @deka@ keeps you from setting an invalid--- context.-invalidContext :: Flag-invalidContext = Flag c'MPD_Invalid_context---- | Raised on a variety of invalid operations, such as an attempt--- to use 'compareSignal' on an operand that is an NaN.-invalidOperation :: Flag-invalidOperation = Flag c'MPD_Invalid_operation--mallocError :: Flag-mallocError = Flag c'MPD_Malloc_error--fpuError :: Flag-fpuError = Flag c'MPD_Fpu_error--notImplemented :: Flag-notImplemented = Flag c'MPD_Not_implemented---- | The exponent of a result is too large to be represented.-overflow :: Flag-overflow = Flag c'MPD_Overflow--clamped :: Flag-clamped = Flag c'MPD_Clamped--rounded :: Flag-rounded = Flag c'MPD_Rounded--subnormal :: Flag-subnormal = Flag c'MPD_Subnormal---- | A result is both subnormal and inexact.-underflow :: Flag-underflow = Flag c'MPD_Underflow---- # Traps---- ## Set---- | If you set a trap, a computation will immediately raise--- @SIGFPE@ if the corresponding error arises. (Currently this--- behavior cannot be configured to do something else.)--- 'setTraps' clears all existing traps and sets them to the new--- ones you specify.------ By setting a flag here, SIGFPE is raised if any subsequent--- computations raise the corresponding error condition. Setting a--- flag with this function or with 'setTrap' never, by itself,--- causes SIGFPE to be raised; it is raised only by a subsequent--- computation. So, if you set a flag using this function or--- 'setTrap' and the corresponding status flag is already set,--- SIGFPE will be raised only if a subsequent computation raises--- that error condition.-setTraps :: Flags -> Ctx ()-setTraps fs = Ctx $ \ptr -> do- let pTr = p'mpd_context_t'traps ptr- poke pTr (unFlags fs) ---- | Gets all currently set traps.-getTraps :: Ctx Flags-getTraps = Ctx $ \ptr -> do- ts <- peek (p'mpd_context_t'traps ptr)- return $ Flags ts---- # Status---- ## Set---- | Sets status flags. All existing status flags are cleared and--- replaced with the ones you indicate here.-setStatus :: Flags -> Ctx ()-setStatus fs = Ctx $ \ptr ->- poke (p'mpd_context_t'status ptr) (unFlags fs)---- | All currently set status flags.-getStatus :: Ctx Flags-getStatus = Ctx $ \ptr -> do- let pSt = p'mpd_context_t'status ptr- ts <- peek pSt- return $ Flags ts---- # Initializers---- | Before running computations in a context. the context must be--- initialized with certain settings, such as the rounding mode,--- precision, and maximum adjusted exponent. An 'Initializer'--- contains all these settings.------ On 64-bit platforms, the maximums are:------ * 'Precision' of ((1 * 10 ^ 18) - 1)--- * 'Emax' of ((1 * 10 ^ 18) - 1)--- * 'Emin' of -((1 * 10 ^ 18) - 1)------ On 32-bit platforms, the maximums are:------ * 'Precision' of 4.25 * 10 ^ 8--- * 'Emax' of 4.25 * 10 ^ 8--- * 'Emin' of -4.25 * 10 ^ 8--data Initializer- = Max- -- ^ Sets:- --- -- * 'Precision' to the maximum available- -- * 'Emax' to the maximum available- -- * 'Emin' to the minimum available- -- * 'Round' to 'roundHalfEven'- -- * Traps to 'invalidOperation', 'divisionByZero', 'overflow',- -- 'underflow'- -- * No status flags are set- -- * No newtrap is set- -- * 'setClamp' is False- -- * 'setAllCorrectRound' is True- --- -- As noted in the documentation for 'Trio', the specification- -- requires that @'Emax' > 5 * 'Precision'@; 'Max' does /not/- -- respect this.-- | Default- -- ^ Same as 'Max', except:- --- -- * Precision is @2 * MPD_RDIGITS@-- | Basic- -- ^ Same as 'Max', except:- --- -- * 'Precision' is 9- -- * Traps to 'invalidOperation', 'divisionByZero', 'overflow',- -- 'underflow', and 'clamped'-- | Pedantic- -- ^ Sets the maximum allowable figures, while respecting the- -- restriction that stated in the specification and the @mpdecimal@- -- documentation, which is that @'Emax' > 5 * 'Precision'@. Also,- -- sets no traps. This sets:- --- -- * 'Emax' to the maximum available- -- * 'Emin' to the minimum available- --- -- * 'Precision' is set to @'Emax' `div` 5@. On 64-bit platforms,- -- this is ((2 * 10 ^ 17) - 1); on 32-bit platforms, this is 8.5 *- -- 10 ^ 8.- --- -- * 'Round' to 'roundHalfEven'- -- * No traps are set- -- * No status flags are set- -- * No newtrap is set- -- * 'setClamp' is False- -- * 'setAllCorrectRound' is True-- | Decimal32- -- ^ Sets:- --- -- * 'Precision' to @7@- -- * 'Emax' to @96@- -- * 'Emin' to @-95@- -- * Rounding to 'roundHalfEven'- -- * No traps are enabled- -- * No status flags are set- -- 'newTrap' is clear- -- * 'setClamp' is True- -- * 'setAllCorrectRound' is True-- | Decimal64- -- ^ Same as 'Decimal32', except:- --- -- * 'Precision' is @16@- -- * 'Emax' is @384@- -- * 'Emin' is @-383@-- | Decimal128- -- ^ Same as 'Decimal32', except:- --- -- * 'Precision' is @34@- -- * 'Emax' is @6144@- -- * 'Emin' is @-6143@---- | Re-initialize a 'Ctx' using the given Initializer.-initCtx :: Initializer -> Ctx ()-initCtx i = Ctx $ \p ->- case i of- Max -> c'mpd_maxcontext p- Default -> c'mpd_defaultcontext p- Basic -> c'mpd_basiccontext p- Pedantic -> unCtx pedantic p- Decimal32 -> c'mpd_ieee_context p 32 >> return ()- Decimal64 -> c'mpd_ieee_context p 64 >> return ()- Decimal128 -> c'mpd_ieee_context p 128 >> return ()--clearStatus :: Ctx ()-clearStatus = Ctx $ \p -> poke (p'mpd_context_t'status p) 0--clearNewtrap :: Ctx ()-clearNewtrap = Ctx $ \p -> poke (p'mpd_context_t'newtrap p) 0--pedantic :: Ctx ()-pedantic = do- setEmax maxBound- setEmin minBound- let pc = Precision $ ((unEmax maxBound) `div` 5)- setPrecision pc- setRound roundHalfEven- setTraps emptyFlags- clearStatus- clearNewtrap- setClamp False- setAllCorrectRound True---- # allCorrectRound---- | By default, most functions are correctly rounded. By setting--- allCorrectRound, correct rounding is additionally enabled for--- exp, ln, and log10. In this case, all functions except pow and--- invroot return correctly rounded results.-getAllCorrectRound :: Ctx Bool-getAllCorrectRound = Ctx $ fmap (/= 0) . peek . p'mpd_context_t'allcr--setAllCorrectRound :: Bool -> Ctx ()-setAllCorrectRound b = Ctx f- where- f ptr = poke (p'mpd_context_t'allcr ptr) v- v = if b then 1 else 0---- # Runners---- | Runs a Ctx computation; begins with the given Initializer to--- set up the context.-runCtxInit :: Initializer -> Ctx a -> a-runCtxInit i (Ctx f) = unsafePerformIO $ do- fp <- mallocForeignPtrBytes c'mpd_context_t'sizeOf- withForeignPtr fp $ \ptr -> do- _ <- unCtx (initCtx i) ptr- f ptr---- | Runs a Ctx computation using the 'Pedantic' Initializer.-runCtx :: Ctx a -> a-runCtx = runCtxInit Pedantic---- | Like 'runCtx' but also returns any status flags resulting from--- the computation.-runCtxStatus :: Ctx a -> (a, Flags)-runCtxStatus c = runCtx $ do- r <- c- f <- getStatus- return (r, f)---- # Local---- | Runs a Ctx computation within the existing Ctx. The existing--- Ctx is copied to form a new Ctx; then the child computation is--- run without affecting the parent Ctx.--local- :: Ctx a- -- ^ Run this computation. It is initialized with the current- -- Ctx, but does not affect the current Ctx.- -> Ctx a- -- ^ Returns the result of the child computation.-local (Ctx l) = Ctx $ \parent ->- allocaBytes (c'mpd_context_t'sizeOf) $ \child ->- copyBytes child parent c'mpd_context_t'sizeOf >>- l child-
− lib/Deka/Internal/Dec/Ctx.hs
@@ -1,364 +0,0 @@-{-# LANGUAGE Safe, OverloadedStrings #-}-module Deka.Internal.Dec.Ctx where--import qualified Data.ByteString.Char8 as BS8-import Deka.Internal.Context-import Deka.Internal.Mpdec-import Deka.Internal.Util.Ctx-import Data.String---- | Converts a character string to a 'Dec'. Implements the--- _to-number_ conversion from the General Decimal Arithmetic--- specification.------ The conversion is exact provided that the numeric string has no--- more significant digits than are specified in the 'Precision' in--- the 'Ctx' and the adjusted exponent is in the range specified by--- 'Emin' and 'Emax' in the 'Ctx'. If there are more than--- 'Precision' digits in the string, or the exponent is out of--- range, the value will be rounded as necessary using the 'Round'--- rounding mode. The 'Precision' therefore both determines the--- maximum precision for unrounded numbers and defines the minimum--- size of the 'Dec' structure required.------ Possible errors are 'conversionSyntax' (the string does not have--- the syntax of a number, which depends on 'setExtended' in the--- 'Ctx'), 'overflow' (the adjusted exponent of the number is larger--- than 'Emax'), or 'underflow' (the adjusted exponent is less than--- 'Emin' and the conversion is not exact). If any of these--- conditions are set, the number structure will have a defined--- value as described in the arithmetic specification (this may be a--- subnormal or infinite value).--fromByteString :: BS8.ByteString -> Ctx Dec-fromByteString bs = Ctx $ \pCtx ->- newDec $ \dn ->- BS8.useAsCString bs $ \cstr ->- c'mpd_set_string dn cstr pCtx---- | Returns the absolute value. The same effect as 'plus' unless--- the operand is negative, in which case it is the same as 'minus'.-abs :: Dec -> Ctx Dec-abs = unary c'mpd_abs---- | Addition.-add :: Dec -> Dec -> Ctx Dec-add = binary c'mpd_add---- | Digit-wise logical @and@.-and :: Dec -> Dec -> Ctx Dec-and = binary c'mpd_and---- | @compare x y@ returns @-1@ if a is less than b, 0 if a is equal--- to b, and 1 if a is greater than b. 'invalidOperation' is set if--- at least one of the operands is a signaling NaN.-compare :: Dec -> Dec -> Ctx Dec-compare = binary c'mpd_compare---- | Identical to 'Deka.Dec.compare' except that all NaNs--- (including quiet NaNs) set the 'invalidOperation' condition.-compareSignal :: Dec -> Dec -> Ctx Dec-compareSignal = binary c'mpd_compare_signal---- | Division.-divide :: Dec -> Dec -> Ctx Dec-divide = binary c'mpd_div---- | Returns the integer part of the result of division. It must be--- possible to express the result as an integer. That is, it must--- have no more digits than 'Precision' in the 'Ctx'. If it does--- then 'divisionImpossible' is raised.-divideInteger :: Dec -> Dec -> Ctx Dec-divideInteger = binary c'mpd_divint---- | Exponentiation. Result is rounded if necessary using the--- 'Precision' in the 'Ctx' and using the 'roundHalfEven' rounding--- method.------ Finite results will always be full precision and inexact, except--- when rhs is a zero or -Infinity (giving 1 or 0 respectively).--- Inexact results will almost always be correctly rounded, but may--- be up to 1 ulp (unit in last place) in error in rare cases.------ This is a mathematical function; the @10 ^ 6@ restrictions on--- precision and range apply as described above.-exp :: Dec -> Ctx Dec-exp = unary c'mpd_exp---- | @fma x y z@ multiplies @x@ by @y@ and then adds @z@ to that--- intermediate result. It is equivalent to a multiplication--- followed by an addition except that the intermediate result is--- not rounded and will not cause overflow or underflow. That is,--- only the final result is rounded and checked.------ This is a mathematical function; the @10 ^ 6@ restrictions on--- precision and range apply as described above.-fma :: Dec -> Dec -> Dec -> Ctx Dec-fma = ternary c'mpd_fma---- | Digit-wise inversion (a @0@ becomes a @1@ and vice versa).-invert :: Dec -> Ctx Dec-invert = unary c'mpd_invert---- | Natural logarithm. Results are correctly rounded if--- 'setAllCorrectRound' is True.-ln :: Dec -> Ctx Dec-ln = unary c'mpd_ln---- | Returns the adjusted exponent of the operand, according to the--- rules for @logB@ of IEEE 754. This returns the exponent of the--- operand as though its decimal point had been moved to follow the--- first digit while keeping the same value. The result is not--- limited by 'Emin' or 'Emax'.---- | If operand is an NaN, the general rules apply. If operand is--- infinite, the result is +Infinity. If operand is zero, result is--- -Infinity and 'invalidOperation' is set. Otherwise, the result--- is the same as the adjusted exponent of the operand, or--- @floor(log10(a))@ where @a@ is the operand.-logB :: Dec -> Ctx Dec-logB = unary c'mpd_logb---- | Base 10 logarithm. Results are correctly rounded if--- 'setAllCorrectRound' is True.-log10 :: Dec -> Ctx Dec-log10 = unary c'mpd_log10---- | Compares two numbers numerically and returns the larger. If--- the numbers compare equal then number is chosen with regard to--- sign and exponent. Unusually, if one operand is a quiet NaN and--- the other a number, then the number is returned.-max :: Dec -> Dec -> Ctx Dec-max = binary c'mpd_max---- | Compares the magnitude of two numbers numerically and sets--- number to the larger. It is identical to 'Deka.Dec.max' except--- that the signs of the operands are ignored and taken to be 0--- (non-negative).-maxMag :: Dec -> Dec -> Ctx Dec-maxMag = binary c'mpd_max_mag---- | Compares two numbers numerically and sets number to the--- smaller. If the numbers compare equal then number is chosen with--- regard to sign and exponent. Unusually, if one operand is a quiet--- NaN and the other a number, then the number is returned.-min :: Dec -> Dec -> Ctx Dec-min = binary c'mpd_min---- | Compares the magnitude of two numbers numerically and sets--- number to the smaller. It is identical to 'Deka.Dec.min' except--- that the signs of the operands are ignored and taken to be 0--- (non-negative).-minMag :: Dec -> Dec -> Ctx Dec-minMag = binary c'mpd_min_mag---- | Returns the result of subtracting the operand from zero. hat--- is, it is negated, following the usual arithmetic rules; this may--- be used for implementing a prefix minus operation.-minus :: Dec -> Ctx Dec-minus = unary c'mpd_minus---- | Multiplication.-multiply :: Dec -> Dec -> Ctx Dec-multiply = binary c'mpd_mul---- | Digit-wise logical inclusive or.-or :: Dec -> Dec -> Ctx Dec-or = binary c'mpd_or---- | Returns the result of adding the operand to zero. This takes--- place according to the settings given in the 'Ctx', following the--- usual arithmetic rules. This may therefore be used for rounding--- or for implementing a prefix plus operation.-plus :: Dec -> Ctx Dec-plus = unary c'mpd_plus---- | @power b e@ returns @b@ raised to the power of @e@. Integer--- powers are exact, provided that the result is finite and fits--- into 'Precision'.------ Results are not correctly rounded, even if 'setAllCorrectRound'--- is True. The error of the function is less than @1ULP + t@,--- where @t@ has a maximum of @0.1ULP@, but is almost always less--- than @0.001ULP@.--power :: Dec -> Dec -> Ctx Dec-power = binary c'mpd_pow---- | @quantize a b@ returns the number that is equal in value to--- @a@, but has the exponent of @b@.-quantize :: Dec -> Dec -> Ctx Dec-quantize = binary c'mpd_quantize---- overflow/underflow checks, returns @a@ in its simplest form with--- all trailing zeros removed.-reduce :: Dec -> Ctx Dec-reduce = unary c'mpd_reduce---- | @remainder a b@ returns the remainder of @a / b@.-remainder :: Dec -> Dec -> Ctx Dec-remainder = binary c'mpd_rem---- | @remainderNear a b@ returns @a - b * n@, where @n@ is the--- integer nearest the exact value of @a / b@. If two integers are--- equally near then the even one is chosen.-remainderNear :: Dec -> Dec -> Ctx Dec-remainderNear = binary c'mpd_rem_near---- | @rescale a b@ returns the number that is equal in value--- to @a@, but has the exponent @b@. Special numbers are copied--- without signaling. This function is not part of the General--- Decimal Arithmetic Specification. It--- is also not equivalent to the rescale function that was removed--- from the specification.--rescale :: Dec -> Signed -> Ctx Dec-rescale a b = Ctx $ \p -> newDec $ \r ->- withDec a $ \pa ->- c'mpd_rescale r pa b p---- | @rotate x y@ returns @x@ rotated by @y@ places. @y@ must be in--- the range [-'Precision', 'Precision']. A negative @y@ indicates a--- right rotation, a positive @y@ a left rotation.--rotate :: Dec -> Dec -> Ctx Dec-rotate = binary c'mpd_rotate---- | @scaleB a b@ - b must be an integer with exponent 0. If @a@ is--- infinite, returns @a@. Otherwise, returns @a@ with the--- value of @b@ added to the exponent.--scaleB :: Dec -> Dec -> Ctx Dec-scaleB = binary c'mpd_scaleb---- | @shift a b@ returns @a@ shifted by @b@ places. @b@ must be in--- the range [-'Precision', 'Precision']. A negative @b@ indicates a--- right shift, a positive @b@ a left shift. Digits that do not fit--- are discarded.--shift :: Dec -> Dec -> Ctx Dec-shift = binary c'mpd_shift---- | Returns the square root. This function is always correctly--- rounded using the 'roundHalfEven' method.--squareRoot :: Dec -> Ctx Dec-squareRoot = unary c'mpd_sqrt---- | Returns the reciprocal of the square root. This function--- always uses 'roundHalfEven'. Results are not correctly rounded--- even if 'setAllCorrectRound' is True.--inverseSquareRoot :: Dec -> Ctx Dec-inverseSquareRoot = unary c'mpd_invroot----- | Subtraction.--subtract :: Dec -> Dec -> Ctx Dec-subtract = binary c'mpd_sub---- | Round to an integer, using the rounding mode of the context.--- Only a signaling NaN causes an 'invalidOperation'--- condition.--toIntegralExact :: Dec -> Ctx Dec-toIntegralExact = unary c'mpd_round_to_intx---- | Like 'toIntegralExact', but 'inexact' and 'rounded' are never--- set.-toIntegralValue :: Dec -> Ctx Dec-toIntegralValue = unary c'mpd_round_to_int--floor :: Dec -> Ctx Dec-floor = unary c'mpd_floor--ceiling :: Dec -> Ctx Dec-ceiling = unary c'mpd_ceil--truncate :: Dec -> Ctx Dec-truncate = unary c'mpd_trunc---- | Digit-wise logical exclusive or.--xor :: Dec -> Dec -> Ctx Dec-xor = binary c'mpd_xor---- | Returns the closest representable number that is smaller than--- the operand.-nextMinus :: Dec -> Ctx Dec-nextMinus = unary c'mpd_next_minus---- | Returns the closest representable number that is larger than--- the operand.-nextPlus :: Dec -> Ctx Dec-nextPlus = unary c'mpd_next_plus---- | @nextToward a b@ returns the representable number closest to--- @a@ in the direction of @b@.--nextToward :: Dec -> Dec -> Ctx Dec-nextToward = binary c'mpd_next_toward--toBool :: Integral a => a -> Bool-toBool i- | i == 0 = False- | otherwise = True---- | False if the decimal is special or zero, or the exponent is--- less than 'Emin'. True otherwise.--isNormal :: Dec -> Ctx Bool-isNormal d = Ctx $ \p ->- withDec d $ \pd ->- c'mpd_isnormal pd p >>= \i ->- return (toBool i)---- | False if the decimal is special or zero, or the exponent is--- greater or equal to 'Emin'. True otherwise.-isSubnormal :: Dec -> Ctx Bool-isSubnormal d = Ctx $ \p ->- withDec d $ \pd ->- c'mpd_issubnormal pd p >>= \i ->- return (toBool i)--data PosNeg = Pos | Neg- deriving (Eq, Ord, Show)--data Number- = Infinity- | Normal- | Subnormal- | Zero- deriving (Eq, Ord, Show)--data Class- = SNaN- | NaN- | Number PosNeg Number- deriving (Eq, Ord, Show)--strToClass :: IsString a => [(a, Class)]-strToClass =- [ ("sNaN", SNaN)- , ("NaN", NaN)- , ("-Infinity", Number Neg Infinity)- , ("-Normal", Number Neg Normal)- , ("-Subnormal", Number Neg Subnormal)- , ("-Zero", Number Neg Zero)- , ("+Zero", Number Pos Zero)- , ("+Subnormal", Number Pos Subnormal)- , ("+Normal", Number Pos Normal)- , ("+Infinity", Number Pos Infinity)- ]---- | Determines the 'Class' of a 'Dec'.--numClass :: Dec -> Ctx Class-numClass d = Ctx $ \pCtx ->- withDec d $ \pd ->- c'mpd_class pd pCtx >>= \chars ->- BS8.packCString chars >>= \bs ->- return . maybe (error "numClass: class not found") id- . lookup bs $ strToClass-
− lib/Deka/Internal/Dec/CtxFree.hs
@@ -1,141 +0,0 @@-{-# LANGUAGE EmptyDataDecls, Trustworthy #-}--module Deka.Internal.Dec.CtxFree where--import Foreign.Safe-import qualified Data.ByteString.Char8 as BS8-import Prelude-import Foreign.C.Types-import Deka.Internal.Mpdec-import System.IO.Unsafe (unsafePerformIO)--numToOrd :: (Num a, Ord a) => a -> Ordering-numToOrd a- | a < 0 = LT- | a > 0 = GT- | otherwise = EQ---- | @compareTotal x y@ compares to numbers using the IEEE 754 total--- ordering. If @x@ is less--- than @y@, returns @-1@. If they are equal (that is, when--- subtracted the result would be 0), returns @0@. If @y@ is--- greater than @x@, returns @1@. ------ Here is the total ordering:------ @-NaN < -sNaN < -Infinity < -finites < -0 < +0 < +finites--- < +Infinity < +SNaN < +NaN@------ Also, @1.000@ < @1.0@ (etc.) and NaNs are ordered by payload.-compareTotal :: Dec -> Dec -> Ordering-compareTotal x y = unsafePerformIO $- withDec x $ \px ->- withDec y $ \py ->- c'mpd_cmp_total px py >>= \i ->- return (numToOrd i)---- | Same as 'compareTotal' except that the signs of the operands--- are ignored and taken to be 0 (non-negative).--compareTotalMag :: Dec -> Dec -> Ordering-compareTotalMag x y = unsafePerformIO $- withDec x $ \px ->- withDec y $ \py ->- c'mpd_cmp_total_mag px py >>= \i ->- return (numToOrd i)---- | Converts a number to engineering notation.-toEngByteString :: Dec -> BS8.ByteString-toEngByteString dn = unsafePerformIO $- withDec dn $ \pDn ->- c'mpd_to_eng pDn capitalize >>= \bytes ->- BS8.packCString bytes >>= \bs ->- free bytes >>= \_ ->- return bs---- | Converts a number to scientific notation.-toByteString :: Dec -> BS8.ByteString-toByteString dn = unsafePerformIO $- withDec dn $ \pDn ->- c'mpd_to_sci pDn capitalize >>= \bytes ->- BS8.packCString bytes >>= \bs ->- free bytes >>= \_ ->- return bs---- | True if both operands have the same exponent; False otherwise.-sameQuantum :: Dec -> Dec -> Bool-sameQuantum x y = unsafePerformIO $- withDec x $ \px ->- withDec y $ \py ->- c'mpd_same_quantum px py >>= \r ->- return $ if r == 0 then False else True--version :: BS8.ByteString-version = c'MPD_VERSION--testBool- :: (CMpd -> IO CInt)- -> Dec- -> Bool-testBool f d = unsafePerformIO $- withDec d $ \pd ->- f pd >>= \bl ->- return (toBool bl)--isFinite :: Dec -> Bool-isFinite = testBool c'mpd_isfinite--isInfinite :: Dec -> Bool-isInfinite = testBool c'mpd_isinfinite--isNaN :: Dec -> Bool-isNaN = testBool c'mpd_isnan--isNegative :: Dec -> Bool-isNegative = testBool c'mpd_isnegative--isPositive :: Dec -> Bool-isPositive = testBool c'mpd_ispositive--isSigned :: Dec -> Bool-isSigned = testBool c'mpd_issigned--isQNaN :: Dec -> Bool-isQNaN = testBool c'mpd_isqnan--isSNaN :: Dec -> Bool-isSNaN = testBool c'mpd_issnan--isSpecial :: Dec -> Bool-isSpecial = testBool c'mpd_isspecial--isZero :: Dec -> Bool-isZero = testBool c'mpd_iszero--isZeroCoeff :: Dec -> Bool-isZeroCoeff = testBool c'mpd_iszerocoeff--isOddCoeff :: Dec -> Bool-isOddCoeff = testBool c'mpd_isoddcoeff--data Sign = Sign0 | Sign1- deriving (Eq, Ord, Show)--sign :: Dec -> Sign-sign d = unsafePerformIO $- withDec d $ \pd ->- c'mpd_sign pd >>= \i ->- return $ if i == 0 then Sign0 else Sign1--data EvenOdd = Even | Odd- deriving (Eq, Show)--evenOdd :: Dec -> (Maybe EvenOdd)-evenOdd d = unsafePerformIO $- withDec d $ \pd ->- c'mpd_isinteger pd >>= \isint ->- if isint /= 0- then c'mpd_isodd pd >>= \oddR ->- return $ if oddR == 0 then Just Even else Just Odd- else return Nothing-
− lib/Deka/Internal/Mpdec.hsc
@@ -1,838 +0,0 @@-{-# LANGUAGE EmptyDataDecls, Safe #-}-{-# LANGUAGE OverloadedStrings #-}-#include <mpdecimal.h>--#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)--module Deka.Internal.Mpdec- ( - -- * Context- Signed- , Unsigned- , C'mpd_context_t- , c'MPD_VERSION- , c'MPD_SSIZE_MAX- , c'MPD_SSIZE_MIN- , c'MPD_MAX_PREC- , c'MPD_MAX_EMAX- , c'MPD_MIN_EMIN- , c'MPD_ROUND_UP- , c'MPD_ROUND_DOWN- , c'MPD_ROUND_CEILING- , c'MPD_ROUND_FLOOR- , c'MPD_ROUND_HALF_UP- , c'MPD_ROUND_HALF_DOWN- , c'MPD_ROUND_HALF_EVEN- , c'MPD_ROUND_05UP- , c'MPD_ROUND_TRUNC- , c'mpd_context_t'sizeOf- , p'mpd_context_t'prec- , p'mpd_context_t'emax- , p'mpd_context_t'emin- , p'mpd_context_t'traps- , p'mpd_context_t'status- , p'mpd_context_t'newtrap- , p'mpd_context_t'round- , p'mpd_context_t'clamp- , p'mpd_context_t'allcr- , c'MPD_Clamped- , c'MPD_Conversion_syntax- , c'MPD_Division_by_zero- , c'MPD_Division_impossible- , c'MPD_Division_undefined- , c'MPD_Fpu_error- , c'MPD_Inexact- , c'MPD_Invalid_context- , c'MPD_Invalid_operation- , c'MPD_Malloc_error- , c'MPD_Not_implemented- , c'MPD_Overflow- , c'MPD_Rounded- , c'MPD_Subnormal- , c'MPD_Underflow- , c'mpd_maxcontext- , c'mpd_defaultcontext- , c'mpd_basiccontext- , c'mpd_ieee_context-- -- * Mpdec- , CMpd- , Mpd- , Dec- , withDec- , newDec- , newDec2- , c'divmod- , c'mpd_fma- , c'mpd_powmod- , c'mpd_adjexp- , capitalize- , c'mpd_to_sci- , c'mpd_to_eng- , c'mpd_set_string- , c'mpd_compare_total- , c'mpd_cmp_total- , c'mpd_compare_total_mag- , c'mpd_cmp_total_mag- , c'mpd_same_quantum- , c'mpd_class- , c'mpd_isnormal- , c'mpd_issubnormal- , c'mpd_sign- , c'mpd_arith_sign- , c'mpd_trail_zeros- , c'mpd_del- , c'mpd_copy- , c'mpd_copy_abs- , c'mpd_copy_negate- , c'mpd_invert- , c'mpd_logb- , c'mpd_abs- , c'mpd_exp- , c'mpd_ln- , c'mpd_log10- , c'mpd_minus- , c'mpd_next_minus- , c'mpd_next_plus- , c'mpd_plus- , c'mpd_reduce- , c'mpd_round_to_intx- , c'mpd_round_to_int- , c'mpd_trunc- , c'mpd_floor- , c'mpd_ceil- , c'mpd_sqrt- , c'mpd_invroot- , c'mpd_and- , c'mpd_copy_sign- , c'mpd_or- , c'mpd_rotate- , c'mpd_scaleb- , c'mpd_shift- , c'mpd_xor- , c'mpd_compare- , c'mpd_compare_signal- , c'mpd_add- , c'mpd_sub- , c'mpd_div- , c'mpd_divint- , c'mpd_max- , c'mpd_max_mag- , c'mpd_min- , c'mpd_min_mag- , c'mpd_mul- , c'mpd_next_toward- , c'mpd_pow- , c'mpd_quantize- , c'mpd_rescale- , c'mpd_rem- , c'mpd_rem_near- , c'mpd_isfinite- , c'mpd_isinfinite- , c'mpd_isinteger- , c'mpd_isnan- , c'mpd_isnegative- , c'mpd_ispositive- , c'mpd_isqnan- , c'mpd_issnan- , c'mpd_issigned- , c'mpd_isspecial- , c'mpd_iszero- , c'mpd_iszerocoeff- , c'mpd_isoddcoeff- , c'mpd_isodd- , c'mpd_iseven- ) where--import Foreign.Safe-import Foreign.C-import Control.Monad-import Data.String--c'MPD_VERSION :: IsString a => a-c'MPD_VERSION = #const_str MPD_VERSION---- | An unsigned integer. Its size is platform dependent.-type Unsigned = #type mpd_size_t---- | A signed integer. Its size is platform dependent.-type Signed = #type mpd_ssize_t--c'MPD_SSIZE_MAX :: Signed-c'MPD_SSIZE_MAX = #const MPD_SSIZE_MAX---- Must convert the constant to an Integer first; it will overflow--- otherwise. GHC's NegativeLiterals extension solves this problem,--- but it is not available on GHC < 7.8.-c'MPD_SSIZE_MIN :: Signed-c'MPD_SSIZE_MIN = fromInteger $ #const MPD_SSIZE_MIN--c'MPD_MAX_PREC :: Signed-c'MPD_MAX_PREC = #const MPD_MAX_PREC--c'MPD_MAX_EMAX :: Signed-c'MPD_MAX_EMAX = #const MPD_MAX_EMAX--c'MPD_MIN_EMIN :: Signed-c'MPD_MIN_EMIN = #const MPD_MIN_EMIN--c'MPD_ROUND_UP :: CInt-c'MPD_ROUND_UP = #const MPD_ROUND_UP--c'MPD_ROUND_DOWN :: CInt-c'MPD_ROUND_DOWN = #const MPD_ROUND_DOWN--c'MPD_ROUND_CEILING :: CInt-c'MPD_ROUND_CEILING = #const MPD_ROUND_CEILING--c'MPD_ROUND_FLOOR :: CInt-c'MPD_ROUND_FLOOR = #const MPD_ROUND_FLOOR--c'MPD_ROUND_HALF_UP :: CInt-c'MPD_ROUND_HALF_UP = #const MPD_ROUND_HALF_UP--c'MPD_ROUND_HALF_DOWN :: CInt-c'MPD_ROUND_HALF_DOWN = #const MPD_ROUND_HALF_DOWN--c'MPD_ROUND_HALF_EVEN :: CInt-c'MPD_ROUND_HALF_EVEN = #const MPD_ROUND_HALF_EVEN--c'MPD_ROUND_05UP :: CInt-c'MPD_ROUND_05UP = #const MPD_ROUND_05UP--c'MPD_ROUND_TRUNC :: CInt-c'MPD_ROUND_TRUNC = #const MPD_ROUND_TRUNC--data C'mpd_context_t--c'mpd_context_t'sizeOf :: Int-c'mpd_context_t'sizeOf = #size mpd_context_t--p'mpd_context_t'prec :: Ptr C'mpd_context_t -> Ptr Signed-p'mpd_context_t'prec = #ptr mpd_context_t, prec--p'mpd_context_t'emax :: Ptr C'mpd_context_t -> Ptr Signed-p'mpd_context_t'emax = #ptr mpd_context_t, emax--p'mpd_context_t'emin :: Ptr C'mpd_context_t -> Ptr Signed-p'mpd_context_t'emin = #ptr mpd_context_t, emin--p'mpd_context_t'traps :: Ptr C'mpd_context_t -> Ptr Word32-p'mpd_context_t'traps = #ptr mpd_context_t, traps--p'mpd_context_t'status :: Ptr C'mpd_context_t -> Ptr Word32-p'mpd_context_t'status = #ptr mpd_context_t, status--p'mpd_context_t'newtrap :: Ptr C'mpd_context_t -> Ptr Word32-p'mpd_context_t'newtrap = #ptr mpd_context_t, newtrap--p'mpd_context_t'round :: Ptr C'mpd_context_t -> Ptr CInt-p'mpd_context_t'round = #ptr mpd_context_t, round--p'mpd_context_t'clamp :: Ptr C'mpd_context_t -> Ptr CInt-p'mpd_context_t'clamp = #ptr mpd_context_t, clamp--p'mpd_context_t'allcr :: Ptr C'mpd_context_t -> Ptr CInt-p'mpd_context_t'allcr = #ptr mpd_context_t, allcr--c'MPD_Clamped :: Word32-c'MPD_Clamped = #const MPD_Clamped--c'MPD_Conversion_syntax :: Word32-c'MPD_Conversion_syntax = #const MPD_Conversion_syntax--c'MPD_Division_by_zero :: Word32-c'MPD_Division_by_zero = #const MPD_Division_by_zero--c'MPD_Division_impossible :: Word32-c'MPD_Division_impossible = #const MPD_Division_impossible--c'MPD_Division_undefined :: Word32-c'MPD_Division_undefined = #const MPD_Division_undefined--c'MPD_Fpu_error :: Word32-c'MPD_Fpu_error = #const MPD_Fpu_error--c'MPD_Inexact :: Word32-c'MPD_Inexact = #const MPD_Inexact--c'MPD_Invalid_context :: Word32-c'MPD_Invalid_context = #const MPD_Invalid_context--c'MPD_Invalid_operation :: Word32-c'MPD_Invalid_operation = #const MPD_Invalid_operation--c'MPD_Malloc_error :: Word32-c'MPD_Malloc_error = #const MPD_Malloc_error--c'MPD_Not_implemented :: Word32-c'MPD_Not_implemented = #const MPD_Not_implemented--c'MPD_Overflow :: Word32-c'MPD_Overflow = #const MPD_Overflow--c'MPD_Rounded :: Word32-c'MPD_Rounded = #const MPD_Rounded--c'MPD_Subnormal :: Word32-c'MPD_Subnormal = #const MPD_Subnormal--c'MPD_Underflow :: Word32-c'MPD_Underflow = #const MPD_Underflow--foreign import ccall unsafe "mpd_maxcontext" c'mpd_maxcontext- :: Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_defaultcontext" c'mpd_defaultcontext- :: Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_basiccontext" c'mpd_basiccontext- :: Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_ieee_context" c'mpd_ieee_context- :: Ptr C'mpd_context_t- -> CInt- -> IO CInt------- mpd_t-----data C'mpd_t--newtype CMpd = CMpd { _unCMpd :: Ptr C'mpd_t }-newtype Mpd = Mpd { unMpd :: Ptr C'mpd_t }---- | A decimal value. A decimal consists of:------ * an integral /coefficient/,------ * an /exponent/, and------ * a /sign/.------ A decimal may also be a /special value/, which can be:------ * /NaN/ (Not a Number), which may be either /quiet/--- (propagates quietly through operations) or /signaling/ (raises--- the /Invalid operation/ condition when encountered), or------ * /Infinity/, either positive or negative.--newtype Dec = Dec { _unDec :: ForeignPtr C'mpd_t }--withDec :: Dec -> (CMpd -> IO a) -> IO a-withDec (Dec fp) f =- withForeignPtr fp $ \ptr ->- f (CMpd ptr)---- Irregular arithmetics--foreign import ccall unsafe "mpd_divmod" c'divmod- :: Mpd- -> Mpd- -> CMpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_fma" c'mpd_fma- :: Mpd- -> CMpd- -> CMpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_powmod" c'mpd_powmod- :: Mpd- -> CMpd- -> CMpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_adjexp" c'mpd_adjexp- :: CMpd- -> IO Signed---- Output to string--foreign import ccall unsafe "mpd_to_sci" c'mpd_to_sci- :: CMpd- -> CInt- -> IO (Ptr CChar)---- | Set to 1 to capitalize the exponent character; otherwise, if it--- is 0, the exponent character is lower case.-capitalize :: CInt-capitalize = 1--foreign import ccall unsafe "mpd_to_eng" c'mpd_to_eng- :: CMpd- -> CInt- -> IO (Ptr CChar)--foreign import ccall unsafe "mpd_set_string" c'mpd_set_string- :: Mpd- -> Ptr CChar- -> Ptr C'mpd_context_t- -> IO ()---- comparisons---- compare_total is context free-foreign import ccall unsafe "mpd_compare_total" c'mpd_compare_total- :: Mpd- -> CMpd- -> CMpd- -> IO CInt--foreign import ccall unsafe "mpd_cmp_total" c'mpd_cmp_total- :: CMpd- -> CMpd- -> IO CInt---- total_mag is context free-foreign import ccall unsafe "mpd_compare_total_mag" c'mpd_compare_total_mag- :: Mpd- -> CMpd- -> CMpd- -> IO CInt--foreign import ccall unsafe "mpd_cmp_total_mag" c'mpd_cmp_total_mag- :: CMpd- -> CMpd- -> IO CInt--foreign import ccall unsafe "mpd_same_quantum" c'mpd_same_quantum- :: CMpd- -> CMpd- -> IO CInt---- Tests--foreign import ccall unsafe "mpd_class" c'mpd_class- :: CMpd- -> Ptr C'mpd_context_t- -> IO (Ptr CChar)--foreign import ccall unsafe "mpd_isnormal" c'mpd_isnormal- :: CMpd- -> Ptr C'mpd_context_t- -> IO CInt--foreign import ccall unsafe "mpd_issubnormal" c'mpd_issubnormal- :: CMpd- -> Ptr C'mpd_context_t- -> IO CInt--foreign import ccall unsafe "mpd_sign" c'mpd_sign- :: CMpd- -> IO Word8--foreign import ccall unsafe "mpd_arith_sign" c'mpd_arith_sign- :: CMpd- -> IO CInt--foreign import ccall unsafe "mpd_trail_zeros" c'mpd_trail_zeros- :: CMpd- -> IO Signed---- Memory handling-foreign import ccall unsafe "mpd_qnew" c'mpd_qnew- :: IO (Mpd)--newDec :: (Mpd -> IO ()) -> IO Dec-newDec f = do- p <- c'mpd_qnew- when (unMpd p == nullPtr) $ error "newMpd: failure"- fp <- newForeignPtr fp'mpd_del (unMpd p)- withForeignPtr fp $ \x1 ->- f (Mpd x1)- return $ Dec fp--newDec2 :: (Mpd -> Mpd -> IO ()) -> IO (Dec, Dec)-newDec2 f = do- p1 <- c'mpd_qnew- when (unMpd p1 == nullPtr) $ error "newMpd: failure"- p2 <- c'mpd_qnew- when (unMpd p2 == nullPtr) $ error "newMpd: failure"- fp1 <- newForeignPtr fp'mpd_del (unMpd p1)- fp2 <- newForeignPtr fp'mpd_del (unMpd p2)- withForeignPtr fp1 $ \x1 ->- withForeignPtr fp2 $ \x2 ->- f (Mpd x1) (Mpd x2)- return (Dec fp1, Dec fp2)---foreign import ccall unsafe "mpd_del" c'mpd_del- :: Mpd- -> IO ()--foreign import ccall unsafe "&mpd_del" fp'mpd_del- :: FunPtr (Ptr C'mpd_t -> IO ())---- Imported from mkmpd--foreign import ccall unsafe "mpd_copy" c'mpd_copy- :: Mpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_copy_abs" c'mpd_copy_abs- :: Mpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_copy_negate" c'mpd_copy_negate- :: Mpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_invert" c'mpd_invert- :: Mpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_logb" c'mpd_logb- :: Mpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_abs" c'mpd_abs- :: Mpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_exp" c'mpd_exp- :: Mpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_ln" c'mpd_ln- :: Mpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_log10" c'mpd_log10- :: Mpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_minus" c'mpd_minus- :: Mpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_next_minus" c'mpd_next_minus- :: Mpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_next_plus" c'mpd_next_plus- :: Mpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_plus" c'mpd_plus- :: Mpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_reduce" c'mpd_reduce- :: Mpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_round_to_intx" c'mpd_round_to_intx- :: Mpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_round_to_int" c'mpd_round_to_int- :: Mpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_trunc" c'mpd_trunc- :: Mpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_floor" c'mpd_floor- :: Mpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_ceil" c'mpd_ceil- :: Mpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_sqrt" c'mpd_sqrt- :: Mpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_invroot" c'mpd_invroot- :: Mpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()---foreign import ccall unsafe "mpd_and" c'mpd_and- :: Mpd- -> CMpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_copy_sign" c'mpd_copy_sign- :: Mpd- -> CMpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_or" c'mpd_or- :: Mpd- -> CMpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_rotate" c'mpd_rotate- :: Mpd- -> CMpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_scaleb" c'mpd_scaleb- :: Mpd- -> CMpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_shift" c'mpd_shift- :: Mpd- -> CMpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_xor" c'mpd_xor- :: Mpd- -> CMpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_compare" c'mpd_compare- :: Mpd- -> CMpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_compare_signal" c'mpd_compare_signal- :: Mpd- -> CMpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_add" c'mpd_add- :: Mpd- -> CMpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_sub" c'mpd_sub- :: Mpd- -> CMpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_div" c'mpd_div- :: Mpd- -> CMpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_divint" c'mpd_divint- :: Mpd- -> CMpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_max" c'mpd_max- :: Mpd- -> CMpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_max_mag" c'mpd_max_mag- :: Mpd- -> CMpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_min" c'mpd_min- :: Mpd- -> CMpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_min_mag" c'mpd_min_mag- :: Mpd- -> CMpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_mul" c'mpd_mul- :: Mpd- -> CMpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_next_toward" c'mpd_next_toward- :: Mpd- -> CMpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_pow" c'mpd_pow- :: Mpd- -> CMpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_quantize" c'mpd_quantize- :: Mpd- -> CMpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_rescale" c'mpd_rescale- :: Mpd- -> CMpd- -> Signed- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_rem" c'mpd_rem- :: Mpd- -> CMpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_rem_near" c'mpd_rem_near- :: Mpd- -> CMpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--foreign import ccall unsafe "mpd_isfinite" c'mpd_isfinite- :: CMpd- -> IO CInt--foreign import ccall unsafe "mpd_isinfinite" c'mpd_isinfinite- :: CMpd- -> IO CInt--foreign import ccall unsafe "mpd_isinteger" c'mpd_isinteger- :: CMpd- -> IO CInt--foreign import ccall unsafe "mpd_isnan" c'mpd_isnan- :: CMpd- -> IO CInt--foreign import ccall unsafe "mpd_isnegative" c'mpd_isnegative- :: CMpd- -> IO CInt--foreign import ccall unsafe "mpd_ispositive" c'mpd_ispositive- :: CMpd- -> IO CInt--foreign import ccall unsafe "mpd_isqnan" c'mpd_isqnan- :: CMpd- -> IO CInt--foreign import ccall unsafe "mpd_issnan" c'mpd_issnan- :: CMpd- -> IO CInt--foreign import ccall unsafe "mpd_issigned" c'mpd_issigned- :: CMpd- -> IO CInt--foreign import ccall unsafe "mpd_isspecial" c'mpd_isspecial- :: CMpd- -> IO CInt--foreign import ccall unsafe "mpd_iszero" c'mpd_iszero- :: CMpd- -> IO CInt--foreign import ccall unsafe "mpd_iszerocoeff" c'mpd_iszerocoeff- :: CMpd- -> IO CInt--foreign import ccall unsafe "mpd_isoddcoeff" c'mpd_isoddcoeff- :: CMpd- -> IO CInt--foreign import ccall unsafe "mpd_isodd" c'mpd_isodd- :: CMpd- -> IO CInt--foreign import ccall unsafe "mpd_iseven" c'mpd_iseven- :: CMpd- -> IO CInt---- Handlers--
− lib/Deka/Internal/Unsafe.hs
@@ -1,19 +0,0 @@-module Deka.Internal.Unsafe where--import System.IO.Unsafe (unsafePerformIO)--unsafe0 :: IO a -> a-unsafe0 = unsafePerformIO--unsafe1 :: (a -> IO b) -> a -> b-unsafe1 f a = unsafePerformIO (f a)--unsafe2 :: (a -> b -> IO c) -> a -> b -> c-unsafe2 f a b = unsafePerformIO (f a b)--unsafe3 :: (a -> b -> c -> IO d) -> a -> b -> c -> d-unsafe3 f a b c = unsafePerformIO (f a b c)--unsafe4 :: (a -> b -> c -> d -> IO e) -> a -> b -> c -> d -> e-unsafe4 f a b c d = unsafePerformIO (f a b c d)-
− lib/Deka/Internal/Util/Ctx.hs
@@ -1,48 +0,0 @@-{-# LANGUAGE Safe #-}-module Deka.Internal.Util.Ctx where--import Deka.Internal.Mpdec-import Deka.Internal.Context-import Foreign.Safe--type Unary- = Mpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--unary :: Unary -> Dec -> Ctx Dec-unary f d = Ctx $ \p ->- newDec $ \nw ->- withDec d $ \old ->- f nw old p--type Binary- = Mpd- -> CMpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--binary :: Binary -> Dec -> Dec -> Ctx Dec-binary f a b = Ctx $ \p ->- newDec $ \nw ->- withDec a $ \pa ->- withDec b $ \pb ->- f nw pa pb p--type Ternary- = Mpd- -> CMpd- -> CMpd- -> CMpd- -> Ptr C'mpd_context_t- -> IO ()--ternary :: Ternary -> Dec -> Dec -> Dec -> Ctx Dec-ternary f a b c = Ctx $ \p ->- newDec $ \n ->- withDec a $ \pa ->- withDec b $ \pb ->- withDec c $ \pc ->- f n pa pb pc p
− lib/Deka/Native.hs
@@ -1,88 +0,0 @@--- | Representation of numbers in native Haskell types.------ Since deka is a binding to the mpdecimal C library, the data--- types are held as pointers to data which are managed by C--- functions. Therefore there is no direct access to what is inside--- of the the 'Deka.Dec' data type. Modules in "Deka.Native"--- provide Haskell types mirroring the abstract representations--- given in the General Decimal Arithmetic Specification. This is--- useful if you want to manipulate the data in an abstract way.--- For example, perhaps you want to perform arithmetic on a value,--- transform it to abstract form, add digit grouping characters, and--- then use your own functions to pretty print the result.------ The General Decimal Arithmetic Specification gives an abstract--- representation of each number. This information is taken from--- the General Decimal Arithmetic specification at------ <http://speleotrove.com/decimal/damodel.html>------ A number may be /finite/, in--- which case it has three components: a /sign/, which must be zero--- (for zero or positive numbers) or one (for negative zero and--- negative numbers), an integral /coefficient/, which is always--- zero or positive, and a signed integral /exponent/, which--- indicates the power of ten by which the number is multiplied.--- The value of a finite number if given by------ > (-1) ^ sign * coefficient * 10 ^ exponent------ In addition to finite numbers, a number may also be one of three--- /special values/:------ * /infinity/ - numbers infinitely large in magnitude------ * /quiet NaN/ - an undefined result which does not cause an--- 'invalidOperation' condition.------ * /signaling NaN/ - an undefined result which will usually cause--- an 'invalidOperation' condition.------ When a number has one of these special values, its /coefficient/--- and /exponent/ are undefined. An NaN, however, may have--- additional /diagnostic information/, which is a positive integer.------ All special values have a sign. The sign of an infinity is--- significant. The sign of an NaN has no meaning, though it may be--- considered as part of the diagnostic information.------ You can transform an abstract form to a 'Dec' losslessly by using--- 'abstractToByteString'. This gives you a string in scientific--- notation, as specified in @to-scientific-string@ in the--- specification. There is a one-to-one mapping of abstract--- representations to @scientific-string@ representations. You can--- also transform a 'Dec' to an 'Abstract' losslessly by using--- 'abstractFromByteString'. This operation will not fail if it is--- using output from 'toByteString'; but it might fail otherwise, if--- the input is malformed.------ All standard typeclass instances in these modules are derived; so--- while the 'Ord' instance might be useful to use 'Abstract' as the--- key in a Map, don't expect it to tell you anything about how--- 'Abstract' are situated on the number line.-module Deka.Native- ( -- * Digits and groups of digits- Novem(..)- , Decem(..)- , Decuple(..)- , Aut(..)- , Firmado(..)-- -- * Elements of abstract numbers- , Coefficient(..)- , Exponent(..)- , Diagnostic(..)- , Noisy(..)- , NonNum(..)- , Value(..)- , Abstract(..)-- -- * Transformations- , abstractToString- , abstractToDec- , stringToAbstract- , decToAbstract- ) where--import Deka.Native.Abstract-import Deka.Native.FromString (stringToAbstract, decToAbstract)
− lib/Deka/Native/Abstract.hs
@@ -1,330 +0,0 @@-{-# LANGUAGE OverloadedStrings, BangPatterns #-}--module Deka.Native.Abstract where--import Deka.Dec-import Prelude hiding (exponent)-import Control.Monad-import Data.List (foldl')-import qualified Data.ByteString.Char8 as BS8---- # Types---- | A digit from one to nine. Useful to represent a most--- significant digit, or MSD, as an MSD cannot be the digit zero.-data Novem = D1 | D2 | D3 | D4 | D5 | D6 | D7 | D8 | D9- deriving (Eq, Ord, Show, Enum, Bounded)--novemToChar :: Novem -> Char-novemToChar n = case n of- { D1 -> '1'; D2 -> '2'; D3 -> '3'; D4 -> '4'; D5 -> '5';- D6 -> '6'; D7 -> '7'; D8 -> '8'; D9 -> '9' }--charToNovem :: Char -> Maybe Novem-charToNovem c = case c of- { '1' -> Just D1; '2' -> Just D2; '3' -> Just D3;- '4' -> Just D4; '5' -> Just D5; '6' -> Just D6; '7' -> Just D7;- '8' -> Just D8; '9' -> Just D9; _ -> Nothing }--novemToInt :: Integral a => Novem -> a-novemToInt d = case d of- { D1 -> 1; D2 -> 2; D3 -> 3; D4 -> 4; D5 -> 5; D6 -> 6;- D7 -> 7; D8 -> 8; D9 -> 9 }--intToNovem :: Integral a => a -> Maybe Novem-intToNovem a = case a of- { 1 -> Just D1; 2 -> Just D2; 3 -> Just D3; 4 -> Just D4;- 5 -> Just D5; 6 -> Just D6;- 7 -> Just D7; 8 -> Just D8; 9 -> Just D9; _ -> Nothing }---- | A digit from zero to nine.-data Decem- = D0- | Nonem Novem- deriving (Eq, Ord, Show)--decemToChar :: Decem -> Char-decemToChar d = case d of- { D0 -> '0'; Nonem n -> novemToChar n }--charToDecem :: Char -> Maybe Decem-charToDecem c = case c of- { '0' -> Just D0; _ -> fmap Nonem (charToNovem c) }--decemToInt :: Integral a => Decem -> a-decemToInt d = case d of- { D0 -> 0; Nonem n -> novemToInt n }--decemToNovem :: Decem -> Maybe Novem-decemToNovem d = case d of- Nonem n -> Just n- _ -> Nothing--intToDecem :: Integral a => a -> Maybe Decem-intToDecem i = case i of- { 0 -> Just D0; _ -> fmap Nonem $ intToNovem i }--intToDecemList :: Integral a => a -> (Sign, [Decem])-intToDecemList x = (sgn, ls)- where- sgn | x < 0 = Sign1- | otherwise = Sign0- ls = reverse . go . Prelude.abs $ x- go !i =- let (d, m) = i `divMod` 10- r = maybe (error "intToDecemList: error") id- . intToDecem $ m- in if i == 0- then []- else r : go d--decemListToInt :: Integral a => [Decem] -> a-decemListToInt ds = foldl' f 0 . indices $ ds- where- indices = zip (iterate pred (length ds - 1))- f acc (ix, d) = acc + decemToInt d * 10 ^ ix---- | A non-empty set of digits. The MSD must be from 1 to 9.--data Decuple = Decuple Novem [Decem]- deriving (Eq, Ord, Show)--decupleToString :: Decuple -> String-decupleToString (Decuple msd rest) =- novemToChar msd : map decemToChar rest--stringToDecuple :: String -> Maybe Decuple-stringToDecuple str = case str of- [] -> Nothing- x:xs -> liftM2 Decuple (charToNovem x) (mapM charToDecem xs)--decupleToInt :: Integral a => Decuple -> a-decupleToInt (Decuple n ds) =- let len = length ds- go !soFar !i digs = case digs of- [] -> soFar- x:xs ->- let nxt = i - 1- thisSum = soFar + decemToInt x * 10 ^ nxt- in go thisSum nxt xs- in novemToInt n * (10 ^ len) + go 0 len ds--uncons :: [a] -> Maybe (a, [a])-uncons a = case a of- [] -> Nothing- x:xs -> Just (x, xs)--intToDecuple :: Integral a => a -> Maybe (Sign, Decuple)-intToDecuple x = do- let (sgn, ds) = intToDecemList x- (d1, dr) <- uncons ds- let nv = maybe (error "intToDecuple: MSD is not zero") id- . decemToNovem $ d1- return (sgn, Decuple nv dr)--decemListToDecuple :: [Decem] -> Maybe Decuple-decemListToDecuple ds = case dropWhile (== D0) ds of- [] -> Nothing- x:xs -> Just $ Decuple d1 xs- where- d1 = maybe (error "decemListToDecuple: bad MSD") id- . decemToNovem $ x----- | Either a set of digits, or zero. Unsigned.--data Aut- = Nil- -- ^ Zero- | Plenus Decuple- -- ^ Non-zero- deriving (Eq, Ord, Show)--autToString :: Aut -> String-autToString a = case a of- Nil -> "0"- Plenus ds -> decupleToString ds--stringToAut :: String -> Maybe Aut-stringToAut s = case s of- "0" -> Just Nil- _ -> fmap Plenus $ stringToDecuple s--autToInt :: Integral a => Aut -> a-autToInt a = case a of- Nil -> 0- Plenus d -> decupleToInt d---- | Fails if the argument is less than zero.-intToAut :: Integral a => a -> Maybe Aut-intToAut a = case intToDecuple a of- Nothing -> Just Nil- Just (s, d) -> case s of- Sign1 -> Nothing- _ -> return . Plenus $ d--decemListToAut :: [Decem] -> Aut-decemListToAut ds = case dropWhile (== D0) ds of- [] -> Nil- x:xs -> Plenus $ Decuple d1 xs- where- d1 = maybe (error "decemListToAut: bad MSD") id- . decemToNovem $ x---- | Either a set of digits, or zero. Signed.--data Firmado- = Cero- -- ^ Zero- | Completo PosNeg Decuple- -- ^ Non-zero- deriving (Eq, Ord, Show)--firmadoToString :: Firmado -> String-firmadoToString x = case x of- Cero -> "0"- Completo p d -> sgn : decupleToString d- where- sgn = case p of { Pos -> '+'; Neg -> '-' }--stringToFirmado :: String -> Maybe Firmado-stringToFirmado s- | s == "0" = Just Cero- | otherwise = do- (sgn, rst) <- case s of- "" -> Nothing- x:xs -> case x of- '+' -> return (Pos, xs)- '-' -> return (Neg, xs)- _ -> Nothing- dec <- stringToDecuple rst- return $ Completo sgn dec--firmadoToInt :: Integral a => Firmado -> a-firmadoToInt x = case x of- Cero -> 0- Completo p d -> apply . decupleToInt $ d- where- apply = case p of { Pos -> id; Neg -> negate }--intToFirmado :: Integral a => a -> Firmado-intToFirmado i = case intToDecuple i of- Nothing -> Cero- Just (sgn, d) -> Completo p d- where- p = case sgn of { Sign0 -> Pos; Sign1 -> Neg }-------- Types in Abstract------- | The coefficient in a number; not used in infinities or NaNs.-newtype Coefficient = Coefficient { unCoefficient :: Aut }- deriving (Eq, Ord, Show)---- | The exponent in a number.-newtype Exponent = Exponent { unExponent :: Firmado }- deriving (Eq, Ord, Show)---- | The diagnostic information in an NaN.-newtype Diagnostic = Diagnostic { unDiagnostic :: Decuple }- deriving (Eq, Ord, Show)---- | Whether an NaN is quiet or signaling.-data Noisy = Quiet | Signaling- deriving (Eq, Ord, Show)---- | Not a Number.-data NonNum = NonNum- { noisy :: Noisy- , diagnostic :: Maybe Diagnostic- } deriving (Eq, Ord, Show)---- | All data in an abstract number except for the sign.-data Value- = Finite Coefficient Exponent- | Infinite- | NotANumber NonNum- deriving (Eq, Ord, Show)---- | Abstract representation of all numbers covered by the General--- Decimal Arithmetic Specification.-data Abstract = Abstract- { sign :: Sign- , value :: Value- } deriving (Eq, Ord, Show)--signToString :: Sign -> String-signToString s = case s of- Sign0 -> ""- Sign1 -> "-"---- | Adjusted exponent. Roughly speaking this represents the--- coefficient and exponent of an abstract decimal, adjusted so--- there is a decimal point between the most significant digit of--- the coefficient and the remaning digits.-newtype AdjustedExp = AdjustedExp { unAdjustedExp :: Integer }- deriving (Eq, Ord, Show)---- | Computes an adjusted exponent. The length of a zero--- coefficient is one.-adjustedExp :: Coefficient -> Exponent -> AdjustedExp-adjustedExp coe ex = AdjustedExp $ e + (c - 1)- where- e = firmadoToInt . unExponent $ ex- c = fromIntegral $ case unCoefficient coe of- Nil -> 1- Plenus (Decuple _ ds) -> length ds + 1--fmtAdjustedExp :: AdjustedExp -> String-fmtAdjustedExp (AdjustedExp i) = 'E' : sgn : digs- where- sgn | i < 0 = '-'- | otherwise = '+'- digs = show . Prelude.abs $ i--finiteToString :: Coefficient -> Exponent -> String-finiteToString c e = coe ++ ae- where- coe = case unCoefficient c of- Nil -> "0"- Plenus (Decuple n ds)- | null ds -> [novemToChar n]- | otherwise -> novemToChar n : '.' : map decemToChar ds- ae = fmtAdjustedExp $ adjustedExp c e--nanToString :: NonNum -> String-nanToString (NonNum n d) = pfx ++ "NaN" ++ dia- where- pfx = case n of { Quiet -> ""; Signaling -> "s" }- dia = maybe "" (decupleToString . unDiagnostic) d--fmtValue :: Value -> String-fmtValue v = case v of- Finite c e -> finiteToString c e- Infinite -> "Infinity"- NotANumber n -> nanToString n---- | Transform an 'Abstract' to a 'String'. This conforms to the--- @to-scientific-string@ transformation given in the General--- Decimal Arithmetic Specification at------ <http://speleotrove.com/decimal/daconvs.html#reftostr>------ with one exception: the specification provides that some finite--- numbers are represented without exponential notation.--- 'abstractToString' /always/ uses exponential notation on finite--- numbers.-abstractToString :: Abstract -> String-abstractToString (Abstract s v) = sgn ++ fmtValue v- where- sgn = case s of { Sign0 -> ""; Sign1 -> "-" }---- | Transforms an 'Abstract' to a 'Dec'. Result is computed in a--- context using the 'Pedantic' initializer. Result is returned--- along with any status flags arising from the computation.-abstractToDec :: Abstract -> (Dec, Flags)-abstractToDec = runCtxStatus . fromByteString- . BS8.pack . abstractToString-
− lib/Deka/Native/FromString.hs
@@ -1,227 +0,0 @@--- | Uses the specification for string conversions given in the--- General Decimal Arithmetic Specification to convert strings to an--- abstract syntax tree. The specification for string conversions--- is at------ <http://speleotrove.com/decimal/daconvs.html>------ The functions and types in this module fall into two groups. The--- first group converts a string to a 'NumericString', which is an--- abstract representation of the grammar given in the General--- Decimal Arithmetic Specification. These functions use Parsec to--- parse the string. The second group transforms the--- 'NumericString' to an 'A.Abstract', a form which more closely--- aligns with the abstract representation given at------ <http://speleotrove.com/decimal/damodel.html>.------ You can transform an 'A.Abstract' to a numeric string; no--- functions are provided to transform a 'NumericString' directly--- back to a string.-module Deka.Native.FromString where--import Data.Char (toLower)-import Control.Applicative-import Text.Parsec.String-import Text.Parsec.Prim (tokenPrim, try, parse)-import Text.Parsec.Pos-import Text.Parsec.Char (char, string)-import Text.Parsec.Combinator (many1, eof)-import qualified Deka.Native.Abstract as A-import Deka.Native.Abstract- (Decem(..), Novem(..), decemListToInt)-import Deka.Dec (Sign(..))-import qualified Deka.Dec as D-import qualified Data.ByteString.Char8 as BS8--sign :: Parser Sign-sign = tokenPrim show next f- where- next pos c _ = updatePosChar pos c- f c = case c of- '-' -> Just Sign1- '+' -> Just Sign0- _ -> Nothing--optSign :: Parser Sign-optSign = do- s <- optional sign- return $ maybe Sign0 id s--digit :: Parser Decem-digit = tokenPrim show next f- where- next pos c _ = updatePosChar pos c- f c = case c of- { '0' -> Just D0; '1' -> Just $ Nonem D1; '2' -> Just $ Nonem D2;- '3' -> Just $ Nonem D3; '4' -> Just $ Nonem D4;- '5' -> Just $ Nonem D5; '6' -> Just $ Nonem D6;- '7' -> Just $ Nonem D7; '8' -> Just $ Nonem D8;- '9' -> Just $ Nonem D9; _ -> Nothing }--indicator :: Parser ()-indicator = () <$ char 'e'--digits :: Parser [Decem]-digits = many1 digit--data DecimalPart- = WholeFrac [Decem] [Decem]- | WholeOnly [Decem]- deriving (Eq, Ord, Show)--decimalPart :: Parser DecimalPart-decimalPart = do- ds1 <- optional digits- case ds1 of- Nothing -> do- _ <- char '.'- fmap WholeOnly digits- Just ds -> do- dot <- optional (char '.')- case dot of- Just _ -> do- ds2 <- many digit- return $ WholeFrac ds ds2- Nothing -> return $ WholeOnly ds--data ExponentPart = ExponentPart- { expSign :: Sign- , expDigits :: [Decem]- } deriving (Eq, Ord, Show)--exponentPart :: Parser ExponentPart-exponentPart = do- indicator- sgn <- optSign- ds <- digits- return $ ExponentPart sgn ds--infinity :: Parser ()-infinity = try $ do- _ <- string "inf"- _ <- optional (string "inity")- return ()--nanId :: Parser A.Noisy-nanId = try (string "nan" >> return A.Quiet)- <|> try (string "snan" >> return A.Signaling)--data NaN = NaN A.Noisy [Decem]- deriving (Eq, Ord, Show)--nan :: Parser NaN-nan = liftA2 NaN nanId (many digit)--data NumericValue- = NVDec DecimalPart (Maybe ExponentPart)- | Infinity- deriving (Eq, Ord, Show)--numericValue :: Parser NumericValue-numericValue =- (Infinity <$ infinity)- <|> liftA2 NVDec decimalPart (optional exponentPart)--data NumericString = NumericString- { nsSign :: Sign- , nsValue :: Either NumericValue NaN- } deriving (Eq, Ord, Show)--numericString :: Parser NumericString-numericString = liftA2 NumericString optSign ei- where- ei = (fmap Left numericValue <|> fmap Right nan)--parseNumericString :: String -> Either String NumericString-parseNumericString s =- case parse (numericString <* eof) "" (map toLower s) of- Left e -> Left (show e)- Right g -> Right g--numericStringToAbstract :: NumericString -> A.Abstract-numericStringToAbstract (NumericString sgn ei) = A.Abstract sgn val- where- val = case ei of- Left nv -> case nv of- NVDec dp me -> uncurry A.Finite $ finiteToAbstract dp me- Infinity -> A.Infinite- Right nn -> A.NotANumber . nanToAbstract $ nn--nanToAbstract- :: NaN- -> A.NonNum-nanToAbstract (NaN nsy ds) = A.NonNum nsy . fmap A.Diagnostic- . A.decemListToDecuple $ ds--finiteToAbstract- :: DecimalPart- -> Maybe ExponentPart- -> (A.Coefficient, A.Exponent)-finiteToAbstract dp mep = (coe, ex)- where- ex = abstractExponent . actualExponent dp- . givenExponent $ mep- coe = abstractCoeff dp- ---- | A numeric value for the exponent that was given in the input--- string.--givenExponent :: Maybe ExponentPart -> Integer-givenExponent me = case me of- Nothing -> 0- Just (ExponentPart s ds) -> getSgn $ decemListToInt ds- where- getSgn = case s of- Sign0 -> id- Sign1 -> negate---- | The number of digits after the decimal point, subtracted from--- the numeric value for the exponent given in the string--actualExponent- :: DecimalPart- -> Integer- -- ^ Output from 'givenExponent'- -> Integer-actualExponent d i = case d of- WholeFrac _ ds -> i - fromIntegral (length ds)- _ -> i---- The value of the abstract exponent.--abstractExponent- :: Integer- -- ^ The output from 'actualExponent'- -> A.Exponent-abstractExponent = A.Exponent . A.intToFirmado--abstractCoeff :: DecimalPart -> A.Coefficient-abstractCoeff d =- let ds = case d of- WholeFrac d1 d2 -> d1 ++ d2- WholeOnly d1 -> d1- in A.Coefficient $ A.decemListToAut ds--stringToAbstract-- :: String- -- ^ Input string-- -> Either String A.Abstract- -- ^ Returns a Right with the abstract representation of the input- -- string, if the input conformed to the numeric string- -- specification given in the General Decimal Arithmetic- -- Specification. Otherwise, returns a Left with an error- -- message.--stringToAbstract = fmap numericStringToAbstract . parseNumericString---- | Transforms a 'Dec' to an 'Abstract'.-decToAbstract :: D.Dec -> A.Abstract-decToAbstract = either (error msg) id . stringToAbstract- . BS8.unpack . D.toByteString- where- msg = "decToAbstract: error: could not parse output from "- ++ "toByteString"
minimum-versions.txt view
@@ -1,7 +1,7 @@ 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-05-20 16:07:05.864819 UTC+Tested as of: 2014-07-16 11:45:23.903792 UTC Path to compiler: ghc-7.4.1 Compiler description: 7.4.1 @@ -33,27 +33,10 @@ time-1.4 unix-2.5.1.0 -/home/massysett/deka/sunlight-730/db:- QuickCheck-2.7.3- ansi-terminal-0.6.1.1- ansi-wl-pprint-0.6.7.1- async-2.0.1.5- deka-0.6.0.0- mmorph-1.0.3+/home/massysett/deka/library/sunlight-20573/db:+ deka-0.6.0.2 mtl-2.1.3.1- optparse-applicative-0.8.1 parsec-3.1.2- pipes-4.1.1- primitive-0.5.3.0- random-1.0.1.1- regex-base-0.93.2- regex-tdfa-1.2.0- stm-2.4.3- tagged-0.7.2- tasty-0.8.0.4- tasty-quickcheck-0.8.0.3 text-0.11.3.1- tf-random-0.5 transformers-0.3.0.0- unbounded-delays-0.1.0.7
− native/AllModules.hs
@@ -1,5 +0,0 @@-{-# OPTIONS_GHC -fno-warn-unused-imports #-}-module AllModules where--import Generators-import Properties
− native/Generators.hs
@@ -1,58 +0,0 @@--- | Generators of native data types.--module Generators where--import Control.Applicative-import Test.QuickCheck-import qualified Deka.Native as D-import qualified Deka.Dec as Dec-import Prelude hiding (exponent)--novem :: Gen D.Novem-novem = elements [minBound..maxBound]--decem :: Gen D.Decem-decem = frequency [(1, return D.D0), (9, fmap D.Nonem novem)]--decuple :: Gen D.Decuple-decuple = D.Decuple <$> novem <*> listOf decem--aut :: Gen D.Aut-aut = frequency [(1, return D.Nil), (4, fmap D.Plenus decuple)]--posNeg :: Gen Dec.PosNeg-posNeg = elements [Dec.Pos, Dec.Neg]--firmado :: Gen D.Firmado-firmado = frequency [(1, return D.Cero)- , (4, D.Completo <$> posNeg <*> decuple)]--coefficient :: Gen D.Coefficient-coefficient = fmap D.Coefficient aut--exponent :: Gen D.Exponent-exponent = fmap D.Exponent firmado--diagnostic :: Gen D.Diagnostic-diagnostic = fmap D.Diagnostic decuple--noisy :: Gen D.Noisy-noisy = elements [D.Quiet, D.Signaling]--nonNum :: Gen D.NonNum-nonNum = D.NonNum- <$> noisy- <*> frequency [(1, return Nothing), (3, fmap Just diagnostic)]--value :: Gen D.Value-value = frequency- [ (4, D.Finite <$> coefficient <*> exponent)- , (1, return D.Infinite)- , (1, fmap D.NotANumber nonNum)- ]--sign :: Gen Dec.Sign-sign = elements [ Dec.Sign1, Dec.Sign0 ]--abstract :: Gen D.Abstract-abstract = D.Abstract <$> sign <*> value
− native/Properties.hs
@@ -1,25 +0,0 @@-module Properties where--import qualified Generators as G-import qualified Deka.Native as N-import Test.Tasty.QuickCheck (testProperty)-import Test.Tasty (TestTree, testGroup)-import Test.QuickCheck-import qualified Deka.Dec as D--tests :: TestTree-tests = testGroup "Native"- [ testProperty "abstract -> string -> abstract" $- forAll G.abstract $ \a ->- case N.stringToAbstract . N.abstractToString $ a of- Left _ -> property False- Right a' -> a === a'-- , testProperty "Dec -> Abstract -> Dec" $- 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/native.hs
@@ -1,9 +0,0 @@-{-# OPTIONS_GHC -fno-warn-unused-imports #-}-module Main where--import AllModules-import Properties (tests)-import Test.Tasty (defaultMain)--main :: IO ()-main = defaultMain tests