1----------------------------------------------------------------------------- 2-- | 3-- Module : Data.SBV.Utils.PrettyNum 4-- Copyright : (c) Levent Erkok 5-- License : BSD3 6-- Maintainer: erkokl@gmail.com 7-- Stability : experimental 8-- 9-- Number representations in hex/bin 10----------------------------------------------------------------------------- 11 12{-# LANGUAGE FlexibleInstances #-} 13{-# LANGUAGE ScopedTypeVariables #-} 14 15{-# OPTIONS_GHC -Wall -Werror #-} 16 17module Data.SBV.Utils.PrettyNum ( 18 PrettyNum(..), readBin, shex, chex, shexI, sbin, sbinI 19 , showCFloat, showCDouble, showHFloat, showHDouble, showBFloat, showFloatAtBase 20 , showSMTFloat, showSMTDouble, smtRoundingMode, cvToSMTLib, mkSkolemZero 21 ) where 22 23import Data.Char (intToDigit, ord, chr, toUpper) 24import Data.Int (Int8, Int16, Int32, Int64) 25import Data.List (isPrefixOf) 26import Data.Maybe (fromJust, fromMaybe, listToMaybe) 27import Data.Ratio (numerator, denominator) 28import Data.Word (Word8, Word16, Word32, Word64) 29 30import qualified Data.Set as Set 31 32import Numeric (showIntAtBase, showHex, readInt, floatToDigits) 33import qualified Numeric as N (showHFloat) 34 35import Data.SBV.Core.Data 36import Data.SBV.Core.Kind (smtType, smtRoundingMode, showBaseKind) 37 38import Data.SBV.Core.AlgReals (algRealToSMTLib2) 39import Data.SBV.Core.SizedFloats (fprToSMTLib2, bfToString) 40 41import Data.SBV.Utils.Lib (stringToQFS) 42 43-- | PrettyNum class captures printing of numbers in hex and binary formats; also supporting negative numbers. 44class PrettyNum a where 45 -- | Show a number in hexadecimal, starting with @0x@ and type. 46 hexS :: a -> String 47 -- | Show a number in binary, starting with @0b@ and type. 48 binS :: a -> String 49 -- | Show a number in hexadecimal, starting with @0x@ but no type. 50 hexP :: a -> String 51 -- | Show a number in binary, starting with @0b@ but no type. 52 binP :: a -> String 53 -- | Show a number in hex, without prefix, or types. 54 hex :: a -> String 55 -- | Show a number in bin, without prefix, or types. 56 bin :: a -> String 57 58-- Why not default methods? Because defaults need "Integral a" but Bool is not.. 59instance PrettyNum Bool where 60 hexS = show 61 binS = show 62 hexP = show 63 binP = show 64 hex = show 65 bin = show 66 67instance PrettyNum String where 68 hexS = show 69 binS = show 70 hexP = show 71 binP = show 72 hex = show 73 bin = show 74 75instance PrettyNum Word8 where 76 hexS = shex True True (False, 8) 77 binS = sbin True True (False, 8) 78 79 hexP = shex False True (False, 8) 80 binP = sbin False True (False, 8) 81 82 hex = shex False False (False, 8) 83 bin = sbin False False (False, 8) 84 85instance PrettyNum Int8 where 86 hexS = shex True True (True, 8) 87 binS = sbin True True (True, 8) 88 89 hexP = shex False True (True, 8) 90 binP = sbin False True (True, 8) 91 92 hex = shex False False (True, 8) 93 bin = sbin False False (True, 8) 94 95instance PrettyNum Word16 where 96 hexS = shex True True (False, 16) 97 binS = sbin True True (False, 16) 98 99 hexP = shex False True (False, 16) 100 binP = sbin False True (False, 16) 101 102 hex = shex False False (False, 16) 103 bin = sbin False False (False, 16) 104 105instance PrettyNum Int16 where 106 hexS = shex True True (True, 16) 107 binS = sbin True True (True, 16) 108 109 hexP = shex False True (True, 16) 110 binP = sbin False True (True, 16) 111 112 hex = shex False False (True, 16) 113 bin = sbin False False (True, 16) 114 115instance PrettyNum Word32 where 116 hexS = shex True True (False, 32) 117 binS = sbin True True (False, 32) 118 119 hexP = shex False True (False, 32) 120 binP = sbin False True (False, 32) 121 122 hex = shex False False (False, 32) 123 bin = sbin False False (False, 32) 124 125instance PrettyNum Int32 where 126 hexS = shex True True (True, 32) 127 binS = sbin True True (True, 32) 128 129 hexP = shex False True (True, 32) 130 binP = sbin False True (True, 32) 131 132 hex = shex False False (True, 32) 133 bin = sbin False False (True, 32) 134 135instance PrettyNum Word64 where 136 hexS = shex True True (False, 64) 137 binS = sbin True True (False, 64) 138 139 hexP = shex False True (False, 64) 140 binP = sbin False True (False, 64) 141 142 hex = shex False False (False, 64) 143 bin = sbin False False (False, 64) 144 145instance PrettyNum Int64 where 146 hexS = shex True True (True, 64) 147 binS = sbin True True (True, 64) 148 149 hexP = shex False True (True, 64) 150 binP = sbin False True (True, 64) 151 152 hex = shex False False (True, 64) 153 bin = sbin False False (True, 64) 154 155instance PrettyNum Integer where 156 hexS = shexI True True 157 binS = sbinI True True 158 159 hexP = shexI False True 160 binP = sbinI False True 161 162 hex = shexI False False 163 bin = sbinI False False 164 165shBKind :: HasKind a => a -> String 166shBKind a = " :: " ++ showBaseKind (kindOf a) 167 168instance PrettyNum CV where 169 hexS cv | isUserSort cv = shows cv $ shBKind cv 170 | isBoolean cv = hexS (cvToBool cv) ++ shBKind cv 171 | isFloat cv = let CFloat f = cvVal cv in N.showHFloat f $ shBKind cv 172 | isDouble cv = let CDouble d = cvVal cv in N.showHFloat d $ shBKind cv 173 | isFP cv = let CFP f = cvVal cv in bfToString 16 True f ++ shBKind cv 174 | isReal cv = let CAlgReal r = cvVal cv in show r ++ shBKind cv 175 | isString cv = let CString s = cvVal cv in show s ++ shBKind cv 176 | not (isBounded cv) = let CInteger i = cvVal cv in shexI True True i 177 | True = let CInteger i = cvVal cv in shex True True (hasSign cv, intSizeOf cv) i 178 179 binS cv | isUserSort cv = shows cv $ shBKind cv 180 | isBoolean cv = binS (cvToBool cv) ++ shBKind cv 181 | isFloat cv = let CFloat f = cvVal cv in showBFloat f $ shBKind cv 182 | isDouble cv = let CDouble d = cvVal cv in showBFloat d $ shBKind cv 183 | isFP cv = let CFP f = cvVal cv in bfToString 2 True f ++ shBKind cv 184 | isReal cv = let CAlgReal r = cvVal cv in shows r $ shBKind cv 185 | isString cv = let CString s = cvVal cv in shows s $ shBKind cv 186 | not (isBounded cv) = let CInteger i = cvVal cv in sbinI True True i 187 | True = let CInteger i = cvVal cv in sbin True True (hasSign cv, intSizeOf cv) i 188 189 hexP cv | isUserSort cv = show cv 190 | isBoolean cv = hexS (cvToBool cv) 191 | isFloat cv = let CFloat f = cvVal cv in show f 192 | isDouble cv = let CDouble d = cvVal cv in show d 193 | isFP cv = let CFP f = cvVal cv in bfToString 16 True f 194 | isReal cv = let CAlgReal r = cvVal cv in show r 195 | isString cv = let CString s = cvVal cv in show s 196 | not (isBounded cv) = let CInteger i = cvVal cv in shexI False True i 197 | True = let CInteger i = cvVal cv in shex False True (hasSign cv, intSizeOf cv) i 198 199 binP cv | isUserSort cv = show cv 200 | isBoolean cv = binS (cvToBool cv) 201 | isFloat cv = let CFloat f = cvVal cv in show f 202 | isDouble cv = let CDouble d = cvVal cv in show d 203 | isFP cv = let CFP f = cvVal cv in bfToString 2 True f 204 | isReal cv = let CAlgReal r = cvVal cv in show r 205 | isString cv = let CString s = cvVal cv in show s 206 | not (isBounded cv) = let CInteger i = cvVal cv in sbinI False True i 207 | True = let CInteger i = cvVal cv in sbin False True (hasSign cv, intSizeOf cv) i 208 209 hex cv | isUserSort cv = show cv 210 | isBoolean cv = hexS (cvToBool cv) 211 | isFloat cv = let CFloat f = cvVal cv in show f 212 | isDouble cv = let CDouble d = cvVal cv in show d 213 | isFP cv = let CFP f = cvVal cv in bfToString 16 False f 214 | isReal cv = let CAlgReal r = cvVal cv in show r 215 | isString cv = let CString s = cvVal cv in show s 216 | not (isBounded cv) = let CInteger i = cvVal cv in shexI False False i 217 | True = let CInteger i = cvVal cv in shex False False (hasSign cv, intSizeOf cv) i 218 219 bin cv | isUserSort cv = show cv 220 | isBoolean cv = binS (cvToBool cv) 221 | isFloat cv = let CFloat f = cvVal cv in show f 222 | isDouble cv = let CDouble d = cvVal cv in show d 223 | isFP cv = let CFP f = cvVal cv in bfToString 2 False f 224 | isReal cv = let CAlgReal r = cvVal cv in show r 225 | isString cv = let CString s = cvVal cv in show s 226 | not (isBounded cv) = let CInteger i = cvVal cv in sbinI False False i 227 | True = let CInteger i = cvVal cv in sbin False False (hasSign cv, intSizeOf cv) i 228 229instance (SymVal a, PrettyNum a) => PrettyNum (SBV a) where 230 hexS s = maybe (show s) (hexS :: a -> String) $ unliteral s 231 binS s = maybe (show s) (binS :: a -> String) $ unliteral s 232 233 hexP s = maybe (show s) (hexP :: a -> String) $ unliteral s 234 binP s = maybe (show s) (binP :: a -> String) $ unliteral s 235 236 hex s = maybe (show s) (hex :: a -> String) $ unliteral s 237 bin s = maybe (show s) (bin :: a -> String) $ unliteral s 238 239-- | Show as a hexadecimal value. First bool controls whether type info is printed 240-- while the second boolean controls wether 0x prefix is printed. The tuple is 241-- the signedness and the bit-length of the input. The length of the string 242-- will /not/ depend on the value, but rather the bit-length. 243shex :: (Show a, Integral a) => Bool -> Bool -> (Bool, Int) -> a -> String 244shex shType shPre (signed, size) a 245 | a < 0 246 = "-" ++ pre ++ pad l (s16 (abs (fromIntegral a :: Integer))) ++ t 247 | True 248 = pre ++ pad l (s16 a) ++ t 249 where t | shType = " :: " ++ (if signed then "Int" else "Word") ++ show size 250 | True = "" 251 pre | shPre = "0x" 252 | True = "" 253 l = (size + 3) `div` 4 254 255-- | Show as hexadecimal, but for C programs. We have to be careful about 256-- printing min-bounds, since C does some funky casting, possibly losing 257-- the sign bit. In those cases, we use the defined constants in <stdint.h>. 258-- We also properly append the necessary suffixes as needed. 259chex :: (Show a, Integral a) => Bool -> Bool -> (Bool, Int) -> a -> String 260chex shType shPre (signed, size) a 261 | Just s <- (signed, size, fromIntegral a) `lookup` specials 262 = s 263 | True 264 = shex shType shPre (signed, size) a ++ suffix 265 where specials :: [((Bool, Int, Integer), String)] 266 specials = [ ((True, 8, fromIntegral (minBound :: Int8)), "INT8_MIN" ) 267 , ((True, 16, fromIntegral (minBound :: Int16)), "INT16_MIN") 268 , ((True, 32, fromIntegral (minBound :: Int32)), "INT32_MIN") 269 , ((True, 64, fromIntegral (minBound :: Int64)), "INT64_MIN") 270 ] 271 suffix = case (signed, size) of 272 (False, 16) -> "U" 273 274 (False, 32) -> "UL" 275 (True, 32) -> "L" 276 277 (False, 64) -> "ULL" 278 (True, 64) -> "LL" 279 280 _ -> "" 281 282-- | Show as a hexadecimal value, integer version. Almost the same as shex above 283-- except we don't have a bit-length so the length of the string will depend 284-- on the actual value. 285shexI :: Bool -> Bool -> Integer -> String 286shexI shType shPre a 287 | a < 0 288 = "-" ++ pre ++ s16 (abs a) ++ t 289 | True 290 = pre ++ s16 a ++ t 291 where t | shType = " :: Integer" 292 | True = "" 293 pre | shPre = "0x" 294 | True = "" 295 296-- | Similar to 'shex'; except in binary. 297sbin :: (Show a, Integral a) => Bool -> Bool -> (Bool, Int) -> a -> String 298sbin shType shPre (signed,size) a 299 | a < 0 300 = "-" ++ pre ++ pad size (s2 (abs (fromIntegral a :: Integer))) ++ t 301 | True 302 = pre ++ pad size (s2 a) ++ t 303 where t | shType = " :: " ++ (if signed then "Int" else "Word") ++ show size 304 | True = "" 305 pre | shPre = "0b" 306 | True = "" 307 308-- | Similar to 'shexI'; except in binary. 309sbinI :: Bool -> Bool -> Integer -> String 310sbinI shType shPre a 311 | a < 0 312 = "-" ++ pre ++ s2 (abs a) ++ t 313 | True 314 = pre ++ s2 a ++ t 315 where t | shType = " :: Integer" 316 | True = "" 317 pre | shPre = "0b" 318 | True = "" 319 320-- | Pad a string to a given length. If the string is longer, then we don't drop anything. 321pad :: Int -> String -> String 322pad l s = replicate (l - length s) '0' ++ s 323 324-- | Binary printer 325s2 :: (Show a, Integral a) => a -> String 326s2 v = showIntAtBase 2 dig v "" where dig = fromJust . flip lookup [(0, '0'), (1, '1')] 327 328-- | Hex printer 329s16 :: (Show a, Integral a) => a -> String 330s16 v = showHex v "" 331 332-- | A more convenient interface for reading binary numbers, also supports negative numbers 333readBin :: Num a => String -> a 334readBin ('-':s) = -(readBin s) 335readBin s = case readInt 2 isDigit cvt s' of 336 [(a, "")] -> a 337 _ -> error $ "SBV.readBin: Cannot read a binary number from: " ++ show s 338 where cvt c = ord c - ord '0' 339 isDigit = (`elem` "01") 340 s' | "0b" `isPrefixOf` s = drop 2 s 341 | True = s 342 343-- | A version of show for floats that generates correct C literals for nan/infinite. NB. Requires "math.h" to be included. 344showCFloat :: Float -> String 345showCFloat f 346 | isNaN f = "((float) NAN)" 347 | isInfinite f, f < 0 = "((float) (-INFINITY))" 348 | isInfinite f = "((float) INFINITY)" 349 | True = N.showHFloat f $ "F /* " ++ show f ++ "F */" 350 351-- | A version of show for doubles that generates correct C literals for nan/infinite. NB. Requires "math.h" to be included. 352showCDouble :: Double -> String 353showCDouble d 354 | isNaN d = "((double) NAN)" 355 | isInfinite d, d < 0 = "((double) (-INFINITY))" 356 | isInfinite d = "((double) INFINITY)" 357 | True = N.showHFloat d " /* " ++ show d ++ " */" 358 359-- | A version of show for floats that generates correct Haskell literals for nan/infinite 360showHFloat :: Float -> String 361showHFloat f 362 | isNaN f = "((0/0) :: Float)" 363 | isInfinite f, f < 0 = "((-1/0) :: Float)" 364 | isInfinite f = "((1/0) :: Float)" 365 | True = show f 366 367-- | A version of show for doubles that generates correct Haskell literals for nan/infinite 368showHDouble :: Double -> String 369showHDouble d 370 | isNaN d = "((0/0) :: Double)" 371 | isInfinite d, d < 0 = "((-1/0) :: Double)" 372 | isInfinite d = "((1/0) :: Double)" 373 | True = show d 374 375-- | A version of show for floats that generates correct SMTLib literals using the rounding mode 376showSMTFloat :: RoundingMode -> Float -> String 377showSMTFloat rm f 378 | isNaN f = as "NaN" 379 | isInfinite f, f < 0 = as "-oo" 380 | isInfinite f = as "+oo" 381 | isNegativeZero f = as "-zero" 382 | f == 0 = as "+zero" 383 | True = "((_ to_fp 8 24) " ++ smtRoundingMode rm ++ " " ++ toSMTLibRational (toRational f) ++ ")" 384 where as s = "(_ " ++ s ++ " 8 24)" 385 386 387-- | A version of show for doubles that generates correct SMTLib literals using the rounding mode 388showSMTDouble :: RoundingMode -> Double -> String 389showSMTDouble rm d 390 | isNaN d = as "NaN" 391 | isInfinite d, d < 0 = as "-oo" 392 | isInfinite d = as "+oo" 393 | isNegativeZero d = as "-zero" 394 | d == 0 = as "+zero" 395 | True = "((_ to_fp 11 53) " ++ smtRoundingMode rm ++ " " ++ toSMTLibRational (toRational d) ++ ")" 396 where as s = "(_ " ++ s ++ " 11 53)" 397 398-- | Show a rational in SMTLib format 399toSMTLibRational :: Rational -> String 400toSMTLibRational r 401 | n < 0 402 = "(- (/ " ++ show (abs n) ++ ".0 " ++ show d ++ ".0))" 403 | True 404 = "(/ " ++ show n ++ ".0 " ++ show d ++ ".0)" 405 where n = numerator r 406 d = denominator r 407 408-- | Convert a CV to an SMTLib2 compliant value 409cvToSMTLib :: RoundingMode -> CV -> String 410cvToSMTLib rm x 411 | isBoolean x, CInteger w <- cvVal x = if w == 0 then "false" else "true" 412 | isUserSort x, CUserSort (_, s) <- cvVal x = roundModeConvert s 413 | isReal x, CAlgReal r <- cvVal x = algRealToSMTLib2 r 414 | isFloat x, CFloat f <- cvVal x = showSMTFloat rm f 415 | isDouble x, CDouble d <- cvVal x = showSMTDouble rm d 416 | isFP x, CFP f <- cvVal x = fprToSMTLib2 f 417 | not (isBounded x), CInteger w <- cvVal x = if w >= 0 then show w else "(- " ++ show (abs w) ++ ")" 418 | not (hasSign x) , CInteger w <- cvVal x = smtLibHex (intSizeOf x) w 419 -- signed numbers (with 2's complement representation) is problematic 420 -- since there's no way to put a bvneg over a positive number to get minBound.. 421 -- Hence, we punt and use binary notation in that particular case 422 | hasSign x , CInteger w <- cvVal x = if w == negate (2 ^ intSizeOf x) 423 then mkMinBound (intSizeOf x) 424 else negIf (w < 0) $ smtLibHex (intSizeOf x) (abs w) 425 | isChar x , CChar c <- cvVal x = "(_ char " ++ smtLibHex 8 (fromIntegral (ord c)) ++ ")" 426 | isString x , CString s <- cvVal x = '\"' : stringToQFS s ++ "\"" 427 | isList x , CList xs <- cvVal x = smtLibSeq (kindOf x) xs 428 | isSet x , CSet s <- cvVal x = smtLibSet (kindOf x) s 429 | isTuple x , CTuple xs <- cvVal x = smtLibTup (kindOf x) xs 430 | isMaybe x , CMaybe mc <- cvVal x = smtLibMaybe (kindOf x) mc 431 | isEither x , CEither ec <- cvVal x = smtLibEither (kindOf x) ec 432 433 | True = error $ "SBV.cvtCV: Impossible happened: Kind/Value disagreement on: " ++ show (kindOf x, x) 434 where roundModeConvert s = fromMaybe s (listToMaybe [smtRoundingMode m | m <- [minBound .. maxBound] :: [RoundingMode], show m == s]) 435 -- Carefully code hex numbers, SMTLib is picky about lengths of hex constants. For the time 436 -- being, SBV only supports sizes that are multiples of 4, but the below code is more robust 437 -- in case of future extensions to support arbitrary sizes. 438 smtLibHex :: Int -> Integer -> String 439 smtLibHex 1 v = "#b" ++ show v 440 smtLibHex sz v 441 | sz `mod` 4 == 0 = "#x" ++ pad (sz `div` 4) (showHex v "") 442 | True = "#b" ++ pad sz (showBin v "") 443 where showBin = showIntAtBase 2 intToDigit 444 negIf :: Bool -> String -> String 445 negIf True a = "(bvneg " ++ a ++ ")" 446 negIf False a = a 447 448 smtLibSeq :: Kind -> [CVal] -> String 449 smtLibSeq k [] = "(as seq.empty " ++ smtType k ++ ")" 450 smtLibSeq (KList ek) xs = let mkSeq [e] = e 451 mkSeq es = "(seq.++ " ++ unwords es ++ ")" 452 mkUnit inner = "(seq.unit " ++ inner ++ ")" 453 in mkSeq (mkUnit . cvToSMTLib rm . CV ek <$> xs) 454 smtLibSeq k _ = error "SBV.cvToSMTLib: Impossible case (smtLibSeq), received kind: " ++ show k 455 456 smtLibSet :: Kind -> RCSet CVal -> String 457 smtLibSet k set = case set of 458 RegularSet rs -> Set.foldr' (modify "true") (start "false") rs 459 ComplementSet rs -> Set.foldr' (modify "false") (start "true") rs 460 where ke = case k of 461 KSet ek -> ek 462 _ -> error $ "SBV.cvToSMTLib: Impossible case (smtLibSet), received kind: " ++ show k 463 464 start def = "((as const " ++ smtType k ++ ") " ++ def ++ ")" 465 466 modify how e s = "(store " ++ s ++ " " ++ cvToSMTLib rm (CV ke e) ++ " " ++ how ++ ")" 467 468 smtLibTup :: Kind -> [CVal] -> String 469 smtLibTup (KTuple []) _ = "mkSBVTuple0" 470 smtLibTup (KTuple ks) xs = "(mkSBVTuple" ++ show (length ks) ++ " " ++ unwords (zipWith (\ek e -> cvToSMTLib rm (CV ek e)) ks xs) ++ ")" 471 smtLibTup k _ = error $ "SBV.cvToSMTLib: Impossible case (smtLibTup), received kind: " ++ show k 472 473 dtConstructor fld [] res = "(as " ++ fld ++ " " ++ smtType res ++ ")" 474 dtConstructor fld args res = "((as " ++ fld ++ " " ++ smtType res ++ ") " ++ unwords args ++ ")" 475 476 smtLibMaybe :: Kind -> Maybe CVal -> String 477 smtLibMaybe km@KMaybe{} Nothing = dtConstructor "nothing_SBVMaybe" [] km 478 smtLibMaybe km@(KMaybe k) (Just c) = dtConstructor "just_SBVMaybe" [cvToSMTLib rm (CV k c)] km 479 smtLibMaybe k _ = error $ "SBV.cvToSMTLib: Impossible case (smtLibMaybe), received kind: " ++ show k 480 481 smtLibEither :: Kind -> Either CVal CVal -> String 482 smtLibEither ke@(KEither k _) (Left c) = dtConstructor "left_SBVEither" [cvToSMTLib rm (CV k c)] ke 483 smtLibEither ke@(KEither _ k) (Right c) = dtConstructor "right_SBVEither" [cvToSMTLib rm (CV k c)] ke 484 smtLibEither k _ = error $ "SBV.cvToSMTLib: Impossible case (smtLibEither), received kind: " ++ show k 485 486 -- anomaly at the 2's complement min value! Have to use binary notation here 487 -- as there is no positive value we can provide to make the bvneg work.. (see above) 488 mkMinBound :: Int -> String 489 mkMinBound i = "#b1" ++ replicate (i-1) '0' 490 491-- | Create a skolem 0 for the kind 492mkSkolemZero :: RoundingMode -> Kind -> String 493mkSkolemZero _ (KUserSort _ (Just (f:_))) = f 494mkSkolemZero _ (KUserSort s _) = error $ "SBV.mkSkolemZero: Unexpected user sort: " ++ s 495mkSkolemZero rm k = cvToSMTLib rm (mkConstCV k (0::Integer)) 496 497-- | Show a float as a binary 498showBFloat :: (Show a, RealFloat a) => a -> ShowS 499showBFloat = showFloatAtBase 2 500 501-- | Like Haskell's showHFloat, but uses arbitrary base instead. Note that the exponent is always written in decimal. 502showFloatAtBase :: (Show a, RealFloat a) => Int -> a -> ShowS 503showFloatAtBase base = showString . fmt 504 where fmt x 505 | isNaN x = "NaN" 506 | isInfinite x = (if x < 0 then "-" else "") ++ "Infinity" 507 | x < 0 || isNegativeZero x = '-' : cvt (-x) 508 | True = cvt x 509 510 prefix = case base of 511 2 -> "0b" 512 8 -> "0o" 513 10 -> "" 514 16 -> "0x" 515 x -> "0<" ++ show x ++ ">" 516 517 cvt x 518 | x == 0 = prefix ++ "0p+0" 519 | True = case floatToDigits (fromIntegral base) x of 520 r@([], _) -> error $ "Impossible happened: showFloatAtBase: " ++ show (base, show x, r) 521 (d:ds, e) -> prefix ++ toDigit d ++ frac ds ++ "p" ++ show (e-1) 522 523 -- Given digits, show them except if they're all 0 then drop 524 frac digits 525 | all (== 0) digits = "" 526 | True = "." ++ concatMap toDigit digits 527 528 toDigit v = map toUpper d 529 where d | v <= 15 = [intToDigit v] 530 | v < 36 = [chr (ord 'a' + v - 10)] 531 | True = '<' : show v ++ ">" 532