module Text.PrettyPrint.GenericPretty(pp, ppLen, ppStyle, pretty, prettyLen, prettyStyle, fullPP,
genOut, wrapParens, outputIO, outputStr,
Out(..), Generic) where
import Data.List
import GHC.Generics
import Data.Char
import FastString
import Text.PrettyPrint.MyPretty
class Out a where
docPrec :: Int
-> a
-> Doc
doc :: a -> Doc
docList :: [a] -> Doc
doc = docPrec 0
docPrec _ = doc
docList = docListWith doc
genOut :: (Generic a ,GOut (Rep a)) => Int -> a -> Doc
genOut n x = sep $ out1 (from x) Pref n False
docListWith :: (a -> Doc) -> [a] -> Doc
docListWith f = brackets . fcat . punctuate comma . map f
middle :: [a] -> [a]
middle [] = []
middle [x] = [x]
middle (x:xs) = init xs
wrapParens :: Bool -> [Doc] -> [Doc]
wrapParens _ [] = []
wrapParens False s = s
wrapParens True s
| length s == 1 = [lparen <> head s <> rparen]
|otherwise = [lparen <> head s] ++ middle s ++ [last s <> rparen]
showDocOneLine :: Doc -> String
showDocOneLine = fullRender OneLineMode 1 1 outputStr ""
data Type = Rec | Pref | Inf String
class GOut f where
out1 :: f x
-> Type
-> Int
-> Bool
-> [Doc]
isNullary :: f x -> Bool
instance GOut U1 where
out1 _ _ _ _ = [empty]
isNullary _ = True
instance (GOut f, Datatype c) => GOut (M1 D c f) where
out1 (M1 a) = out1 a
isNullary (M1 a) = isNullary a
instance (GOut f, Selector c) => GOut (M1 S c f) where
out1 s@(M1 a) t d p
| selector == "" = out1 a t d p
| otherwise = (text selector <+> char '='):map (nest $ length selector + 3) (out1 a t 0 p)
where
selector = selName s
isNullary (M1 a) = isNullary a
instance (GOut f, Constructor c) => GOut (M1 C c f) where
out1 c@(M1 a) _ d p =
case fixity of
Prefix -> wrapParens boolParens $ text name: makeMargins t boolParens (out1 a t 11 boolParens)
Infix _ m -> wrapParens (d>m) $ out1 a t (m+1) (d>m)
where
boolParens = d>10 && (not $ isNullary a)
name = checkInfix $ conName c
fixity = conFixity c
t = if conIsRecord c then Rec else
case fixity of
Prefix -> Pref
Infix _ _ -> Inf (conName c)
makeMargins :: Type -> Bool -> [Doc] -> [Doc]
makeMargins _ _ [] = []
makeMargins Rec b s
| length s == 1 = [nest (length name + 1) (lbrace <> head s <> rbrace)]
| otherwise = nest (length name + 1) (lbrace <> head s) :
map (nest $ length name + 2) (middle s ++ [last s <> rbrace])
makeMargins _ b s = map (nest $ length name + if b then 2 else 1) s
checkInfix :: String -> String
checkInfix [] = []
checkInfix (x:xs)
| fixity == Prefix && (isAlphaNum x || x == '_') = (x:xs)
| otherwise = "(" ++ (x:xs) ++ ")"
isNullary (M1 a) = isNullary a
instance (Out f) => GOut (K1 t f) where
out1 (K1 a) _ d _ = [docPrec d a]
isNullary _ = False
instance (GOut f, GOut g) => GOut (f :+: g) where
out1 (L1 a) t d p = out1 a t d p
out1 (R1 a) t d p = out1 a t d p
isNullary (L1 a) = isNullary a
isNullary (R1 a) = isNullary a
instance (GOut f, GOut g) => GOut (f :*: g) where
out1 (f :*: g) t@Rec d p = init pfn ++ [last pfn <> comma] ++ pgn
where
pfn = out1 f t d p
pgn = out1 g t d p
out1 (f :*: g) t@(Inf s) d p = init pfn ++ [last pfn <+> text s] ++ checkIndent pgn
where
pfn = out1 f t d p
pgn = out1 g t d p
checkIndent :: [Doc] -> [Doc]
checkIndent [] = []
checkIndent m@(x:xs)
| parens == 0 = if p then map (nest 1) m else m
| otherwise = map (nest $ cons + 1 + parenSpace) m
where
parenSpace = if p then 1 else 0
strG = showDocOneLine x
strF = showDocOneLine (head pfn)
parens = length $ takeWhile (== '(') strG
cons = length $ takeWhile( /= ' ') (dropWhile(== '(') strF)
out1 (f :*: g) t@Pref n p = out1 f t n p ++ out1 g t n p
isNullary _ = False
fullPP :: (Out a) => Mode
-> Int
-> Float
-> (TextDetails -> b -> b)
-> b
-> a
-> b
fullPP mode len rib td end a = fullRender mode len rib td end doc
where
doc = docPrec 0 a
outputIO :: TextDetails -> IO() -> IO()
outputIO td act = do
putStr $ decode td
act
where
decode :: TextDetails -> String
decode (PStr s1) = unpackFS s1
decode (LStr s1 _) = unpackLitString s1
decode (Chr c) = [c]
decode (Str s) = s
outputStr :: TextDetails -> String -> String
outputStr td str = decode td ++ str
where
decode :: TextDetails -> String
decode (PStr s1) = unpackFS s1
decode (LStr s1 _) = unpackLitString s1
decode (Chr c) = [c]
decode (Str s) = s
prettyStyle :: (Out a) => Style -> a -> String
prettyStyle s = fullPP (mode s) (lineLength s) (ribbonsPerLine s) outputStr ""
prettyLen :: (Out a) => Int -> a -> String
prettyLen l = fullPP PageMode l 1 outputStr ""
pretty :: (Out a) => a -> String
pretty = prettyStyle style
ppStyle :: (Out a) => Style -> a -> IO()
ppStyle s = fullPP (mode s) (lineLength s) (ribbonsPerLine s) outputIO (putChar '\n')
ppLen :: (Out a) => Int -> a -> IO()
ppLen l = fullPP PageMode l 1 outputIO (putChar '\n')
pp :: (Out a) => a -> IO()
pp = ppStyle style
instance Out Char where
docPrec _ a = char '\'' <> (text.middle.show $ a) <> char '\''
docList xs = text $ show xs
instance Out Integer where
docPrec n x
| n/=0 && x<0 = parens $ integer x
| otherwise = integer x
instance Out a => Out [a] where
docPrec _ = docList
instance Out Bool where
docPrec _ True = text "True"
docPrec _ False = text "False"
instance Out Int where
docPrec n x
| n/=0 && x<0 = parens $ int x
| otherwise = int x
instance Out a => Out (Maybe a) where
docPrec n Nothing = text "Nothing"
docPrec n (Just x)
| n/=0 = parens result
|otherwise = result
where
result = text "Just" <+> docPrec 10 x
instance (Out a, Out b) => Out (Either a b) where
docPrec n (Left x)
| n/=0 = parens result
| otherwise = result
where
result = text "Left" <+> docPrec 10 x
docPrec n (Right y)
| n/=0 = parens result
| otherwise = result
where
result = text "Right" <+> docPrec 10 y
instance (Out a, Out b) => Out (a, b) where
docPrec _ (a,b) = parens (sep [docPrec 0 a <> comma, docPrec 0 b])
instance (Out a, Out b, Out c) => Out (a, b, c) where
docPrec _ (a,b,c) = parens (sep [docPrec 0 a <> comma, docPrec 0 b <> comma, docPrec 0 c])
instance (Out a, Out b, Out c, Out d) => Out (a, b, c, d) where
docPrec _ (a,b,c,d) = parens (sep [docPrec 0 a <> comma, docPrec 0 b <> comma, docPrec 0 c <> comma, docPrec 0 d])
instance (Out a, Out b, Out c, Out d, Out e) => Out (a, b, c, d, e) where
docPrec _ (a,b,c,d,e) = parens (sep [docPrec 0 a <> comma, docPrec 0 b <> comma, docPrec 0 c <> comma, docPrec 0 d <> comma, docPrec 0 e])
instance (Out a, Out b, Out c, Out d, Out e, Out f)
=> Out (a, b, c, d, e, f) where
docPrec _ (a, b, c, d, e, f) =
parens (sep [docPrec 0 a <> comma, docPrec 0 b <> comma, docPrec 0 c <> comma,
docPrec 0 d <> comma, docPrec 0 e <> comma, docPrec 0 f])
instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g)
=> Out (a, b, c, d, e, f, g) where
docPrec _ (a, b, c, d, e, f, g) =
parens (sep [docPrec 0 a <> comma, docPrec 0 b <> comma, docPrec 0 c <> comma,
docPrec 0 d <> comma, docPrec 0 e <> comma, docPrec 0 f <> comma, docPrec 0 g])
instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g, Out h)
=> Out (a, b, c, d, e, f, g, h) where
docPrec _ (a, b, c, d, e, f, g, h) =
parens (sep [docPrec 0 a <> comma, docPrec 0 b <> comma, docPrec 0 c <> comma,
docPrec 0 d <> comma, docPrec 0 e <> comma, docPrec 0 f <> comma, docPrec 0 g <> comma, docPrec 0 h])
instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g, Out h, Out i)
=> Out (a, b, c, d, e, f, g, h, i) where
docPrec _ (a, b, c, d, e, f, g, h, i) =
parens (sep [docPrec 0 a <> comma, docPrec 0 b <> comma, docPrec 0 c <> comma, docPrec 0 d <> comma,
docPrec 0 e <> comma, docPrec 0 f <> comma, docPrec 0 g <> comma, docPrec 0 h <> comma, docPrec 0 i])
instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g, Out h, Out i, Out j)
=> Out (a, b, c, d, e, f, g, h, i, j) where
docPrec _ (a, b, c, d, e, f, g, h, i, j) =
parens (sep [docPrec 0 a <> comma, docPrec 0 b <> comma, docPrec 0 c <> comma, docPrec 0 d <> comma,
docPrec 0 e <> comma, docPrec 0 f <> comma, docPrec 0 g <> comma, docPrec 0 h <> comma, docPrec 0 i <> comma, docPrec 0 j])
instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g, Out h, Out i, Out j, Out k)
=> Out (a, b, c, d, e, f, g, h, i, j, k) where
docPrec _ (a, b, c, d, e, f, g, h, i, j, k) =
parens (sep [docPrec 0 a <> comma, docPrec 0 b <> comma, docPrec 0 c <> comma, docPrec 0 d <> comma, docPrec 0 e<> comma,
docPrec 0 f <> comma, docPrec 0 g <> comma, docPrec 0 h <> comma, docPrec 0 i <> comma, docPrec 0 j <> comma, docPrec 0 k])
instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g, Out h, Out i, Out j, Out k, Out l)
=> Out (a, b, c, d, e, f, g, h, i, j, k, l) where
docPrec _ (a, b, c, d, e, f, g, h, i, j, k, l) =
parens (sep [docPrec 0 a <> comma, docPrec 0 b <> comma, docPrec 0 c <> comma, docPrec 0 d <> comma, docPrec 0 e <> comma,
docPrec 0 f <> comma, docPrec 0 g <> comma, docPrec 0 h <> comma, docPrec 0 i <> comma, docPrec 0 j <> comma,
docPrec 0 k <> comma, docPrec 0 l])
instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g, Out h, Out i, Out j, Out k, Out l, Out m)
=> Out (a, b, c, d, e, f, g, h, i, j, k, l, m) where
docPrec _ (a, b, c, d, e, f, g, h, i, j, k, l, m) =
parens (sep [docPrec 0 a <> comma, docPrec 0 b <> comma, docPrec 0 c <> comma, docPrec 0 d <> comma, docPrec 0 e <> comma,
docPrec 0 f <> comma, docPrec 0 g <> comma, docPrec 0 h <> comma, docPrec 0 i <> comma, docPrec 0 j <> comma,
docPrec 0 k <> comma, docPrec 0 l <> comma, docPrec 0 m])
instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g, Out h, Out i, Out j, Out k, Out l, Out m, Out n)
=> Out (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where
docPrec _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n) =
parens (sep [docPrec 0 a <> comma, docPrec 0 b <> comma, docPrec 0 c <> comma, docPrec 0 d <> comma, docPrec 0 e <> comma,
docPrec 0 f <> comma, docPrec 0 g <> comma, docPrec 0 h <> comma, docPrec 0 i <> comma, docPrec 0 j <> comma,
docPrec 0 k <> comma, docPrec 0 l <> comma, docPrec 0 m <> comma, docPrec 0 n])
instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g, Out h, Out i, Out j, Out k, Out l, Out m, Out n, Out o)
=> Out (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where
docPrec _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) =
parens (sep [docPrec 0 a <> comma, docPrec 0 b <> comma, docPrec 0 c <> comma, docPrec 0 d <> comma, docPrec 0 e <> comma,
docPrec 0 f <> comma, docPrec 0 g <> comma, docPrec 0 h <> comma, docPrec 0 i <> comma, docPrec 0 j <> comma,
docPrec 0 k <> comma, docPrec 0 l <> comma, docPrec 0 m <> comma, docPrec 0 n <> comma, docPrec 0 o])