module Test.ChasingBottoms.ApproxShow
( Prec
, ApproxShow(..)
) where
import Data.Generics
import Test.ChasingBottoms.IsBottom
import Test.ChasingBottoms.Nat
import Test.ChasingBottoms.IsType
import qualified Data.List as List
type Prec = Int
class ApproxShow a where
approxShowsPrec :: Nat -> Prec -> a -> ShowS
approxShows :: Nat -> a -> ShowS
approxShow :: Nat -> a -> String
approxShows n a = approxShowsPrec n 0 a
approxShow n a = approxShowsPrec n 0 a ""
instance Data a => ApproxShow a where
approxShowsPrec n p = gShowsPrec False n p
gShowsPrec :: Data a => Bool -> Nat -> Prec -> a -> ShowS
gShowsPrec insideList n p (a :: a)
| n == 0 = showString "_"
| isBottom a = showString "_|_"
| isFunction a = showString "<function /= _|_>"
| isTuple a = showParen True $ drive $
List.intersperse (showString ", ") $
(continueR (:) [] minPrec a)
| isString a && isAtom a = when' (not insideList) (showString "\"") $
showString "\""
| isString a = when' (not insideList) (showString "\"") $
gmapQr (.) id
( id
`mkQ`
(\c -> if n == 1 then showString "_" else
if isBottom c then showString "_|_"
else showChar c)
`extQ`
(\(a :: String) -> if n == 1 then id else
if isBottom a then showString "_|_"
else gShowsPrec True (pred n) minPrec a
)
) a
| isList a && isAtom a = when' (not insideList) (showString "[") $
showString "]"
| isList a = when' (not insideList) (showString "[") $
gmapQr (.) id
( gShowsPrec False (pred n) minPrec
`extQ`
(\(a :: a) ->
if n == 1 then id
else if isBottom a then showString "_|_"
else (if not (isAtom a) then showString ", "
else id) .
gShowsPrec True (pred n) minPrec a
)
) a
| isInfix a = showParen (not (isAtom a) && p > appPrec) $
let (arg1:arg2:rest) =
continueR (:) [] (succ appPrec) a
in (showParen (not (null rest)) $
arg1 .^. showCon a .^. arg2
) . drive rest
| otherwise = showParen (not (isAtom a) && p > appPrec) $
showCon a .
continueL (.^.) nil (succ appPrec) a
where
continueL f x p = gmapQl f x (gShowsPrec False (pred n) p)
continueR f x p = gmapQr f x (gShowsPrec False (pred n) p)
drive = foldr (.) id
nil = showString ""
f .^. g = f . showChar ' ' . g
appPrec = 10
minPrec = 0
showCon a = showString $ showConstr $ toConstr a
isAtom a = glength a == 0
isPrimitive a = not $ isAlgType (dataTypeOf a)
isInfix a = if isPrimitive a then
False
else
constrFixity (toConstr a) == Infix
wrap s = \s' -> s . s' . s
when' b s = if b then (s .) else (id .)