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 :: 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' :: a -> Maybe String prettyHaskell' a x = (String -> String) -> Maybe String -> Maybe String 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'' :: 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 (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 (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 showList :: [MySuperHero] -> String -> String $cshowList :: [MySuperHero] -> String -> String show :: MySuperHero -> String $cshow :: MySuperHero -> String showsPrec :: Int -> MySuperHero -> String -> String $cshowsPrec :: Int -> 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 showList :: [MySuperSuperHero] -> String -> String $cshowList :: [MySuperSuperHero] -> String -> String show :: MySuperSuperHero -> String $cshow :: MySuperSuperHero -> String showsPrec :: Int -> MySuperSuperHero -> String -> String $cshowsPrec :: Int -> 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 :: Int -> String -> String -> Int -> MySuperHero 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 :: Bool -> MySuperHero -> MySuperSuperHero 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)