module FP.DerivingPrism where
import FP.Core
import FP.TH
import Language.Haskell.TH
import Data.Char
makePrismLogic :: (Monad m, MonadQ m) => Cxt -> Name -> [TyVarBndr] -> Name -> [Type] -> Int -> m [Dec]
makePrismLogic cx ty tyargs con args numcons = do
let lensName = mkName $ lowerCase (nameBase con) ++ toChars "L"
x <- liftQ $ newName $ toChars "x"
argVars <- liftQ $ mapOnM args $ const $ newName $ toChars "a"
return
[ SigD lensName $
ForallT tyargs cx $ app (ConT ''Prism)
[ ConT ty #@| map (VarT . tyVarBndrName) tyargs
, tup args
]
, FunD lensName
[ sclause [] $ app (ConE 'Prism)
[ LamE [tup $ map VarP argVars] $ ConE con #@| map VarE argVars
, LamE [VarP x] $
CaseE (VarE x) $ concat
[ single $ smatch (ConP con $ map VarP argVars) $
ConE 'Just #@ tup (map VarE argVars)
, if numcons <= 1 then [] else single $ smatch WildP $ ConE 'Nothing
]
]
]
]
where lowerCase = mapHead toLower
makePrisms :: Name -> Q [Dec]
makePrisms name = do
(cx, ty, tyargs, cs, _) <- maybeZero . (coerceADT *. view tyConIL) *$ liftQ $ reify name
scs <- mapM (maybeZero . coerceSimpleCon) cs
concat ^$ mapOnM scs $ \ (cname, args) -> do
makePrismLogic cx ty tyargs cname args $ length scs