|
sourcecode:
|
{-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-}
module Data.Format
( showChar, showInt, showFloat, showString )
where
import Data.Char
import Data.List
import Numeric
-- Basic type for show functions
type ShowSpec a = Typ -> Maybe Flag -> Maybe Width -> Maybe Precision
-> a -> String
type Typ = Char
type Flag = String
type Width = Int
type Precision = Int
--- The function showChar formats a character
--- @param type - will be ignored
--- @param flags - a string, everything but the minus char will be ignored
--- @param width - the minimal number of characters to be printed
--- @param precision - will be ignored
--- @param char - The char which should be formatted
--- @return A string containing the formatted character
showChar :: ShowSpec Char
showChar _ mf mw _ c =
let flags = convertFlags mf
width = convertWidth mw
minusFlag = getMinusFlag flags
cToString = [c]
in if minusFlag then fillWithCharsLeftAlign width ' ' cToString
else fillWithCharsRightAlign width ' ' cToString
--- The function showInt formats an Int
--- @param t - A char setting the way of number representation
--- @param mf - A string containing all flags
--- @param mw - The minimal number of characters to be printed
--- @param mp - The minimal number of numbers to be printed
--- @param i - The Int which should be formatted
--- @return A string containing the formatted Int
showInt :: ShowSpec Int
showInt t mf mw mp i =
-- convert to better format
let flags = convertFlags mf
width = convertWidth mw
prec = convertPrecision mp
precPresent = maybe False (\_ -> True) mp
minusFlag = getMinusFlag flags
plusFlag = getPlusFlag flags
zeroFlag = getZeroFlag flags
spaceFlag = getSpaceFlag flags
hashFlag = getHashFlag flags
-- convert to the right numeric system
iToString = case t of
'i' -> consistentShowInt i
'd' -> consistentShowInt i
'o' -> showIntAsOct i
'x' -> showIntAsHex i
'X' -> map toUpper (showIntAsHex i)
isPositive = head iToString /= '-'
isSigned = (||) (t == 'i') (t == 'd')
iToStringPosi = if isPositive then iToString else (tail iToString)
-- apply precision
applyPrecision = fillWithCharsRightAlign prec '0' iToStringPosi
afterPrecision = if isPositive then applyPrecision
else '-':applyPrecision
-- apply flags
afterPlusFlag = if (plusFlag && isSigned && isPositive)
then '+':afterPrecision
else afterPrecision
afterHashFlag = if (not (isSigned) && hashFlag && i /= 0)
then case t of
'o' -> '0' :afterPlusFlag
'x' -> '0':'x':afterPlusFlag
'X' -> '0':'X':afterPlusFlag
else afterPlusFlag
afterSpaceFlag = if (spaceFlag && isSigned && isPositive && not plusFlag)
then ' ':afterHashFlag
else afterHashFlag
-- apply width
afterWidth = if minusFlag
then fillWithCharsLeftAlign width ' ' afterSpaceFlag
else let filler = if (zeroFlag && not (precPresent))
then '0' else ' '
in fillWithCharsRightAlign width filler
afterSpaceFlag
-- result
in afterWidth
--- The function showFloat formats a Float
--- @param t - A char setting wether to use an exponent or not
--- @param mf - A string containing all flags
--- @param mw - The minimal number of characters to be printed before the point
--- @param mp - The exact amount of numbers to be printed after the point
--- @param x - The Float which should be formatted
--- @return A string containing the formatted float
showFloat :: ShowSpec Float
showFloat t mf mw mp x =
-- convert to better format
let flags = convertFlags mf
width = convertWidth mw
prec = convertPrecision mp
minusFlag = getMinusFlag flags
plusFlag = getPlusFlag flags
zeroFlag = getZeroFlag flags
spaceFlag = getSpaceFlag flags
hashFlag = getHashFlag flags
isPositive = (>=) x 0
-- Convert to Floater format for easier formatting
floa = floatToFloater x
-- apply type
afterType = case t of
'f' -> eliminateExponent floa
'e' -> onePrePoint floa
'E' -> onePrePoint floa
-- apply precision
afterPrec = roundFloater prec afterType
-- apply flags
afterPlusFlag = if (plusFlag && x >= 0)
then setMantissaBeforePoint afterPrec
('+':getMantissaBeforePoint afterPrec)
else afterPrec
afterHashFlag = if (not (isPrefixOf (getMantissaAfterPoint afterPlusFlag)
(repeat '0')) || hashFlag || prec > 0)
then setMantissaAfterPoint afterPlusFlag
('.':getMantissaAfterPoint afterPlusFlag)
else afterPlusFlag
afterSpaceFlag = if (spaceFlag && not plusFlag && isPositive)
then setMantissaBeforePoint afterHashFlag
(' ':getMantissaBeforePoint afterHashFlag)
else if (not isPositive)
then setMantissaBeforePoint afterHashFlag
('-':getMantissaBeforePoint afterHashFlag)
else afterHashFlag
-- convert back from floater data type
unitedFloater = case t of
'f' -> getMantissaBeforePoint afterSpaceFlag
++ getMantissaAfterPoint afterSpaceFlag
'e' -> getMantissaBeforePoint afterSpaceFlag
++ getMantissaAfterPoint afterSpaceFlag
++ "e" ++ showExponent afterSpaceFlag
'E' -> getMantissaBeforePoint afterSpaceFlag
++ getMantissaAfterPoint afterSpaceFlag
++ "E" ++ showExponent afterSpaceFlag
-- apply width
afterWidth = if minusFlag
then fillWithCharsLeftAlign width ' ' unitedFloater
else let filler = if zeroFlag
then '0' else ' '
in fillWithCharsRightAlign width filler
unitedFloater
-- result
in afterWidth
--- The function showString formats a String
--- @param t - Ignored
--- @param mf - A string containing all flags
--- @param mw - The minimal number of characters to be printed
--- @param mp - The exact number of characters of the string to be printed
--- @param s - The String which should be formatted
--- @return A string containing the formatted String
showString :: ShowSpec String
showString _ mf mw mp s =
let flags = convertFlags mf
width = convertWidth mw
minusFlag = getMinusFlag flags
afterPrec = maybe s (flip take s) mp
afterWidth = if minusFlag
then fillWithCharsLeftAlign width ' ' afterPrec
else fillWithCharsRightAlign width ' ' afterPrec
in afterWidth
--- FLOATER DATA TYPE BEGIN ----------------------
-- Our own datatype for floats, to make manipulating their string representation
-- easier
data Floater = Floater Sign
MantissaBeforePoint
MantissaAfterPoint
Exponent
data Sign = Positive | Negative
type MantissaBeforePoint = String
type MantissaAfterPoint = String
type Mantissa = String
type MantissaSigned = String
type Exponent = Int
floater :: Sign -> MantissaBeforePoint -> MantissaAfterPoint -> Exponent
-> Floater
floater = Floater
floaterCreator :: MantissaSigned -> Exponent -> Floater
floaterCreator ms e = setExponent (setMantissaSigned zeroFloater ms) e
zeroFloater :: Floater
zeroFloater = Floater Positive "0" "" 0
floatToFloater :: Float -> Floater
floatToFloater f = let (mantissa,exp) = break ((==) 'e') (consistentShowFloat f)
in if exp == ""
then floaterCreator mantissa 0
else floaterCreator mantissa
(case readInt (tail exp) of
[(n,_)] -> n
_ -> failed)
getSign :: Floater -> Sign
getSign (Floater s _ _ _) = s
setSign :: Floater -> Sign -> Floater
setSign (Floater _ m1 m2 e) s = Floater s m1 m2 e
getMantissaBeforePoint :: Floater -> MantissaBeforePoint
getMantissaBeforePoint (Floater _ m1 _ _) = m1
setMantissaBeforePoint :: Floater -> MantissaBeforePoint -> Floater
setMantissaBeforePoint (Floater s _ m2 e) m1 = Floater s m1 m2 e
getMantissaAfterPoint :: Floater -> MantissaAfterPoint
getMantissaAfterPoint (Floater _ _ m2 _) = m2
setMantissaAfterPoint :: Floater -> MantissaAfterPoint -> Floater
setMantissaAfterPoint (Floater s m1 _ e) m2 = Floater s m1 m2 e
getMantissa :: Floater -> Mantissa
getMantissa (Floater _ m1 m2 _) = m1 ++ ('.':m2)
setMantissa :: Floater -> Mantissa -> Floater
setMantissa (Floater s _ _ e) m = let (bP,aP) = break ((==) '.') m
in Floater s bP (tail aP) e
setMantissaSigned :: Floater -> MantissaSigned -> Floater
setMantissaSigned (Floater _ _ _ e) m =
let (bP,aP) = break ((==) '.') m
in if (head bP == '-') then
Floater Negative (tail bP) (tail aP) e
else Floater Positive bP (tail aP) e
getExponent :: Floater -> Exponent
getExponent (Floater _ _ _ e) = e
setExponent :: Floater -> Exponent -> Floater
setExponent (Floater s m1 m2 _) e = Floater s m1 m2 e
showExponent :: Floater -> String
showExponent (Floater _ _ _ e) = let st = consistentShowInt e
in if (e < -10) then st
else if (e < 0 ) then ('-':'0':tail st)
else if (e < 10 ) then ('+':'0':st)
else ('+':st)
eliminateExponent :: Floater -> Floater
eliminateExponent (Floater s m1 m2 e) | e == 0 = Floater s m1 m2 e
| e > 0 =
if (null m2) then eliminateExponent (Floater s (m1 ++ "0") "" (e-1))
else eliminateExponent
(Floater s (m1 ++ [(head m2)]) (tail m2) (e-1))
| e < 0 =
if (null m1) then eliminateExponent (Floater s "" ("0" ++ m2) (e+1))
else eliminateExponent (Floater s (init m1) ([last m1] ++ m2)
(e+1))
onePrePoint :: Floater -> Floater
onePrePoint (Floater s m1 m2 e) | m1 == "0" && m2 == "" =
Floater s m1 m2 e
| m1 == "0" && m2 /= "" =
onePrePoint (Floater s [head m2] (tail m2) (e-1))
| m1 /= "0" && length m1 == 1 =
Floater s m1 m2 e
| m1 /= "0" && length m1 >= 1 =
onePrePoint (Floater s (init m1) ((last m1):m2) (e+1))
roundFloater :: Int -> Floater -> Floater
roundFloater n (Floater sgn mb ma exp) =
if (length ma <= n)
then Floater sgn mb (ma ++ replicate (n - length ma) '0') exp
else if (digitToInt (ma !! n) < 5)
then Floater sgn mb (take n ma) exp
else roundUp (Floater sgn mb (take n ma) exp)
where
roundUp :: Floater -> Floater
roundUp (Floater s m1 m2 e) = Floater s m1Result m2Result e
where
(m2Result, m2Overflow) = roundStringUp m2
(m1Rounded, m1Overflow) = if m2Overflow
then roundStringUp m1
else (m1, False)
m1Result = if m1Overflow
then "1" ++ m1Rounded
else m1Rounded
roundStringUp :: String -> (String, Bool)
roundStringUp s = let (res, overflow) = roundBigEndianStrUp (reverse s) True
in (reverse res, overflow)
roundBigEndianStrUp :: String -> Bool -> (String, Bool)
roundBigEndianStrUp "" b = ("", b)
roundBigEndianStrUp (c:cs) False = (c:cs, False)
roundBigEndianStrUp (c:cs) True =
let nc = digitToInt c
in if nc == 9 then let (rs, overflow) = roundBigEndianStrUp cs True
in ('0':rs, overflow)
else (show (nc+1) ++ cs, False)
--- FLOATER DATA TYPE END ------------------------
--- HANDLING OF FLAGS BEGIN ----------------------
-- | Handling flags
data Flags = Flags Bool -- '-' appears
Bool -- '+' appears
Bool -- '0' appears
Bool -- ' ' appears
Bool -- '#' appears
getMinusFlag :: Flags -> Bool
getMinusFlag (Flags b _ _ _ _) = b
getPlusFlag :: Flags -> Bool
getPlusFlag (Flags _ b _ _ _) = b
getZeroFlag :: Flags -> Bool
getZeroFlag (Flags _ _ b _ _) = b
getSpaceFlag :: Flags -> Bool
getSpaceFlag (Flags _ _ _ b _) = b
getHashFlag :: Flags -> Bool
getHashFlag (Flags _ _ _ _ b) = b
-- Converters of arguments
convertFlags :: Maybe String -> Flags
convertFlags = maybe (Flags False False False False False)
(convFlags (Flags False False False False False))
where
convFlags :: Flags -> String -> Flags
convFlags f "" = f
convFlags (Flags b1 b2 b3 b4 b5) (c:cs) = case c of
'-' -> convFlags (Flags True b2 b3 b4 b5 ) cs
'+' -> convFlags (Flags b1 True b3 b4 b5 ) cs
'0' -> convFlags (Flags b1 b2 True b4 b5 ) cs
' ' -> convFlags (Flags b1 b2 b3 True b5 ) cs
'#' -> convFlags (Flags b1 b2 b3 b4 True) cs
convertWidth :: Maybe Width -> Int
convertWidth = maybe 0 id
convertPrecision :: Maybe Int -> Int
convertPrecision = maybe 1 id
--- HANDLING OF FLAGS END ------------------------
--- FILLING A STRING WITH APPROPRIATE ALIGNMENT
data Alignment = LeftAlign | RightAlign
deriving Eq
fillWithCharsLeftAlign :: Int -> Char -> String -> String
fillWithCharsLeftAlign = fillWithChars LeftAlign
fillWithCharsRightAlign :: Int -> Char -> String -> String
fillWithCharsRightAlign = fillWithChars RightAlign
fillWithChars :: Alignment -> Int -> Char -> String -> String
fillWithChars a n c st = let i = n - length st
in if (i > 0)
then
if (a == RightAlign)
then replicate i c ++ st
else st ++ replicate i c
else st
--- CONSISTENT NUMBER REPRESENTATION AS A STRING -----------
-- The show function on Int and Float is different for pakcs and kics2.
-- show -1
-- pakcs: (-1)
-- kics2: -1
-- Therefor we need a function that removes the parenthesis.
consistentShowInt :: Int -> String
consistentShowInt = showWithoutParantheses '(' ')' . show
consistentShowFloat :: Float -> String
consistentShowFloat = showWithoutParantheses '(' ')' . show
showWithoutParantheses :: Char -> Char -> String -> String
showWithoutParantheses start_p end_p s =
let lengthOfString = length s
in if (lengthOfString >= 2)
then
let (h,t) = splitAt 1 s
(r,l) = splitAt (lengthOfString-2) t
in if (head h == start_p && head l == end_p)
then r
else s
else s
--- CONVERSION OF INTEGERS TO DIFFERENT NUMERATIVE SYSTEMS -----
showIntAsOct :: Int -> String
showIntAsOct = convertToBase 8
showIntAsHex :: Int -> String
showIntAsHex = convertToBase 16
convertToBase :: Int -> Int -> String
convertToBase b n =
if (b < 2 || b > 16)
then error $ "Can't handle base " ++ (show b)
++ ". Can only handle bases between 2 and 16."
else if (n < -2147483647)
then error $ "Can only handle integers geq -2147483648."
else if (n == 0) then "0"
else if (n < 0) then let num = bitNot ((n*(-1))-1)
in cTB "" b num
else cTB "" b n
where
cTB :: String -> Int -> Int -> String
cTB acc base m = if (m == 0) then acc else
let dr = ((div m base),(mod m base))
d = (fst dr)
r = (snd dr)
st = if (r < 10) then (show r) else
case r of
10 -> "a"
11 -> "b"
12 -> "c"
13 -> "d"
14 -> "e"
15 -> "f"
in cTB (st ++ acc) b d
--- Returns the bitwise NOT of the argument.
--- Since integers have unlimited precision,
--- only the 32 least significant bits are computed.
---
--- @param n - Argument.
--- @return the bitwise negation of `n` truncated to 32 bits.
bitNot :: Int -> Int
bitNot n = aux 32 n
where
aux c m = if c==0
then 0
else let p = 2 * aux (c-1) (m `div` 2)
q = 1 - m `mod` 2
in p + q
------------------------------------------------------------------------------
|