AccessorTemplateExpr

AccessorTemplateExpr.hs

{-# LANGUAGE TemplateHaskell, ViewPatterns #-}
module AccessorTemplateExpr where

import Language.Haskell.TH (reify, runIO, Info(TyConI), Dec(DataD), ppr, Con(NormalC, RecC), newName,
                            tupE, appE, lamE, varE, conE,
                            conP, varP, wildP)
import Data.Accessor.Basic (fromSetGet)

makeAccessors typeName = do
  info <- reify typeName
  case info of
    TyConI (DataD _ _ _ [getSimpleConstructor -> Just (name, n)] _) -> do
      fs <- sequence (replicate n (newName "field"))
      val <- newName "val"
      tupE (map (makeAccN name fs val) [0 .. (n - 1)])
    _ -> fail ("makeAccessors: unsupported data: " ++ show (ppr info))
  where
    getSimpleConstructor c = case c of
      NormalC name args -> Just (name, length args)
      RecC name args -> Just (name, length args)
      _ -> Nothing
    -- fromSetGet (\val ($name field0 .. _ .. field{N-1}) -> $name field0 .. val .. field{N-1})
    --            (\($name _ .. val .. _) -> val)
    makeAccN name fs val k = appE (appE (varE 'fromSetGet) set) get
      where
        set = lamE [varP val, conP name fsSetPat] (foldl appE (conE name) fsSetRes)
        get = lamE [conP name fsGetPat] (varE val)
        fsSetRes = map varE (fsH ++ [val] ++ fsT)
        fsSetPat = map varP fsH ++ [wildP] ++ map varP fsT
        fsGetPat = replicate k wildP ++ [varP val] ++ replicate (n - k - 1) wildP
        n = length fs
        (fsH, (_ : fsT)) = splitAt k fs

AccessorTemplateExprTest.hs

{-# LANGUAGE TemplateHaskell #-}
module AccessorTemplateExprTest where

import AccessorTemplateExpr (makeAccessors)

data D = D Int Int Int

(acc1, acc2, acc3) = $(makeAccessors ''D)

data E = E {a :: Int, b :: String, c :: Double}

(acc4, acc5, acc6) = $(makeAccessors ''E)

{- this would produce an error
data F = Int :+ Int
_ = $(makeAccessors ''F)
-}