Created
February 9, 2012 22:32
-
-
Save max630/1783879 to your computer and use it in GitHub Desktop.
AccessorTemplateExpr
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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) | |
-} |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment