{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, TemplateHaskell, QuasiQuotes, UndecidableInstances #-} module Data.TrieMap.Rep.TH where import Language.Haskell.TH import Data.TrieMap.Rep genRepr :: Q Type -> Q [Dec] genRepr typ = do t <- typ let a = VarT (mkName "a") toRepImpl <- [| toRepTMap toRep |] fromRepImpl <- [| fromRepTMap fromRep |] return [InstanceD [ClassP ''Repr [a]] (ConT ''Repr `AppT` (t `AppT` a)) [TySynInstD ''Rep [t `AppT` a] ((ConT ''RepT `AppT` t) `AppT` (ConT ''Rep `AppT` a)), ValD (VarP 'toRep) (NormalB toRepImpl) [], ValD (VarP 'fromRep) (NormalB fromRepImpl) []]] genTupleRepr :: Int -> Q [Dec] genTupleRepr n = do let ts = [mkName [a] | a <- take n ['a'..]] xs <- sequence [newName [a] | a <- take n ['a'..]] xReps <- sequence [newName (a:"Rep") | a <- take n ['a'..]] let toR = 'toRep let fromR = 'fromRep let tupleT = foldl AppT (TupleT n) [VarT t | t <- ts] return [InstanceD [ClassP ''Repr [VarT t] | t <- ts] (ConT ''Repr `AppT` tupleT) [TySynInstD ''Rep [tupleT] (foldl AppT (TupleT n) [ConT ''Rep `AppT` VarT t | t <- ts]), FunD toR [Clause [TupP [VarP x | x <- xs]] (NormalB (TupE [VarE toR `AppE` VarE x | x <- xs])) []], FunD fromR [Clause [TupP [VarP xRep | xRep <- xReps]] (NormalB (TupE [VarE fromR `AppE` VarE xRep | xRep <- xReps])) []]]]