{- |
Internal module for pretty-printing showable Haskell values.
-}
--
-- Copyright (c) 2009-2022 Stefan Wehr - http://www.stefanwehr.de
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
--
module Test.Framework.PrettyHaskell (

    prettyHaskell, prettyHaskell', prettyHaskellTests

) where

import qualified Data.List as List
import Language.Haskell.Parser
import Language.Haskell.Pretty
import Test.HUnit
import Test.Framework.Utils

prettyHaskell :: Show a => a -> String
prettyHaskell :: forall a. Show a => a -> String
prettyHaskell a
x =
    case a -> Maybe String
forall a. Show a => a -> Maybe String
prettyHaskell' a
x of
      Just String
s -> String
s
      Maybe String
Nothing -> String
"FALLBACK: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x

prettyHaskell' :: Show a => a -> Maybe String
prettyHaskell' :: forall a. Show a => a -> Maybe String
prettyHaskell' a
x =
    (String -> String) -> Maybe String -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String -> String
postProcess (a -> String
forall a. Show a => a -> String
show a
x)) (a -> Maybe String
forall a. Show a => a -> Maybe String
prettyHaskell'' a
x )

prettyHaskell'' :: Show a => a -> Maybe String
prettyHaskell'' :: forall a. Show a => a -> Maybe String
prettyHaskell'' a
x =
    let str :: String
str = a -> String
forall a. Show a => a -> String
show a
x
        code :: String
code = String
"module M where TOP = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str
    in case String -> ParseResult HsModule
parseModule String
code of
         ParseOk HsModule
x -> String -> Maybe String
forall a. a -> Maybe a
Just (HsModule -> String
forall a. Pretty a => a -> String
prettyPrint HsModule
x)
         ParseFailed SrcLoc
_ String
_ -> Maybe String
forall a. Maybe a
Nothing

postProcess :: String -> String -> String
postProcess :: String -> String -> String
postProcess String
fallback String
s =
    case (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\String
l -> Bool -> Bool
not (Char
'=' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
l)) (String -> [String]
lines String
s) of
      [] -> String
fallback
      (String
l:[String]
ls) ->
          case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'=') String
l of
            (String
prefix, Char
'=':Char
' ':String
suffix) ->
                let indentLen :: Int
indentLen = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
prefix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
                in String -> String
strip (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines (String
suffix String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
indentLen) [String]
ls))
            (String, String)
_ -> String
fallback

prettyHaskellTests :: [(String, IO ())]
prettyHaskellTests =
    [(String
"testPrettyHaskell", IO ()
testPrettyHaskell)]

data MySuperHero
    = MySuperHero
      { MySuperHero -> Int
msh_age :: Int
      , MySuperHero -> String
msh_name :: String
      , MySuperHero -> String
msh_address :: String
      , MySuperHero -> Int
msh_fun :: Int
      }
    deriving (Int -> MySuperHero -> String -> String
[MySuperHero] -> String -> String
MySuperHero -> String
(Int -> MySuperHero -> String -> String)
-> (MySuperHero -> String)
-> ([MySuperHero] -> String -> String)
-> Show MySuperHero
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> MySuperHero -> String -> String
showsPrec :: Int -> MySuperHero -> String -> String
$cshow :: MySuperHero -> String
show :: MySuperHero -> String
$cshowList :: [MySuperHero] -> String -> String
showList :: [MySuperHero] -> String -> String
Show)

data MySuperSuperHero
    = MySuperSuperHero
      { MySuperSuperHero -> Bool
mssh_isHere :: Bool
      , MySuperSuperHero -> MySuperHero
mssh_hero :: MySuperHero
      }
    deriving (Int -> MySuperSuperHero -> String -> String
[MySuperSuperHero] -> String -> String
MySuperSuperHero -> String
(Int -> MySuperSuperHero -> String -> String)
-> (MySuperSuperHero -> String)
-> ([MySuperSuperHero] -> String -> String)
-> Show MySuperSuperHero
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> MySuperSuperHero -> String -> String
showsPrec :: Int -> MySuperSuperHero -> String -> String
$cshow :: MySuperSuperHero -> String
show :: MySuperSuperHero -> String
$cshowList :: [MySuperSuperHero] -> String -> String
showList :: [MySuperSuperHero] -> String -> String
Show)

testPrettyHaskell :: IO ()
testPrettyHaskell =
    do String -> Maybe Integer -> IO ()
forall {a}. Show a => String -> a -> IO ()
assertPretty String
"Just 1" (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1)
       let hero :: MySuperHero
hero =
               MySuperHero
               { msh_age :: Int
msh_age = Int
35
               , msh_name :: String
msh_name = String
"FOO"
               , msh_address :: String
msh_address = String
"address"
               , msh_fun :: Int
msh_fun = Int
1
               }
       String -> MySuperHero -> IO ()
forall {a}. Show a => String -> a -> IO ()
assertPretty
         (String
"MySuperHero{msh_age = 35, msh_name = \"FOO\",\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
          String
"            msh_address = \"address\", msh_fun = 1}")
         MySuperHero
hero
       String -> MySuperSuperHero -> IO ()
forall {a}. Show a => String -> a -> IO ()
assertPretty
          (String
"MySuperSuperHero{mssh_isHere = True,\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
           String
"                 mssh_hero =\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
           String
"                   MySuperHero{msh_age = 35, msh_name = \"FOO\",\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
           String
"                               msh_address = \"address\", msh_fun = 1}}")
          (MySuperSuperHero { mssh_isHere :: Bool
mssh_isHere = Bool
True, mssh_hero :: MySuperHero
mssh_hero = MySuperHero
hero })
    where
      assertPretty :: String -> a -> IO ()
assertPretty String
s a
x =
          String -> String -> String -> IO ()
forall a. (HasCallStack, Eq a, Show a) => String -> a -> a -> IO ()
assertEqual (String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" /=\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
prettyHaskell a
x)
                      String
s (a -> String
forall a. Show a => a -> String
prettyHaskell a
x)