module Text.PrettyPrint.GenericPretty
(pp, ppLen, ppStyle, pretty, prettyLen, prettyStyle, fullPP,
genOut, outputIO, outputStr, wrapParens, defStyle,
Out(..), Style(..), Generic) where
import Data.List
import GHC.Generics
import Pretty
import Data.Char
import FastString
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) => a
-> Mode
-> Int
-> Float
-> (TextDetails -> b -> b)
-> b
-> b
fullPP a mode len rib td end = 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 a = fullPP a (mode s) (lineLength s) (ribbonsPerLine s) outputStr ""
prettyLen :: (Out a) => Int -> a -> String
prettyLen l a = fullPP a PageMode l 1 outputStr ""
pretty :: (Out a) => a -> String
pretty = prettyStyle defStyle
ppStyle :: (Out a) => Style -> a -> IO()
ppStyle s a = fullPP a (mode s) (lineLength s) (ribbonsPerLine s) outputIO (putChar '\n')
ppLen :: (Out a) => Int -> a -> IO()
ppLen l a = fullPP a PageMode l 1 outputIO (putChar '\n')
pp :: (Out a) => a -> IO()
pp = ppStyle defStyle
defStyle :: Style
defStyle = Style {mode = PageMode, lineLength = 80, ribbonsPerLine = 1}
data Style
= Style { mode :: Mode
, lineLength :: Int
, ribbonsPerLine :: Float
}
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])