{-# LANGUAGE BlockArguments #-}

module Test.MockCat.TH (showExp) where

import Language.Haskell.TH (Exp (..), Lit (..), Pat (..), Q, pprint)
import Language.Haskell.TH.PprLib (Doc, hcat, parens, text)
import Language.Haskell.TH.Syntax (nameBase)

showExp :: Q Exp -> Q String
showExp :: Q Exp -> Q String
showExp Q Exp
qexp = Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> (Exp -> Doc) -> Exp -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Doc
pprintExp (Exp -> String) -> Q Exp -> Q String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp
qexp

pprintExp :: Exp -> Doc
pprintExp :: Exp -> Doc
pprintExp (VarE Name
name) = String -> Doc
text (Name -> String
nameBase Name
name)
pprintExp (ConE Name
name) = String -> Doc
text (Name -> String
nameBase Name
name)
pprintExp (LitE Lit
lit) = Lit -> Doc
pprintLit Lit
lit
pprintExp (AppE Exp
e1 Exp
e2) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hcat [Exp -> Doc
pprintExp Exp
e1, String -> Doc
text String
" ", Exp -> Doc
pprintExp Exp
e2]
pprintExp (InfixE Maybe Exp
e1 Exp
e2 Maybe Exp
e3) = Maybe Exp -> Exp -> Maybe Exp -> Doc
pprintInfixE Maybe Exp
e1 Exp
e2 Maybe Exp
e3
pprintExp (LamE [Pat]
pats Exp
body) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hcat [String -> Doc
text String
"\\", [Pat] -> Doc
pprintPats [Pat]
pats, String -> Doc
text String
" -> ", Exp -> Doc
pprintExp Exp
body]
pprintExp (TupE [Maybe Exp]
exps) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hcat ((Maybe Exp -> Doc) -> [Maybe Exp] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> (Exp -> Doc) -> Maybe Exp -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Doc
text String
"") Exp -> Doc
pprintExp) [Maybe Exp]
exps)
pprintExp (ListE [Exp]
exps) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hcat ((Exp -> Doc) -> [Exp] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Doc
pprintExp [Exp]
exps)
pprintExp (SigE Exp
e Type
_) = Exp -> Doc
pprintExp Exp
e
pprintExp Exp
x = String -> Doc
text (Exp -> String
forall a. Ppr a => a -> String
pprint Exp
x)

pprintInfixE :: Maybe Exp -> Exp -> Maybe Exp -> Doc
pprintInfixE :: Maybe Exp -> Exp -> Maybe Exp -> Doc
pprintInfixE Maybe Exp
e1 Exp
e2 Maybe Exp
e3 =
  Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    [Doc] -> Doc
hcat
      [ Doc -> (Exp -> Doc) -> Maybe Exp -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Doc
text String
"") Exp -> Doc
pprintExp Maybe Exp
e1,
        Doc -> (Exp -> Doc) -> Maybe Exp -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Doc
text String
"") (Doc -> Exp -> Doc
forall a b. a -> b -> a
const (String -> Doc
text String
" ")) Maybe Exp
e1,
        Exp -> Doc
pprintExp Exp
e2,
        String -> Doc
text String
" ",
        Doc -> (Exp -> Doc) -> Maybe Exp -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Doc
text String
"") Exp -> Doc
pprintExp Maybe Exp
e3
      ]

pprintPats :: [Pat] -> Doc
pprintPats :: [Pat] -> Doc
pprintPats = [Doc] -> Doc
hcat ([Doc] -> Doc) -> ([Pat] -> [Doc]) -> [Pat] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pat -> Doc) -> [Pat] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Pat -> Doc
pprintPat

pprintPat :: Pat -> Doc
pprintPat :: Pat -> Doc
pprintPat (VarP Name
name) = String -> Doc
text (Name -> String
nameBase Name
name)
pprintPat Pat
p = String -> Doc
text (Pat -> String
forall a. Ppr a => a -> String
pprint Pat
p)

pprintLit :: Lit -> Doc
pprintLit :: Lit -> Doc
pprintLit (IntegerL Integer
n) = String -> Doc
text (Integer -> String
forall a. Show a => a -> String
show Integer
n)
pprintLit (RationalL Rational
r) = String -> Doc
text (Rational -> String
forall a. Show a => a -> String
show Rational
r)
pprintLit (StringL String
s) = String -> Doc
text (String -> String
forall a. Show a => a -> String
show String
s)
pprintLit (CharL Char
c) = String -> Doc
text (Char -> String
forall a. Show a => a -> String
show Char
c)
pprintLit Lit
l = String -> Doc
text (Lit -> String
forall a. Ppr a => a -> String
pprint Lit
l)