{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE StandaloneDeriving #-}
module THUtils where

import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.ExpandSyns
import Control.Monad.Error
import Control.Applicative
import Data.Generics
import Control.Exception
import Data.List(intersperse)
import Data.Char(ord)
    
    
deriving instance Ord Type
#if __GLASGOW_HASKELL__ >= 611
deriving instance Ord Kind
deriving instance Ord Pred
deriving instance Ord TyVarBndr

deKindSigify :: TyVarBndr -> Name
deKindSigify (PlainTV t) = t
deKindSigify (KindedTV t _) = t

#else
deKindSigify :: Name -> Name
deKindSigify = id

#endif

    
-- name2constructors :: Name -> Q [Con]
-- name2constructors n = do
--   i <- reify n
--   case i of
--       TyConI d -> dec2constructors d
--       _ -> fail ("Not a type name: "++show n++"\nInfo for this name was: "++show i)

-- dec2constructors :: Dec -> Q [Con]  
-- dec2constructors (DataD _ _ _ cs _) = return cs
-- dec2constructors (NewtypeD _ _ _ c _) = return [c]
-- -- dec2constructors (TySynD _ _ t) = type2constructors t
-- dec2constructors x = fail ("Don't know how to extract constructors from this Dec: "
--                            ++ show x)
  
-- type2constructors :: Type -> Q [Con]
-- type2constructors (ForallT _ _ t) = type2constructors t
-- type2constructors (ConT n) = name2constructors n
-- type2constructors (AppT t _) = type2constructors t
-- type2constructors x = fail ("Don't know how to extract constructors from this Type: "
--                             ++ show x)

(@@) = AppT
(@@@) = AppE
infixl 9 @@
infixl 9 @@@

-- | A type constructor applied to some argument types
data AppliedTyCon = AppliedTyCon {
      atcHead :: Name
    , atcArgs :: [Type]
    }
                  deriving (Eq,Ord,Show,Data,Typeable)
                           
-- | Rewrite 'ListT','TupleT' and 'ArrowT' to ordinary 'ConT's
normaliseSpecialTyCons ::  (Data a) => a -> a
normaliseSpecialTyCons = everywhere (mkT f)
    where
      f ListT = ConT (''[])
      f (TupleT n) = ConT (tupleTypeName n)
      f ArrowT = ConT (''(->))
      f x = x
                  

-- | Expands synonyms, then tries to parse the type as an applied type constructor
toAppliedTyCon :: (MonadError String m) => Type -> Q (m AppliedTyCon)
toAppliedTyCon t = (go [] . normaliseSpecialTyCons) `fmap` expandSyns t
    where
      go acc (ConT n) = return (AppliedTyCon n acc)
      -- go acc ListT = return (AppliedTyCon ''[] acc)
      -- go acc (TupleT n) = return (AppliedTyCon (tupleTypeName n) acc)
      -- go acc ArrowT = return (AppliedTyCon ''(->) acc)
                      
      go acc (AppT t1 t2) = go (t2:acc) t1
                            
      go acc other = throwError ("Expected applied type constructor, got: "
                                 ++ show (foldl AppT other acc))

fromAppliedTyCon :: AppliedTyCon -> Type
fromAppliedTyCon (AppliedTyCon n ts) | n == ''[] = foldl AppT ListT ts
                                     | otherwise = foldl AppT (ConT n) ts


-- | Get constructors with all type parameters instantiated as
-- described by the 'AppliedTyCon' argument
atc2constructors ::  AppliedTyCon -> Q [Con]
atc2constructors (AppliedTyCon n args) = do
  i <- reify n
  (params,cs) <- 
      case i of
        -- Note: Synonyms should already be expanded at this point by
        -- toAppliedTyCon
        
        TyConI (DataD _ _ ps cs0 _) -> return (ps,cs0)
        TyConI (NewtypeD _ _ ps c0 _) -> return (ps,[c0])
                  
        _ -> fail ("Expected this name to refer to a data or newtype: "
                  ++show n
                  ++"\nBut info for this name was: "++show i)

  let
      substs :: [(Name,Type)]
      substs = assert (length params == length args)
               (zip (fmap deKindSigify params) args)
               
      doSubsts x = foldr substInCon x substs
      

  return (doSubsts <$> cs)

  
-- | Apply 'nameBase' to all the 'Name'-typed subvalues
cutNames ::  (Data a) => a -> a
cutNames = everywhere (mkT cutName)
    where
      cutName = mkName . nameBase
                
pprintUnqual ::  (Ppr a, Data a) => a -> String
pprintUnqual = pprint . cutNames


#define showQ(X)\
            $( (runIO . print =<< (X)) >> [d| showQ_dummy______ = ()|])
        

-- showQ( liftM2 (==) (ConE ''[]) [| [] |] )


instance Ppr AppliedTyCon where
    ppr (AppliedTyCon n args) = ppr (foldl AppT (ConT n) args)


-- | 'Match' with normal body and no where clause
sMatch ::  Pat -> Exp -> Match
sMatch p b = Match p (NormalB b) []

-- | 'Clause' with normal body and no where clause
sClause ::  [Pat] -> Exp -> Clause
sClause ps b = Clause ps (NormalB b) []

cleanConstructorName :: [Char] -> [Char]
cleanConstructorName c =
 case c of
    ('(':_) | last c == ')' -> "TUPLE"++show (length c-1)
    "[]" -> "NIL"
    ":" -> "CONS"

    -- Better than nothing, I guess
    (':':c1) -> "INFIX_CTOR" ++ concatMap (\x -> "_" ++ (show . ord) x ) c1 

    _ -> c