module Language.Haskell.Derive.Gadt.Class.Show where
import Language.Haskell.Derive.Gadt.Common
import Data.List
import Control.Monad
import Control.Applicative
import Language.Haskell.Meta.Utils
import Language.Haskell.Exts.Pretty
import qualified Language.Haskell.Exts.Syntax as Hs
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Lib
import Text.PrettyPrint
deriveShowGadts :: String -> Q [Dec]
deriveShowGadts s = do
case parseModuleGadts s of
Left e -> fail e
Right is -> concat <$> mapM deriveShowGadtInfo is
deriveShowGadtInfo :: GadtInfo -> Q [Dec]
deriveShowGadtInfo = deriveShowGadtShowInfo . gadtShowInfo
data GadtShowInfo = GadtShowInfo
{gadtShowName :: Name
,gadtShowArity :: Int
,gadtShowCxt :: [Int]
,gadtShowCons :: [(Name, Int)]}
deriving(Show)
gadtShowInfo :: GadtInfo -> GadtShowInfo
gadtShowInfo info = GadtShowInfo
{gadtShowName = (mkName . prettyPrint . gadtName) info
,gadtShowArity = gadtArity info
,gadtShowCxt = nub (concatMap collectShowCxt (gadtCons info))
,gadtShowCons = fmap (\c -> ((mkName . prettyPrint . gadtConName) c
,(length . gadtConArgs) c))
(gadtCons info)}
collectShowCxt :: GadtConInfo -> [Int]
collectShowCxt info =
let cvs = fmap (mkName . prettyPrint) (gadtConBound info
`intersect`
gadtConFree info)
ixs = (fmap (\(n,i) -> ((mkName . prettyPrint) n, i))
. getTopTyVars . snd . splitTypeApps . gadtConType) info
in concatMap (maybe [] (:[]) . flip lookup ixs) cvs
deriveShowGadtShowInfo :: GadtShowInfo -> Q [Dec]
deriveShowGadtShowInfo info = do
do vars <- fmap VarT <$> replicateM (gadtShowArity info) (newName "a")
let cxt = fmap (ConT ''Show `AppT`) (fmap (vars!!) (gadtShowCxt info))
tyCon = conT (gadtShowName info)
decsQ = mkShowFunDs (gadtShowCons info)
decs <- fmap return <$> decsQ
sequence [instanceD (return cxt)
(conT ''Show `appT` foldl appT tyCon
(fmap return vars)) decs]
mkShowFunDs :: [(Name, Int)] -> Q [Dec]
mkShowFunDs xs = do
p <- newName "p"
forM xs (\(n,i)-> do
ns <- replicateM i (newName "x")
ps <- sequence [varP p, conP n (fmap varP ns)]
mkFunD 'showsPrec ps <$>
(let es = intersperse [|showChar ' '|]
([|showString $((litE . stringL . render . ppDoc) n)|]
: fmap (\x -> [|showsPrec 11 $(varE x)|]) ns)
in [|showParen ($(varE p) > 10) $(foldr (|.|) [|id|] es)|]))