{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
#include "HsBaseConfig.h"
module Text.Show.Pragmatic (
Show(..), print
, ltdPrecShowsPrec
, showsPrecWithSharedPrecision
, ShowMagnitudeRangeLimited(..)
) where
import Prelude hiding (Show(..), shows, print)
import qualified Prelude
import Data.Foldable (toList)
import Data.List (intersperse, minimumBy)
import Data.Ord (comparing)
import Data.Int (Int8, Int16, Int32, Int64)
import Data.Word (Word8, Word16, Word32, Word64)
import Data.Ratio
import Data.Complex (Complex((:+)), magnitude)
#if MIN_VERSION_base(4,8,0)
import Numeric.Natural (Natural)
#endif
#if MIN_VERSION_base(4,10,0)
import Type.Reflection (TyCon, SomeTypeRep, Module)
#endif
#if MIN_VERSION_base(4,9,0)
import GHC.Stack (SrcLoc, CallStack)
#endif
#if MIN_VERSION_base(3,0,0)
import Control.Exception.Base ( SomeException, ArithException, ErrorCall, IOException
, MaskingState
, ArrayException, AsyncException
#if MIN_VERSION_base(4,7,0)
, SomeAsyncException
#endif
, AssertionFailed
#if MIN_VERSION_base(4,10,0)
, CompactionFailed
#endif
#if MIN_VERSION_base(4,7,1)
, AllocationLimitExceeded
#endif
, Deadlock, BlockedIndefinitelyOnSTM
, BlockedIndefinitelyOnMVar
, NestedAtomically, NonTermination
#if MIN_VERSION_base(4,9,0)
, TypeError
#endif
, NoMethodError
, RecUpdError, RecConError, RecSelError, PatternMatchFail
)
#endif
import Data.Char (GeneralCategory)
import Text.Read.Lex (Number, Lexeme)
#if MIN_VERSION_base(4,7,0)
import GHC.Fingerprint.Type (Fingerprint)
#endif
import System.IO (IOMode)
import System.IO.Error (IOErrorType)
import System.Exit (ExitCode)
import Foreign.Ptr (IntPtr, WordPtr)
import Foreign.C.Types ( CUIntMax, CIntMax, CUIntPtr, CIntPtr
, CSUSeconds, CUSeconds, CTime, CClock
, CSigAtomic, CWchar, CSize, CPtrdiff
, CDouble, CFloat
#if MIN_VERSION_base(4,10,0)
, CBool
#endif
, CULLong, CLLong, CULong, CLong, CUInt, CInt, CUShort, CShort
, CUChar, CSChar, CChar
)
#if MIN_VERSION_base(4,10,0)
import GHC.TypeNats (SomeNat)
import GHC.TypeLits (SomeSymbol)
#endif
#if MIN_VERSION_base(4,9,0)
import GHC.Generics ( DecidedStrictness, SourceStrictness, SourceUnpackedness
, Associativity, Fixity )
#endif
import Data.Monoid (Any, All)
#if MIN_VERSION_base(4,4,0)
import GHC.IO.Encoding.Types (CodingProgress, TextEncoding)
import GHC.IO.Encoding.Failure (CodingFailureMode)
#endif
import GHC.IO.Device (SeekMode)
import GHC.IO.Handle (NewlineMode, Newline, BufferMode, Handle, HandlePosn)
#if MIN_VERSION_base(4,10,0)
import GHC.IO.Handle.Lock (FileLockingNotSupported)
#endif
#if MIN_VERSION_base(4,9,0)
import GHC.StaticPtr (StaticPtrInfo)
#endif
import System.Posix.Types ( Fd
#if MIN_VERSION_base(4,10,0)
#if defined(HTYPE_TIMER_T)
, CTimer
#endif
, CKey, CId, CFsFilCnt, CFsBlkCnt
#if defined(HTYPE_CLOCKID_T)
, CClockId
#endif
, CBlkCnt, CBlkSize
#endif
, CRLim, CTcflag, CSpeed, CCc, CUid
, CNlink, CGid, CSsize, CPid, COff, CMode, CIno, CDev )
#if MIN_VERSION_base(4,8,1)
import GHC.Event (Lifetime, Event, FdKey)
#endif
#if MIN_VERSION_base(2,1,0)
import Data.Dynamic (Dynamic)
#endif
import GHC.Conc (ThreadStatus, BlockReason)
import Control.Concurrent (ThreadId)
#if MIN_VERSION_base(4,8,0)
import Data.Version (Version)
#endif
#if MIN_VERSION_base(4,5,0)
import Data.Version (Version)
#endif
#if MIN_VERSION_base(4,10,0)
import GHC.Stats (RTSStats)
#endif
#if MIN_VERSION_base(4,9,0)
import GHC.RTS.Flags ( RTSFlags
#if MIN_VERSION_base(4,10,0)
, ParFlags
#endif
, TickyFlags, TraceFlags, DoTrace, ProfFlags
, DoHeapProfile, CCFlags, DoCostCentres, DebugFlags, MiscFlags
, ConcFlags, GCFlags, GiveGCStats )
#endif
import Data.Data ( Fixity, ConstrRep, DataRep
#if MIN_VERSION_base(4,0,0)
, Constr
#endif
, DataType )
#if MIN_VERSION_base(4,8,0)
import Data.Void
#endif
import qualified Data.Set as Set
import qualified Data.IntSet as ℤSet
import qualified Data.Map as Map
import qualified Data.IntMap as ℤMap
import qualified Data.Sequence as Seq
import qualified Data.Tree as Tree
class Show a where
{-# MINIMAL showsPrec | show #-}
showsPrec :: Int -> a -> ShowS
showsPrec _ x = (show x++)
show :: a -> String
show = (`shows`"")
showList :: [a] -> ShowS
showList = defaultShowList
defaultShowList :: Show a => [a] -> ShowS
defaultShowList [] = ("[]"++)
defaultShowList (x:xs) = ('[':) . shows x . flip (foldr (\y -> (',':) . shows y)) xs . (']':)
shows :: Show a => a -> ShowS
shows = showsPrec 0
#define StdShow(A) \
instance Show (A) where { \
show = Prelude.show; \
showsPrec = Prelude.showsPrec; \
showList = Prelude.showList }
StdShow(Bool)
StdShow(Int)
StdShow(Int8)
StdShow(Int16)
StdShow(Int32)
StdShow(Int64)
StdShow(Integer)
#if MIN_VERSION_base(4,8,0)
StdShow(Natural)
#endif
StdShow(Ordering)
StdShow(Word)
StdShow(Word8)
StdShow(Word16)
StdShow(Word32)
StdShow(Word64)
#if MIN_VERSION_base(4,9,0)
StdShow(CallStack)
#endif
#if MIN_VERSION_base(4,10,0)
StdShow(SomeTypeRep)
#endif
StdShow(())
#if MIN_VERSION_base(4,10,0)
StdShow(TyCon)
StdShow(Module)
#endif
#if MIN_VERSION_base(4,9,0)
StdShow(SrcLoc)
#endif
#if MIN_VERSION_base(3,0,0)
StdShow(SomeException)
#endif
StdShow(GeneralCategory)
StdShow(Number)
StdShow(Lexeme)
#if MIN_VERSION_base(4,7,0)
StdShow(Fingerprint)
#endif
StdShow(IOMode)
StdShow(IntPtr)
StdShow(WordPtr)
StdShow(CUIntMax)
StdShow(CIntMax)
StdShow(CUIntPtr)
StdShow(CIntPtr)
StdShow(CSUSeconds)
StdShow(CUSeconds)
StdShow(CTime)
StdShow(CClock)
StdShow(CSigAtomic)
StdShow(CWchar)
StdShow(CSize)
StdShow(CPtrdiff)
#if MIN_VERSION_base(4,10,0)
StdShow(CBool)
#endif
StdShow(CULLong)
StdShow(CLLong)
StdShow(CULong)
StdShow(CLong)
StdShow(CUInt)
StdShow(CInt)
StdShow(CUShort)
StdShow(CShort)
StdShow(CUChar)
StdShow(CSChar)
StdShow(CChar)
#if MIN_VERSION_base(4,10,0)
StdShow(SomeNat)
StdShow(SomeSymbol)
#endif
#if MIN_VERSION_base(4,9,0)
StdShow(DecidedStrictness)
StdShow(SourceStrictness)
StdShow(SourceUnpackedness)
StdShow(Associativity)
StdShow(GHC.Generics.Fixity)
#endif
StdShow(Any)
StdShow(All)
#if MIN_VERSION_base(4,0,0)
StdShow(ArithException)
StdShow(ErrorCall)
#endif
#if MIN_VERSION_base(4,1,0)
StdShow(IOException)
#endif
StdShow(MaskingState)
#if MIN_VERSION_base(4,4,0)
StdShow(CodingProgress)
#endif
#if MIN_VERSION_base(4,3,0)
StdShow(TextEncoding)
#endif
StdShow(SeekMode)
StdShow(NewlineMode)
StdShow(Newline)
StdShow(BufferMode)
#if MIN_VERSION_base(4,1,0)
StdShow(Handle)
StdShow(IOErrorType)
#endif
StdShow(ExitCode)
#if MIN_VERSION_base(4,1,0)
StdShow(ArrayException)
StdShow(AsyncException)
#endif
#if MIN_VERSION_base(4,7,0)
StdShow(SomeAsyncException)
#endif
#if MIN_VERSION_base(4,1,0)
StdShow(AssertionFailed)
#endif
#if MIN_VERSION_base(4,10,0)
StdShow(CompactionFailed)
#endif
#if MIN_VERSION_base(4,7,1)
StdShow(AllocationLimitExceeded)
#endif
#if MIN_VERSION_base(4,1,0)
StdShow(Deadlock)
StdShow(BlockedIndefinitelyOnSTM)
StdShow(BlockedIndefinitelyOnMVar)
StdShow(CodingFailureMode)
#endif
StdShow(Fd)
#if MIN_VERSION_base(4,10,0)
#if defined(HTYPE_TIMER_T)
StdShow(CTimer)
#endif
StdShow(CKey)
StdShow(CId)
StdShow(CFsFilCnt)
StdShow(CFsBlkCnt)
#if defined(HTYPE_CLOCKID_T)
StdShow(CClockId)
#endif
StdShow(CBlkCnt)
StdShow(CBlkSize)
#endif
StdShow(CRLim)
StdShow(CTcflag)
StdShow(CSpeed)
StdShow(CCc)
StdShow(CUid)
StdShow(CNlink)
StdShow(CGid)
StdShow(CSsize)
StdShow(CPid)
StdShow(COff)
StdShow(CMode)
StdShow(CIno)
StdShow(CDev)
#if MIN_VERSION_base(4,8,1)
StdShow(Lifetime)
StdShow(Event)
#endif
#if MIN_VERSION_base(2,1,0)
StdShow(Dynamic)
#endif
StdShow(ThreadStatus)
StdShow(BlockReason)
#if MIN_VERSION_base(4,2,0)
StdShow(ThreadId)
#endif
#if MIN_VERSION_base(4,0,0)
StdShow(NestedAtomically)
StdShow(NonTermination)
#endif
#if MIN_VERSION_base(4,9,0)
StdShow(TypeError)
#endif
#if MIN_VERSION_base(4,0,0)
StdShow(NoMethodError)
StdShow(RecUpdError)
StdShow(RecConError)
StdShow(RecSelError)
StdShow(PatternMatchFail)
#endif
StdShow(FdKey)
#if MIN_VERSION_base(4,10,0)
StdShow(FileLockingNotSupported)
#endif
#if MIN_VERSION_base(4,1,0)
StdShow(HandlePosn)
#endif
#if MIN_VERSION_base(4,8,0)
StdShow(Version)
#endif
#if MIN_VERSION_base(4,10,0)
StdShow(RTSStats)
StdShow(ParFlags)
#endif
#if MIN_VERSION_base(4,9,0)
StdShow(RTSFlags)
StdShow(TickyFlags)
StdShow(TraceFlags)
StdShow(DoTrace)
StdShow(ProfFlags)
StdShow(DoHeapProfile)
StdShow(CCFlags)
StdShow(DoCostCentres)
StdShow(DebugFlags)
StdShow(MiscFlags)
StdShow(ConcFlags)
StdShow(GCFlags)
StdShow(GiveGCStats)
#endif
StdShow(Data.Data.Fixity)
StdShow(ConstrRep)
StdShow(DataRep)
#if MIN_VERSION_base(4,0,0)
StdShow(Constr)
#endif
StdShow(DataType)
#if MIN_VERSION_base(4,9,0)
StdShow(StaticPtrInfo)
#endif
#if MIN_VERSION_base(4,8,0)
StdShow(Void)
#endif
instance Show Char where
show c | c>'\31', c/='\'', c/='\\'
= '\'':c:"'"
| otherwise = Prelude.show c
showList cs = ('"':) . flip (foldr showc) cs . ('"':)
where showc '"' = ("\\\""++)
showc '\\' = ("\\\\"++)
showc '\SO' = ("\\SO\\&"++)
showc c | c>'\31' = (c:)
| otherwise = case show c of
('\'':q) -> case break (=='\'') q of
(r,"'") -> (r++)
class Show a => ShowMagnitudeRangeLimited a where
showsPrecMagnitudeRangeLimited :: Int -> Int -> a -> ShowS
instance Show Float where
showsPrec = ltdPrecShowsPrec 7
showList = ltdPrecShowList id 7
instance ShowMagnitudeRangeLimited Float where
showsPrecMagnitudeRangeLimited = ltdPrecShowsPrec
instance Show Double where
showsPrec = ltdPrecShowsPrec 10
showList = ltdPrecShowList id 10
instance ShowMagnitudeRangeLimited Double where
showsPrecMagnitudeRangeLimited = ltdPrecShowsPrec
instance Show CFloat where
showsPrec = ltdPrecShowsPrec 5
showList = ltdPrecShowList id 5
instance ShowMagnitudeRangeLimited CFloat where
showsPrecMagnitudeRangeLimited = ltdPrecShowsPrec
instance Show CDouble where
showsPrec = ltdPrecShowsPrec 10
showList = ltdPrecShowList id 10
instance ShowMagnitudeRangeLimited CDouble where
showsPrecMagnitudeRangeLimited = ltdPrecShowsPrec
ltdPrecShowList :: (ShowMagnitudeRangeLimited n, RealFloat sn)
=> (n -> sn) -> Int -> [n] -> ShowS
ltdPrecShowList realise precision vals
= ('[':) . flip (foldr id)
(intersperse (',':)
$ showsPrecWithSharedPrecision realise precision 0 vals)
. (']':)
showsPrecWithSharedPrecision :: (ShowMagnitudeRangeLimited n, RealFloat sn, Traversable list)
=> (n -> sn)
-> Int
-> Int
-> list n
-> list ShowS
showsPrecWithSharedPrecision realise precision p vals
= fmap (\val ->
let uMagn = usableMagnitude $ realise val
in showsPrecMagnitudeRangeLimited
(max 0 $ precision - floor (maxUMag - uMagn)) p val
) vals
where usableMagnitude n
| n<0 = usableMagnitude (-n)
| n==n, 2*n>n = logBase 10 n
| otherwise = -1/0
maxUMag = maximum $ usableMagnitude . realise <$> vals
ltdPrecShowsPrec :: (RealFloat n) => Int -> Int -> n -> ShowS
ltdPrecShowsPrec precision p n cont
= minimumBy (comparing length)
[ postProc $ ltdPrecShowsPrecDecimal precision p' (preProc n) ""
| (preProc, p', postProc)
<- [ (id, p, id) ]
++[ ( (/μ)
, 7, \s -> case s of
"1" -> sμ ""
"(-1)"-> showParen (p>=6) (('-':) . sμ) ""
_ -> showParen (p>7) ((s++) . ('*':) . sμ) ""
)
| (μ,sμ) <- (pi, ("pi"++))
:[ (pi / fromIntegral m, ("pi/"++) . shows m)
| m<-[2,3,4 :: Int] ]
++[ (sqrt $ fromIntegral n, ("sqrt "++) . shows n)
| n<-[2,3,5 :: Int] ]
++[ ( sqrt (fromIntegral n)/fromIntegral m
, ("sqrt "++) . shows n . ('/':) . shows m)
| n<-[2,3 :: Int]
, m<-[2,3 :: Int] ]
]
++[ ( (*fromIntegral n)
, 7, \s -> showParen (p>7) ((s++) . ('/':) . shows n) "" )
| n<-[3,7,9 :: Int] ]
] ++ cont
ltdPrecShowsPrecDecimal :: (RealFloat n) => Int -> Int -> n -> ShowS
ltdPrecShowsPrecDecimal _ _ 0 = ("0"++)
ltdPrecShowsPrecDecimal precision p n
| not (n==n) = ("NaN"++)
| n<0 = showParen (p>5)
$ ('-':) . ltdPrecShowsPrecDecimal precision 0 (negate n)
| n==n*2 = ("Infinity"++)
| e₁₀<7 && lrDigs <= e₁₀
= (rDigits++) . (replicate (e₁₀-lrDigs) '0' ++)
| e₁₀>0 && e₁₀<3
= (take e₁₀ rDigits++) . ('.':) . (drop e₁₀ rDigits++)
| e₁₀> -2 && e₁₀<=0
= ("0."++) . (replicate (negate e₁₀) '0'++) . (rDigits++)
| [hd] <- rDigits
= (hd:) . ("e"++) . shows (e₁₀-1)
| (hd:qd@(_:_)) <- rDigits
= (hd:) . ('.':) . (qd++) . ("e"++) . shows (e₁₀-1)
where (e₁₀,m₁₀Approx) = correctPrecision . ceiling $ logBase 10 n
where correctPrecision e
= case show (round $ n * 10^^(precision+2 - e) :: Int) of
digits | length digits <= precision+2 -> (e,digits)
| otherwise -> correctPrecision $ e+1
(rApprZeroes, rDigits') = break (>'0') . reverse $ m₁₀Approx
rDigits = reverse rDigits'
lrDigs = length rDigits
instance (Show a) => Show [a] where
showsPrec _ = showList
instance (Show a, Ord a) => Show (Seq.Seq a) where
showsPrec _ = defaultShowList . toList
instance (Show a, Ord a) => Show (Set.Set a) where
showsPrec _ = defaultShowList . Set.toList
instance Show ℤSet.IntSet where
showsPrec _ = defaultShowList . ℤSet.toList
instance (Show a, Ord a, Show b) => Show (Map.Map a b) where
showsPrec _ = defaultShowList . Map.toList
instance (Show b) => Show (ℤMap.IntMap b) where
showsPrec _ = defaultShowList . ℤMap.toList
instance (Show a) => Show (Tree.Tree a) where
showsPrec p (Tree.Node a st) = showParen (p>9)
$ ("Node "++) . showsPrec 11 a . (' ':) . shows st
instance (Show a, Show b) => Show (a,b) where
showsPrec _ (a,b) = ('(':) . shows a . (',':) . shows b . (')':)
instance (Show a, Show b, Show c) => Show (a,b,c) where
showsPrec _ (a,b,c) = ('(':) . shows a . (',':) . shows b . (',':) . shows c . (')':)
instance (Show a, Show b, Show c, Show d) => Show (a,b,c,d) where
showsPrec _ (a,b,c,d) = ('(':)
. shows a . (',':) . shows b . (',':) . shows c . (',':) . shows d
. (')':)
instance (Integral i, Show i) => Show (Ratio i) where
showsPrec p n
| n<0 = showParen (p>5) $ ('-':) . showsPrec 6 (-n)
| denominator n == 1 = shows $ numerator n
| otherwise = showParen (p>6) $ shows (numerator n)
. ('/':) . shows (denominator n)
instance Show (Complex Double) where
showsPrec = ltdPrecShowsPrecComplex 10
showList = ltdPrecShowList magnitude 10
instance Show (Complex Float) where
showsPrec = ltdPrecShowsPrecComplex 7
showList = ltdPrecShowList magnitude 7
instance (RealFloat a, Show (Complex a), ShowMagnitudeRangeLimited a)
=> ShowMagnitudeRangeLimited (Complex a) where
showsPrecMagnitudeRangeLimited = ltdPrecShowsPrecComplex
ltdPrecShowsPrecComplex :: (RealFloat r, ShowMagnitudeRangeLimited r)
=> Int -> Int -> Complex r -> ShowS
ltdPrecShowsPrecComplex precision p (r:+i)
| abs r > abs i * 10^precision
= ltdPrecShowsPrec precision p r
| otherwise
= case ($"")<$>showsPrecWithSharedPrecision id precision 6 [r,i] of
[sr,"0"] -> showParen (p>7) $ (sr++)
[sr,si] -> showParen (p>6) $ (sr++) . (":+"++) . (si++)
print :: Show a => a -> IO ()
print = putStrLn . show