module Generics.MultiRec.Show where
import Generics.MultiRec.Base
import Generics.MultiRec.HFunctor
import Generics.MultiRec.Fold
import qualified Prelude as P
import Prelude hiding (show, showsPrec)
class HFunctor f => HShow f where
hShowsPrecAlg :: Algebra' s f (K0 [Int -> ShowS])
instance HShow (I xi) where
hShowsPrecAlg _ (I (K0 x)) = K0 x
instance Show x => HShow (K x) where
hShowsPrecAlg _ (K x) = K0 [\ n -> P.showsPrec n x]
instance HShow U where
hShowsPrecAlg _ U = K0 []
instance (HShow f, HShow g) => HShow (f :+: g) where
hShowsPrecAlg ix (L x) = hShowsPrecAlg ix x
hShowsPrecAlg ix (R y) = hShowsPrecAlg ix y
instance (HShow f, HShow g) => HShow (f :*: g) where
hShowsPrecAlg ix (x :*: y) = K0 (unK0 (hShowsPrecAlg ix x) ++ unK0 (hShowsPrecAlg ix y))
instance HShow f => HShow (f :>: ix) where
hShowsPrecAlg ix (Tag x) = hShowsPrecAlg ix x
instance HShow f => HShow (C c f) where
hShowsPrecAlg ix cx@(C x) =
case conFixity cx of
Prefix -> K0 [\ n -> showParen (not (null fields) && n > 10)
(spaces ((conName cx ++) : map ($ 11) fields))]
Infix a p -> K0 [\ n -> showParen (n > p)
(spaces (head fields p : (conName cx ++) : map ($ p) (tail fields)))]
where
fields = unK0 $ hShowsPrecAlg ix x
hShowsPrecAlg_ :: (HShow f) => s ix -> Algebra' s f (K0 [Int -> ShowS])
hShowsPrecAlg_ _ = hShowsPrecAlg
showsPrec :: forall s ix. (Ix s ix, HShow (PF s)) => s ix -> Int -> ix -> ShowS
showsPrec ix n x = spaces (map ($ n) (unK0 (fold (hShowsPrecAlg_ ix) x)))
show :: forall s ix. (Ix s ix, HShow (PF s)) => s ix -> ix -> String
show ix x = showsPrec ix 0 x ""
spaces :: [ShowS] -> ShowS
spaces [] = id
spaces [x] = x
spaces (x:xs) = x . (' ':) . spaces xs