-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE PackageImports #-}
{- | This is based on gleb.alexeev\@gmail.com's ipprint package on hackage.

    I'm not just using it directly because I want to pass custom formatting
    flags because my terminal is 80 chars wide, not the 137-whatever default.
-}
module Util.PPrint (
    pprint, pshow
    , format, format_str
    -- * util
    , record, list
) where
import qualified Data.Char as Char
import qualified Data.Maybe as Maybe
import qualified Language.Haskell.Parser as Parser
import qualified Language.Haskell.Pretty as Pretty
import qualified Text.PrettyPrint as PrettyPrint
import qualified Text.Printf as Printf

import qualified Util.Strings as Strings

import           "haskell-src" Language.Haskell.Syntax


-- * showable

pprint :: Show a => a -> IO ()
pprint :: forall a. Show a => a -> IO ()
pprint = [Char] -> IO ()
putStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
pshow

-- | Pretty show.
pshow :: Show a => a -> String
pshow :: forall a. Show a => a -> [Char]
pshow = [Char] -> [Char]
format forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show

-- * String

-- | Pretty up a string containing a parseable haskell value.
format :: String -> String
format :: [Char] -> [Char]
format = (HsModule -> [Char]) -> [Char] -> [Char]
parse HsModule -> [Char]
format_parsed

-- | Pretty up haskell value, unless it's a string, in which case return it
-- directly.
--
-- Previously I needed this in the REPL since it didn't have a way to say text
-- should be unformatted.  I don't need it any more, but it doesn't seem to be
-- hurting so I'll leave it here for now.
format_str :: String -> String
format_str :: [Char] -> [Char]
format_str = (HsModule -> [Char]) -> [Char] -> [Char]
parse HsModule -> [Char]
format_nonstr
    where
    format_nonstr :: HsModule -> [Char]
format_nonstr HsModule
m = forall a. a -> Maybe a -> a
Maybe.fromMaybe (HsModule -> [Char]
format_parsed HsModule
m) (HsModule -> Maybe [Char]
is_str HsModule
m)
    is_str :: HsModule -> Maybe [Char]
is_str (HsModule SrcLoc
_ Module
_ Maybe [HsExportSpec]
_ [HsImportDecl]
_ [HsPatBind SrcLoc
_ HsPat
_ (HsUnGuardedRhs HsExp
rhs) [HsDecl]
_]) =
        case HsExp
rhs of
            HsLit (HsString [Char]
s) -> forall a. a -> Maybe a
Just [Char]
s
            HsExp
_ -> forall a. Maybe a
Nothing
    is_str HsModule
_ = forall a. Maybe a
Nothing

-- * util

-- | pprint does ok for records, but it doesn't work so well if I want to print
-- part of the record, or change the types.  A real record system for haskell
-- would probably fix this.
record :: [(String, String)] -> String
record :: [([Char], [Char])] -> [Char]
record = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a -> b) -> a -> b
$ \([Char]
k, [Char]
v) ->
    let s :: [Char]
s = [Char] -> [Char]
Strings.strip [Char]
v in forall r. PrintfType r => [Char] -> r
Printf.printf [Char]
"%s:%s\n" [Char]
k
            (if Char
'\n' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
s then Char
'\n' forall a. a -> [a] -> [a]
: [Char] -> [Char]
indent_lines [Char]
s else Char
' ' forall a. a -> [a] -> [a]
: [Char]
s)

indent_lines :: [Char] -> [Char]
indent_lines = [Char] -> [Char]
Strings.rstrip forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ([Char]
indent++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
lines
indent :: [Char]
indent = [Char]
"  "

list :: [String] -> String
list :: [[Char]] -> [Char]
list [[Char]]
xs = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Int
i, [Char]
x) -> forall r. PrintfType r => [Char] -> r
Printf.printf [Char]
"%d. %s\n" Int
i [Char]
x)
    (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [[Char]]
xs)


-- * implementation

parse :: (HsModule -> String) -> String -> String
parse :: (HsModule -> [Char]) -> [Char] -> [Char]
parse HsModule -> [Char]
format [Char]
s = case [Char] -> ParseResult HsModule
Parser.parseModule ([Char]
"value = " forall a. [a] -> [a] -> [a]
++ [Char]
s) of
    Parser.ParseOk HsModule
m -> HsModule -> [Char]
format HsModule
m
    -- The formatted version appends a newline, so the unformatted one should
    -- too.
    Parser.ParseFailed SrcLoc
_ [Char]
_  -> [Char]
s forall a. [a] -> [a] -> [a]
++ [Char]
"\n"

format_parsed :: HsModule -> String
format_parsed :: HsModule -> [Char]
format_parsed = [Char] -> [Char]
strip_boilerplate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> [Char]
pprint_mode

strip_boilerplate :: String -> String
strip_boilerplate :: [Char] -> [Char]
strip_boilerplate = [Char] -> [Char]
dedent forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"    "++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char]
strip_match [Char]
"value="
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
/=Char
'\n') -- Strip module line and "value =".
    -- Prefix 4 spaces since this is how much will have been stripped from
    -- the first line, namely " = ", and make this line up vertically with the
    -- following lines.  If it fit on one line, it'll be "value = " which is
    -- not 4 characters but it doesn't matter because there's no following
    -- line.

strip_match :: String -> String -> String
strip_match :: [Char] -> [Char] -> [Char]
strip_match [Char]
pattern [Char]
str = [Char] -> [Char] -> [Char]
go [Char]
pattern [Char]
str
    where
    go :: [Char] -> [Char] -> [Char]
go [Char]
"" [Char]
s = [Char] -> [Char]
strip [Char]
s
    go [Char]
_ [Char]
"" = [Char]
""
    go (Char
p:[Char]
ps) [Char]
s = case [Char] -> [Char]
strip [Char]
s of
        Char
c : [Char]
cs | Char
p forall a. Eq a => a -> a -> Bool
== Char
c -> [Char] -> [Char] -> [Char]
go [Char]
ps [Char]
cs
        [Char]
_ -> [Char]
str
    strip :: [Char] -> [Char]
strip = forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
Char.isSpace

pprint_mode :: Pretty.Pretty a => a -> String
pprint_mode :: forall a. Pretty a => a -> [Char]
pprint_mode = forall a. Pretty a => Style -> PPHsMode -> a -> [Char]
Pretty.prettyPrintStyleMode Style
pp_style PPHsMode
Pretty.defaultMode
    where
    pp_style :: Style
pp_style = Style
PrettyPrint.style
        { ribbonsPerLine :: Float
PrettyPrint.ribbonsPerLine = Float
1, lineLength :: Int
PrettyPrint.lineLength = Int
80 }

dedent :: String -> String
dedent :: [Char] -> [Char]
dedent [Char]
s = [[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> [a] -> [a]
drop Int
indent) [[Char]]
slines
    where
    indent :: Int
indent = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum forall a b. (a -> b) -> a -> b
$ Int
80 forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
Char.isSpace) [[Char]]
slines
    slines :: [[Char]]
slines = [Char] -> [[Char]]
lines [Char]
s