{-# LANGUAGE TemplateHaskell #-}

module Text.GShow ( GShow(..), deriveShow, app_prec ) where

import Text.GRead
import Language.TTTAS

import Language.Haskell.TH
import Language.Haskell.TH.Syntax

import Data.List (nub, foldl1')

class GShow a where
  gshow :: a -> String
  gshowsPrec :: Int -> a -> ShowS

app_prec = 10 :: Int


data ADInfo = ADInfo [Name] [Con]

deriveShow :: Name -> Q [Dec]
deriveShow name = do
                   (ADInfo args cons) <- getInfo name
                   let targs = map VarT args
                       ctx   = map (AppT (ConT ''GShow)) (nub $ filterVars $ unrollApps $ mkContext cons)
                       typ   = AppT (ConT ''GShow) (foldl1' AppT $ (ConT name):targs)
                   
                   gs <- [d| gshow a =  gshowsPrec 0 a "" |]
                   let clcons = map deriveShowCon cons
                   gsps <- funD (mkName "gshowsPrec") clcons
                   return [ InstanceD ctx typ (gsps:gs) ]



mkContext :: [Con] -> Cxt
mkContext []                              = []
mkContext ((NormalC        _ args)  :cs)  = (map snd args) ++ (mkContext cs)
mkContext ((InfixC   argl  _ argr)  :cs)  = (snd argl) : ((snd argr) : (mkContext cs))

filterVars :: Cxt -> Cxt
filterVars [] = []
filterVars (v@(VarT _):vs) = v : filterVars vs
filterVars (_:vs)          =     filterVars vs

unrollApps :: [Type] -> [Type]
unrollApps [] = [] 
unrollApps (a@(AppT _ _):ts) = unrollApp a ++ unrollApps ts
unrollApps (other:ts)        = other : unrollApps ts

unrollApp :: Type -> [Type]
unrollApp app = unrollApp' app []
    where unrollApp' :: Type -> [Type] -> [Type]
          unrollApp' (AppT sub@(AppT _ _) arg) args = unrollApp' sub (arg:args)
          unrollApp' (AppT top arg)            args = top:(arg:args)


deriveShowCon :: Con -> Q Clause

deriveShowCon (NormalC name types) = do
                            names <- mapM (const $ newName "x") types
                            let pat  = conP name (map varP names)
                                shows = map ((appE fgshowp) . varE) names
                            clause [varP (mkName "d"), pat] (bdy shows) []
         where                             
               bdy s  = normalB (appE (appE fshowParen cond) (str s))
               fshowParen = varE $ mkName "showParen"
               cond = infixE (Just $ varE $ mkName "d") 
                             (varE $ mkName ">") 
                             (Just $ varE $ mkName "app_prec")
               str s = infixE (Just (appE (varE $ mkName "showString") cons))
                              (varE $ mkName ".") (Just $ conc s)
               cons  = litE $ StringL (nameBase name ++ " ")
               fgshowp = appE (varE $ mkName "gshowsPrec") (varE $ mkName "app_prec")
               conc []     = [| id |]
               conc (s:[]) = [| $(s) |]
               conc (s:rs) = [| $(s) . $(conc rs)|]
               

deriveShowCon (InfixC _ name _) = do
                            f <- getPrec name
                            clause [varP (mkName "d"), pat] (bdy f) []
         where 
               l = mkName "l"
               r = mkName "r"
               pat = infixP (varP l) name (varP r) 
               bdy (f,fl,fr) = normalB (appE (appE fshowParen (cond f)) (str fl fr))
               fshowParen = varE $ mkName "showParen"
               cond f = infixE (Just $ varE $ mkName "d") 
                               (varE $ mkName ">") 
                               (Just [| f |])

               fshowsPrec d n = appE (appE (varE $ mkName "gshowsPrec") [| d |]) n
               strl fl   = appE (appE (varE $ mkName ".") (fshowsPrec fl (varE l))) 
                                (appE (varE $ mkName "showString") 
                                      (litE $ StringL (' ' : nameBase name ++ " ")))
               str fl fr = appE (appE (varE $ mkName ".")  (strl fl)) 
                                (fshowsPrec fr (varE r))
 
getPrec :: Name -> Q (Int, Int, Int)
getPrec name = do
    (DataConI _ _ _ (Fixity f fd)) <- reify name
    return (f, (f + fLeft fd), (f + fRight fd))
    where
        fLeft   InfixL  = 0
        fLeft   InfixR  = 1
        fRight  InfixR  = 0
        fRight  InfixL  = 1



getInfo :: Name -> Q ADInfo
getInfo name = do
    info <- reify name
    case info of
        TyConI d -> case d of
            (DataD     _ _ args cs  _)  -> return $ ADInfo args cs 
            (NewtypeD  _ _ args c   _)  -> return $ ADInfo args [c]
            _                           -> scopeError
        _ -> scopeError
    where scopeError = error $ "Can only be used on algebraic datatypes (which " ++ (show name) ++ " isn't)"