summaryrefslogtreecommitdiff
path: root/src/Data/Morpheus/Types/Internal/TH.hs
blob: 1f7f9988ff0fd8a058734e90a08565053e4f7dae (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
{-# LANGUAGE TemplateHaskell #-}

module Data.Morpheus.Types.Internal.TH where

import           Data.Text                  (Text, pack, unpack)
import           Language.Haskell.TH
import           Language.Haskell.TH.Syntax

liftText :: Text -> ExpQ
liftText x = appE (varE 'pack) (lift (unpack x))

liftTextTuple :: Lift a => (Text, a) -> ExpQ
liftTextTuple (name, x) = tupE [liftText name, lift x]

liftTextMap :: Lift a => [(Text, a)] -> ExpQ
liftTextMap = listE . map liftTextTuple

apply :: Name -> [Q Exp] -> Q Exp
apply n = foldl appE (conE n)

applyT :: Name -> [Q Type] -> Q Type
applyT name = foldl appT (conT name)

typeT :: Name -> [String] -> Q Type
typeT name li = applyT name (map (varT . mkName) li)

instanceHeadT :: Name -> String -> [String] -> Q Type
instanceHeadT cName iType tArgs = applyT cName [applyT (mkName iType) (map (varT . mkName) tArgs)]

instanceFunD :: Name -> [String] -> Q Exp -> Q Dec
instanceFunD name args body = funD name [clause (map (varP . mkName) args) (normalB body) []]

instanceHeadMultiT :: Name -> Q Type -> [Q Type] -> Q Type
instanceHeadMultiT className iType li = applyT className (iType : li)