81 lines
2.7 KiB
Haskell
81 lines
2.7 KiB
Haskell
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
|
|
module Utils.TH 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 --
|
|
------------
|
|
|
|
-- Alternatively uses lenses: "^. _3" projects the 3rd component of an n-tuple for any n >=3, requires import Control.Lens
|
|
{-
|
|
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 $ nameBase name
|
|
in return $ Clause pats body []
|
|
genClause _ = fail "deriveShowTheme: constructors not allowed to have arguments"
|
|
|