module Data.HList.RecordPuns (
pun
) where
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Data.HList.Record
import Data.HList.FakePrelude
import Data.List
import Data.HList.HList
pun :: QuasiQuoter
pun = QuasiQuoter {
quotePat = mp . parseRec,
quoteExp = me . parseRec,
quoteDec = error "Data.HList.RecordPuns.quoteDec",
quoteType = error "Data.HList.RecordPuns.quoteType"
}
extracts xs = do
record <- newName "record"
lamE [varP record]
(tupE
[ [| $(varE record) .!. $label |]
| x <- xs,
let label = [| Label :: Label $(litT (strTyLit x)) |]
])
mkExp :: [String] -> ExpQ
mkExp xs = foldr (\x acc -> [| $(mkPair x (dyn x)) .*. $acc |]) [| emptyRecord |] xs
mkPair :: String -> ExpQ -> ExpQ
mkPair x xe = [| (Label :: Label $(litT (strTyLit x))) .=. $xe |]
me :: Tree -> ExpQ
me (C as) = foldr (\(l,e) acc -> [| $(mkPair l e) .*. $acc |]) [| emptyRecord |] (mes as)
me (D _as) = error "Data.HList.RecordPuns.mp impossible"
me a = do
reportWarning $ "Data.HList.RecordPuns.mp implicit {} added around:" ++ show a
me (C [a])
mes :: [Tree] -> [(String, ExpQ)]
mes (V a : V "@": b : c) = (a, [| $(me b) `hLeftUnion` $(dyn a) |]) : mes c
mes (V a : C b : c) = (a, me (C b)) : mes c
mes (V a : D b : c) = (a, me (C b)) : mes c
mes (V a : b) = (a, varE (mkName a)) : mes b
mes [] = []
mes inp = error $ "Data.HList.RecordPuns.mes: cannot translate remaining:" ++
show (map ppTree inp)
mp :: Tree -> PatQ
mp (C as) = case unzip (mps as) of
(a, b) -> viewP (extracts a) (tupP b)
mp (D as) = conP 'Record
[viewP (varE 'prime)
(foldr ( \ (n,p) xs -> conP 'HCons'
[viewP [| \x -> x `asTypeOf`
(undefined :: Tagged $(litT (strTyLit n)) t) |]
(conP 'Tagged [p]),
xs])
(conP 'HNil' [])
(mps as))]
mp a = do
reportWarning $ "Data.HList.RecordPuns.mp implicit {} added around:" ++ show a
mp (C [a])
mps :: [Tree] -> [(String, PatQ)]
mps (V a : V "@" : b : c) = (a, asP (mkName a) (mp b)) : mps c
mps (V a : C b : c) = (a, mp (C b)) : mps c
mps (V a : D b : c) = (a, mp (D b)) : mps c
mps (V a : b) = (a, varP (mkName a)) : mps b
mps [] = []
mps inp = error $ "Data.HList.RecordPuns.mps: cannot translate remaining pattern:" ++
show (map ppTree inp)
data Tree = C [Tree]
| D [Tree]
| V String
deriving Show
parseRec :: String -> Tree
parseRec str = case parseRec' 0 0 [[]] $ lexing str of
[x] -> x
x -> C (reverse x)
parseRec' :: Int -> Int -> [[Tree]] -> [String] -> [Tree]
parseRec' n m accum ("{" : rest) = parseRec' (n+1) m ([] : accum) rest
parseRec' n m accum ("(" : rest) = parseRec' n (m+1) ([] : accum) rest
parseRec' n m (a:b:c) ("}" : rest) = parseRec' (n1) m ((C (reverse a) : b) : c) rest
parseRec' n m (a:b:c) (")" : rest) = parseRec' n (m1) ((D (reverse a) : b) : c) rest
parseRec' n m (b:c) (a : rest)
| a `notElem` ["{","}","(",")"] = parseRec' n m ((V a : b) : c) rest
parseRec' 0 0 (a:_) [] = a
parseRec' _ _ accum e = error ("Data.HList.RecordPuns.parseRec' unexpected: " ++ show e
++ "\n parsed:" ++ show (reverse accum))
ppTree :: Tree -> String
ppTree (C ts) = "{" ++ unwords (map ppTree ts) ++ "}"
ppTree (D ts) = "(" ++ unwords (map ppTree ts) ++ ")"
ppTree (V x) = x
lexing = unfoldr (\v -> case lex v of
("", "") : _ -> Nothing
e : _ -> Just e
_ -> Nothing)