{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}

module Utils.Common where
-- Common Utility Functions that require TemplateHaskell

-- import Data.Char

import Language.Haskell.TH
-- import Control.Monad
-- import Control.Monad.Trans.Class
-- import Control.Monad.Trans.Maybe
-- import Control.Monad.Trans.Except

------------
-- Tuples --
------------


projNI :: Int -> Int -> ExpQ -- generic projection gives I-th element of N-tuple, i.e. snd3 = $(projNI 3 2)  --ghci -fth
-- $(projN n m) :: (t1,..,tn) -> tm (for m<=n)
projNI n i = lamE [pat] rhs
  where pat = tupP (map varP xs)
        rhs = varE (xs !! (i - 1))
        xs  = [ mkName $ "x" ++ show j | j <- [1..n] ]
        
        
---------------
-- Functions --
---------------

permuteFun :: [Int] -> ExpQ -- generic permutation of function arguments, i.e. $(permuteFun [2,1]) == flip
permuteFun perm = lamE pat rhs
  where pat = map varP $ fn:xs
        rhs = foldl appE (varE fn) $ map varE ps
--         rhs = appE (varE fn) (varE $ xs!!1)
        ln  = length perm   
        xs  = [ mkName $ "x" ++ show j | j <- [1..ln] ]
        ps  = [ xs !! (j-1) | j <- perm ]
        fn  = mkName "fn" 

altFun :: [Int] -> ExpQ -- generic permutation/repetition of function arguments, i.e. $(permuteFun [2,1]) == flip
altFun perm = lamE pat rhs
  where pat = map varP $ fn:xs
        rhs = foldl appE (varE fn) $ map varE ps
--         rhs = appE (varE fn) (varE $ xs!!1)        
        mx  = maximum perm
        xs  = [ mkName $ "x" ++ show j | j <- [1..mx] ]
        ps  = [ xs !! (j-1) | j <- perm ]
        fn  = mkName "fn" 
        


-- Special Show-Instances for Themes
deriveShowWith :: (String -> String) -> Name -> Q [Dec]
deriveShowWith = deriveSimpleWith ''Show 'show

-- deriveDisplayWith :: (String -> String) -> Name -> Q [Dec]
-- deriveDisplayWith = deriveSimpleWith ''DisplayAble 'display

deriveSimpleWith ::  Name -> Name -> (String -> String) -> Name -> Q [Dec]
deriveSimpleWith cls fun strOp ty = do
    (TyConI tyCon)  <- reify ty
    (tyConName, cs) <- case tyCon of
        DataD [] nm [] _ cs _ -> return (nm, cs)
        _ -> fail "deriveShowTheme: tyCon must be a plain datatype enumeration"
    let instanceT = conT cls `appT` conT tyConName
    return <$> instanceD (return []) instanceT [genDecs cs]
  where
    genDecs :: [Con] -> Q Dec
    genDecs cs = funD fun (map genClause cs)

    genClause :: Con -> Q Clause
    genClause (NormalC name []) =
      let pats = [ConP name []]
          body = NormalB $ LitE $ StringL $ strOp $ show $ name
      in return $ Clause pats body []
    genClause _ = fail "deriveShowTheme: constructors not allowed to have arguments"