diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -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 diff --git a/current-versions.txt b/current-versions.txt --- a/current-versions.txt +++ b/current-versions.txt @@ -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 diff --git a/dectest/AllModules.hs b/dectest/AllModules.hs deleted file mode 100644 --- a/dectest/AllModules.hs +++ /dev/null @@ -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 diff --git a/dectest/Arity.hs b/dectest/Arity.hs deleted file mode 100644 --- a/dectest/Arity.hs +++ /dev/null @@ -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" - diff --git a/dectest/Conditions.hs b/dectest/Conditions.hs deleted file mode 100644 --- a/dectest/Conditions.hs +++ /dev/null @@ -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) - ] - diff --git a/dectest/Directives.hs b/dectest/Directives.hs deleted file mode 100644 --- a/dectest/Directives.hs +++ /dev/null @@ -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) - ] - diff --git a/dectest/NumTests.hs b/dectest/NumTests.hs deleted file mode 100644 --- a/dectest/NumTests.hs +++ /dev/null @@ -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) - ] diff --git a/dectest/Operand.hs b/dectest/Operand.hs deleted file mode 100644 --- a/dectest/Operand.hs +++ /dev/null @@ -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 diff --git a/dectest/Parse.hs b/dectest/Parse.hs deleted file mode 100644 --- a/dectest/Parse.hs +++ /dev/null @@ -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 diff --git a/dectest/Parse/Tokenizer.hs b/dectest/Parse/Tokenizer.hs deleted file mode 100644 --- a/dectest/Parse/Tokenizer.hs +++ /dev/null @@ -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" diff --git a/dectest/Parse/Tokens.hs b/dectest/Parse/Tokens.hs deleted file mode 100644 --- a/dectest/Parse/Tokens.hs +++ /dev/null @@ -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 - diff --git a/dectest/Result.hs b/dectest/Result.hs deleted file mode 100644 --- a/dectest/Result.hs +++ /dev/null @@ -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 - diff --git a/dectest/Runner.hs b/dectest/Runner.hs deleted file mode 100644 --- a/dectest/Runner.hs +++ /dev/null @@ -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 - diff --git a/dectest/Specials.hs b/dectest/Specials.hs deleted file mode 100644 --- a/dectest/Specials.hs +++ /dev/null @@ -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) diff --git a/dectest/TestHelpers.hs b/dectest/TestHelpers.hs deleted file mode 100644 --- a/dectest/TestHelpers.hs +++ /dev/null @@ -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 diff --git a/dectest/TestLog.hs b/dectest/TestLog.hs deleted file mode 100644 --- a/dectest/TestLog.hs +++ /dev/null @@ -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 - diff --git a/dectest/Types.hs b/dectest/Types.hs deleted file mode 100644 --- a/dectest/Types.hs +++ /dev/null @@ -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. diff --git a/dectest/Util.hs b/dectest/Util.hs deleted file mode 100644 --- a/dectest/Util.hs +++ /dev/null @@ -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) diff --git a/dectest/dectest.hs b/dectest/dectest.hs deleted file mode 100644 --- a/dectest/dectest.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Main where - -import Runner -import System.Environment - -main :: IO () -main = getArgs >>= runAndExit diff --git a/deka.cabal b/deka.cabal --- a/deka.cabal +++ b/deka.cabal @@ -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 . - + . 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 . + . + 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 diff --git a/exposed/Deka.hs b/exposed/Deka.hs new file mode 100644 --- /dev/null +++ b/exposed/Deka.hs @@ -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: +-- +-- +-- +-- 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 diff --git a/exposed/Deka/Abstract.hs b/exposed/Deka/Abstract.hs new file mode 100644 --- /dev/null +++ b/exposed/Deka/Abstract.hs @@ -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 +-- +-- +-- +-- 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 + diff --git a/exposed/Deka/Context.hs b/exposed/Deka/Context.hs new file mode 100644 --- /dev/null +++ b/exposed/Deka/Context.hs @@ -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) diff --git a/exposed/Deka/Dec.hs b/exposed/Deka/Dec.hs new file mode 100644 --- /dev/null +++ b/exposed/Deka/Dec.hs @@ -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 +-- +-- +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 + diff --git a/exposed/Deka/Docs.hs b/exposed/Deka/Docs.hs new file mode 100644 --- /dev/null +++ b/exposed/Deka/Docs.hs @@ -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 +-- +-- +-- +-- 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: +-- +-- + +module Deka.Docs where diff --git a/exposed/Deka/Docs/Examples.lhs b/exposed/Deka/Docs/Examples.lhs new file mode 100644 --- /dev/null +++ b/exposed/Deka/Docs/Examples.lhs @@ -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: +> -- +> -- +> 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! + +> }; diff --git a/exposed/Deka/Native.hs b/exposed/Deka/Native.hs new file mode 100644 --- /dev/null +++ b/exposed/Deka/Native.hs @@ -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 +-- +-- +-- +-- 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) diff --git a/exposed/Deka/Native/Abstract.hs b/exposed/Deka/Native/Abstract.hs new file mode 100644 --- /dev/null +++ b/exposed/Deka/Native/Abstract.hs @@ -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 +-- +-- +-- +-- 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 + diff --git a/exposed/Deka/Native/FromString.hs b/exposed/Deka/Native/FromString.hs new file mode 100644 --- /dev/null +++ b/exposed/Deka/Native/FromString.hs @@ -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 +-- +-- +-- +-- 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 +-- +-- . +-- +-- 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" diff --git a/internal/Deka/Internal/Context.hs b/internal/Deka/Internal/Context.hs new file mode 100644 --- /dev/null +++ b/internal/Deka/Internal/Context.hs @@ -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 + diff --git a/internal/Deka/Internal/Dec/Ctx.hs b/internal/Deka/Internal/Dec/Ctx.hs new file mode 100644 --- /dev/null +++ b/internal/Deka/Internal/Dec/Ctx.hs @@ -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 + diff --git a/internal/Deka/Internal/Dec/CtxFree.hs b/internal/Deka/Internal/Dec/CtxFree.hs new file mode 100644 --- /dev/null +++ b/internal/Deka/Internal/Dec/CtxFree.hs @@ -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 + diff --git a/internal/Deka/Internal/Mpdec.hsc b/internal/Deka/Internal/Mpdec.hsc new file mode 100644 --- /dev/null +++ b/internal/Deka/Internal/Mpdec.hsc @@ -0,0 +1,838 @@ +{-# LANGUAGE EmptyDataDecls, Safe #-} +{-# LANGUAGE OverloadedStrings #-} +#include + +#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 + + diff --git a/internal/Deka/Internal/Unsafe.hs b/internal/Deka/Internal/Unsafe.hs new file mode 100644 --- /dev/null +++ b/internal/Deka/Internal/Unsafe.hs @@ -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) + diff --git a/internal/Deka/Internal/Util/Ctx.hs b/internal/Deka/Internal/Util/Ctx.hs new file mode 100644 --- /dev/null +++ b/internal/Deka/Internal/Util/Ctx.hs @@ -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 diff --git a/lib/Deka.hs b/lib/Deka.hs deleted file mode 100644 --- a/lib/Deka.hs +++ /dev/null @@ -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: --- --- --- --- 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 diff --git a/lib/Deka/Context.hs b/lib/Deka/Context.hs deleted file mode 100644 --- a/lib/Deka/Context.hs +++ /dev/null @@ -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) diff --git a/lib/Deka/Dec.hs b/lib/Deka/Dec.hs deleted file mode 100644 --- a/lib/Deka/Dec.hs +++ /dev/null @@ -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 --- --- -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 - diff --git a/lib/Deka/Docs.hs b/lib/Deka/Docs.hs deleted file mode 100644 --- a/lib/Deka/Docs.hs +++ /dev/null @@ -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 --- --- --- --- 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: --- --- - -module Deka.Docs where diff --git a/lib/Deka/Docs/Examples.lhs b/lib/Deka/Docs/Examples.lhs deleted file mode 100644 --- a/lib/Deka/Docs/Examples.lhs +++ /dev/null @@ -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: -> -- -> -- -> 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! - -> }; diff --git a/lib/Deka/Internal/Context.hs b/lib/Deka/Internal/Context.hs deleted file mode 100644 --- a/lib/Deka/Internal/Context.hs +++ /dev/null @@ -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 - diff --git a/lib/Deka/Internal/Dec/Ctx.hs b/lib/Deka/Internal/Dec/Ctx.hs deleted file mode 100644 --- a/lib/Deka/Internal/Dec/Ctx.hs +++ /dev/null @@ -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 - diff --git a/lib/Deka/Internal/Dec/CtxFree.hs b/lib/Deka/Internal/Dec/CtxFree.hs deleted file mode 100644 --- a/lib/Deka/Internal/Dec/CtxFree.hs +++ /dev/null @@ -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 - diff --git a/lib/Deka/Internal/Mpdec.hsc b/lib/Deka/Internal/Mpdec.hsc deleted file mode 100644 --- a/lib/Deka/Internal/Mpdec.hsc +++ /dev/null @@ -1,838 +0,0 @@ -{-# LANGUAGE EmptyDataDecls, Safe #-} -{-# LANGUAGE OverloadedStrings #-} -#include - -#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 - - diff --git a/lib/Deka/Internal/Unsafe.hs b/lib/Deka/Internal/Unsafe.hs deleted file mode 100644 --- a/lib/Deka/Internal/Unsafe.hs +++ /dev/null @@ -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) - diff --git a/lib/Deka/Internal/Util/Ctx.hs b/lib/Deka/Internal/Util/Ctx.hs deleted file mode 100644 --- a/lib/Deka/Internal/Util/Ctx.hs +++ /dev/null @@ -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 diff --git a/lib/Deka/Native.hs b/lib/Deka/Native.hs deleted file mode 100644 --- a/lib/Deka/Native.hs +++ /dev/null @@ -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 --- --- --- --- 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) diff --git a/lib/Deka/Native/Abstract.hs b/lib/Deka/Native/Abstract.hs deleted file mode 100644 --- a/lib/Deka/Native/Abstract.hs +++ /dev/null @@ -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 --- --- --- --- 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 - diff --git a/lib/Deka/Native/FromString.hs b/lib/Deka/Native/FromString.hs deleted file mode 100644 --- a/lib/Deka/Native/FromString.hs +++ /dev/null @@ -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 --- --- --- --- 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 --- --- . --- --- 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" diff --git a/minimum-versions.txt b/minimum-versions.txt --- a/minimum-versions.txt +++ b/minimum-versions.txt @@ -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 diff --git a/native/AllModules.hs b/native/AllModules.hs deleted file mode 100644 --- a/native/AllModules.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -module AllModules where - -import Generators -import Properties diff --git a/native/Generators.hs b/native/Generators.hs deleted file mode 100644 --- a/native/Generators.hs +++ /dev/null @@ -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 diff --git a/native/Properties.hs b/native/Properties.hs deleted file mode 100644 --- a/native/Properties.hs +++ /dev/null @@ -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 - ] diff --git a/native/native.hs b/native/native.hs deleted file mode 100644 --- a/native/native.hs +++ /dev/null @@ -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