#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704
#endif
#ifndef MIN_VERSION_template_haskell
#define MIN_VERSION_template_haskell(x,y,z) (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706)
#endif
module Control.Lens.TH
(
makeLenses, makeLensesFor
, makeClassy, makeClassyFor
, makeIso
, makeLensesWith
, defaultRules
, LensRules(LensRules)
, lensRules
, classyRules
, isoRules
, lensIso
, lensField
, lensClass
, lensFlags
, LensFlag(..)
, simpleLenses
, partialLenses
, buildTraversals
, handleSingletons
, singletonIso
, singletonRequired
, createClass
, createInstance
, classRequired
, singletonAndField
, generateSignatures
) where
import Control.Applicative
import Control.Lens.Fold
import Control.Lens.Getter
import Control.Lens.Iso
import Control.Lens.Setter
import Control.Lens.Tuple
import Control.Lens.Traversal
import Control.Lens.Type
import Control.Lens.IndexedLens
import Control.Monad
import Data.Char (toLower)
import Data.Either (lefts)
import Data.Foldable hiding (concat)
import Data.Function (on)
import Data.List as List
import Data.Map as Map hiding (toList,map,filter)
import Data.Maybe (isNothing,isJust,catMaybes,fromJust)
import Data.Ord (comparing)
import Data.Set as Set hiding (toList,map,filter)
import Data.Set.Lens
import Data.Traversable hiding (mapM)
import Language.Haskell.TH
import Language.Haskell.TH.Lens
data LensFlag
= SimpleLenses
| PartialLenses
| BuildTraversals
| SingletonAndField
| SingletonIso
| HandleSingletons
| SingletonRequired
| CreateClass
| CreateInstance
| ClassRequired
| GenerateSignatures
deriving (Eq,Ord,Show,Read)
simpleLenses :: Simple Lens LensRules Bool
simpleLenses = lensFlags.contains SimpleLenses
partialLenses :: Simple Lens LensRules Bool
partialLenses = lensFlags.contains PartialLenses
buildTraversals :: Simple Lens LensRules Bool
buildTraversals = lensFlags.contains BuildTraversals
handleSingletons :: Simple Lens LensRules Bool
handleSingletons = lensFlags.contains HandleSingletons
singletonAndField :: Simple Lens LensRules Bool
singletonAndField = lensFlags.contains SingletonAndField
singletonIso :: Simple Lens LensRules Bool
singletonIso = lensFlags.contains SingletonIso
singletonRequired :: Simple Lens LensRules Bool
singletonRequired = lensFlags.contains SingletonRequired
createClass :: Simple Lens LensRules Bool
createClass = lensFlags.contains CreateClass
createInstance :: Simple Lens LensRules Bool
createInstance = lensFlags.contains CreateInstance
classRequired :: Simple Lens LensRules Bool
classRequired = lensFlags.contains ClassRequired
generateSignatures :: Simple Lens LensRules Bool
generateSignatures = lensFlags.contains GenerateSignatures
data LensRules = LensRules
{ _lensIso :: String -> Maybe String
, _lensField :: String -> Maybe String
, _lensClass :: String -> Maybe (String, String)
, _lensFlags :: Set LensFlag
}
lensIso :: Simple Lens LensRules (String -> Maybe String)
lensIso f (LensRules i n c o) = (\i' -> LensRules i' n c o) <$> f i
lensField :: Simple Lens LensRules (String -> Maybe String)
lensField f (LensRules i n c o) = (\n' -> LensRules i n' c o) <$> f n
lensClass :: Simple Lens LensRules (String -> Maybe (String, String))
lensClass f (LensRules i n c o) = (\c' -> LensRules i n c' o) <$> f c
lensFlags :: Simple Lens LensRules (Set LensFlag)
lensFlags f (LensRules i n c o) = LensRules i n c <$> f o
defaultRules :: LensRules
defaultRules = LensRules top field (const Nothing) $
Set.fromList [SingletonIso, SingletonAndField, CreateClass, CreateInstance, BuildTraversals, GenerateSignatures]
where
top (c:cs) = Just (toLower c:cs)
top _ = Nothing
field ('_':c:cs) = Just (toLower c:cs)
field _ = Nothing
lensRules :: LensRules
lensRules = defaultRules
% lensIso .~ const Nothing
% lensClass .~ const Nothing
% handleSingletons .~ True
% partialLenses .~ False
% buildTraversals .~ True
classyRules :: LensRules
classyRules = defaultRules
% lensIso .~ const Nothing
% handleSingletons .~ False
% lensClass .~ classy
% classRequired .~ True
% partialLenses .~ False
% buildTraversals .~ True
where
classy :: String -> Maybe (String, String)
classy n@(a:as) = Just ("Has" ++ n, toLower a:as)
classy _ = Nothing
isoRules :: LensRules
isoRules = defaultRules
% singletonRequired .~ True
% singletonAndField .~ True
makeLenses :: Name -> Q [Dec]
makeLenses = makeLensesWith lensRules
makeClassy :: Name -> Q [Dec]
makeClassy = makeLensesWith classyRules
makeIso :: Name -> Q [Dec]
makeIso = makeLensesWith isoRules
makeLensesFor :: [(String, String)] -> Name -> Q [Dec]
makeLensesFor fields = makeLensesWith $ lensRules % lensField .~ (`Prelude.lookup` fields)
makeClassyFor :: String -> String -> [(String, String)] -> Name -> Q [Dec]
makeClassyFor clsName funName fields = makeLensesWith $ classyRules
% lensClass .~ const (Just (clsName,funName))
% lensField .~ (`Prelude.lookup` fields)
makeLensesWith :: LensRules -> Name -> Q [Dec]
makeLensesWith cfg nm = do
inf <- reify nm
case inf of
(TyConI decl) -> case deNewtype decl of
(DataD ctx tyConName args cons _) -> case cons of
[NormalC dataConName [( _,ty)]]
| cfg^.handleSingletons -> makeIsoLenses cfg ctx tyConName args dataConName Nothing ty
[RecC dataConName [(fld,_,ty)]]
| cfg^.handleSingletons -> makeIsoLenses cfg ctx tyConName args dataConName (Just fld) ty
_ | cfg^.singletonRequired -> fail "makeLensesWith: A single-constructor single-argument data type is required"
| otherwise -> makeFieldLenses cfg ctx tyConName args cons
_ -> fail "makeLensesWith: Unsupported data type"
_ -> fail "makeLensesWith: Expected the name of a data type or newtype"
where
deNewtype (NewtypeD ctx tyConName args c d) = DataD ctx tyConName args [c] d
deNewtype d = d
freshMap :: Set Name -> Q (Map Name Name)
freshMap ns = Map.fromList <$> for (toList ns) (\ n -> (,) n <$> newName (nameBase n))
makeIsoTo :: Name -> ExpQ
makeIsoTo conName = do
f <- newName "f"
a <- newName "a"
lamE [varP f, conP conName [varP a]] $
appsE [ return (VarE 'fmap)
, conE conName
, varE f `appE` varE a
]
makeIsoFrom :: Name -> ExpQ
makeIsoFrom conName = do
f <- newName "f"
a <- newName "a"
b <- newName "b"
lamE [varP f, varP a] $
appsE [ return (VarE 'fmap)
, lamE [conP conName [varP b]] $ varE b
, varE f `appE` (conE conName `appE` varE a)
]
makeIsoBody :: Name -> Name -> (Name -> ExpQ) -> (Name -> ExpQ) -> DecQ
makeIsoBody lensName conName f g = funD lensName [clause [] (normalB body) []] where
body = appsE [ return (VarE 'isomorphic)
, f conName
, g conName
]
makeLensBody :: Name -> Name -> (Name -> ExpQ) -> (Name -> ExpQ) -> DecQ
makeLensBody lensName conName f _ = funD lensName [clause [] (normalB (f conName)) []]
plain :: TyVarBndr -> TyVarBndr
plain (KindedTV t _) = PlainTV t
plain (PlainTV t) = PlainTV t
appArgs :: Type -> [TyVarBndr] -> Type
appArgs t [] = t
appArgs t (x:xs) = appArgs (AppT t (VarT (x^.name))) xs
apps :: Type -> [Type] -> Type
apps = Prelude.foldl AppT
appsT :: TypeQ -> [TypeQ] -> TypeQ
appsT = Prelude.foldl appT
makeIsoLenses :: LensRules
-> Cxt
-> Name
-> [TyVarBndr]
-> Name
-> Maybe Name
-> Type
-> Q [Dec]
makeIsoLenses cfg ctx tyConName tyArgs0 dataConName maybeFieldName partTy = do
let tyArgs = map plain tyArgs0
m <- freshMap $ setOf typeVars tyArgs
let aty = partTy
bty = substTypeVars m aty
cty = appArgs (ConT tyConName) tyArgs
dty = substTypeVars m cty
quantified = ForallT (tyArgs ++ substTypeVars m tyArgs) (ctx ++ substTypeVars m ctx)
maybeIsoName = mkName <$> view lensIso cfg (nameBase dataConName)
lensOnly = not $ cfg^.singletonIso
isoCon | lensOnly = ConT ''Lens
| otherwise = ConT ''Iso
makeBody | lensOnly = makeLensBody
| otherwise = makeIsoBody
isoDecls <- flip (maybe (return [])) maybeIsoName $ \isoName -> do
let decl = SigD isoName $ quantified $ isoCon `apps`
if cfg^.simpleLenses then [aty,aty,cty,cty] else [aty,bty,cty,dty]
body <- makeBody isoName dataConName makeIsoFrom makeIsoTo
#ifndef INLINING
return $ if cfg^.generateSignatures then [decl, body] else [body]
#else
inlining <- inlinePragma isoName
return $ if cfg^.generateSignatures then [decl, body, inlining] else [body, inlining]
#endif
accessorDecls <- case mkName <$> (maybeFieldName >>= view lensField cfg . nameBase) of
jfn@(Just lensName)
| (jfn /= maybeIsoName) && (isNothing maybeIsoName || cfg^.singletonAndField) -> do
let decl = SigD lensName $ quantified $ isoCon `apps`
if cfg^.simpleLenses then [cty,cty,aty,aty]
else [cty,dty,aty,bty]
body <- makeBody lensName dataConName makeIsoTo makeIsoFrom
#ifndef INLINING
return $ if cfg^.generateSignatures then [decl, body] else [body]
#else
inlining <- inlinePragma lensName
return $ if cfg^.generateSignatures then [decl, body, inlining] else [body, inlining]
#endif
_ -> return []
return $ isoDecls ++ accessorDecls
makeFieldLensBody :: Bool -> Name -> [(Con, [Name])] -> Maybe Name -> Q Dec
makeFieldLensBody isTraversal lensName conList maybeMethodName = case maybeMethodName of
Just methodName -> do
go <- newName "go"
let expr = infixApp (varE methodName) (varE '(Prelude..)) (varE go)
funD lensName [ clause [] (normalB expr) [funD go clauses] ]
Nothing -> funD lensName clauses
where
clauses = map buildClause conList
buildClause (con, fields) = do
f <- newName "_f"
vars <- for (con^..conNamedFields._1) $ \field ->
if field `List.elem` fields
then Left <$> ((,) <$> newName ('_':(nameBase field++"'")) <*> newName ('_':nameBase field))
else Right <$> newName ('_':nameBase field)
let cpats = map (varP . either fst id) vars
cvals = map (varE . either snd id) vars
fpats = map (varP . snd) $ lefts vars
fvals = map (appE (varE f) . varE . fst) $ lefts vars
conName = con^.name
recon = appsE $ conE conName : cvals
expr
| not isTraversal && length fields /= 1
= appE (varE 'error) . litE . stringL
$ show lensName ++ ": expected a single matching field in " ++ show conName ++ ", found " ++ show (length fields)
| List.null fields
= appE (varE 'pure) recon
| otherwise
= let step Nothing r = Just $ infixE (Just $ lamE fpats recon) (varE '(<$>)) (Just r)
step (Just l) r = Just $ infixE (Just l) (varE '(<*>)) (Just r)
in fromJust $ List.foldl step Nothing fvals
clause [varP f, conP conName cpats] (normalB expr) []
makeFieldLenses :: LensRules
-> Cxt
-> Name
-> [TyVarBndr]
-> [Con]
-> Q [Dec]
makeFieldLenses cfg ctx tyConName tyArgs0 cons = do
let tyArgs = map plain tyArgs0
maybeLensClass = do
guard $ tyArgs == []
view lensClass cfg $ nameBase tyConName
maybeClassName = fmap (^._1.to mkName) maybeLensClass
t <- newName "t"
a <- newName "a"
lensFields <- map (\xs -> (fst $ head xs, map snd xs))
. groupBy ((==) `on` fst) . sortBy (comparing fst)
. concat
<$> mapM (getLensFields $ view lensField cfg) cons
let varMultiSet = List.concatMap (toListOf (conFields._2.typeVars)) cons
varSet = Set.fromList $ map (view name) tyArgs
bodies <- for lensFields $ \(lensName, fields) -> do
let fieldTypes = map (view _3) fields
otherVars = varMultiSet List.\\ fieldTypes^..typeVars
(tyArgs', cty) <- unifyTypes tyArgs fieldTypes
m <- freshMap . Set.difference varSet $ Set.fromList otherVars
let aty | isJust maybeClassName = VarT t
| otherwise = appArgs (ConT tyConName) tyArgs'
bty = substTypeVars m aty
dty = substTypeVars m cty
s = setOf folded m
relevantBndr b = s^.contains (b^.name)
relevantCtx = not . Set.null . Set.intersection s . setOf typeVars
tvs = tyArgs' ++ filter relevantBndr (substTypeVars m tyArgs')
ps = ctx ++ filter relevantCtx (substTypeVars m ctx)
qs = case maybeClassName of
Just n | not (cfg^.createClass) -> ClassP n [VarT t] : ps
_ -> ps
tvs' | isJust maybeClassName && not (cfg^.createClass) = PlainTV t : tvs
| otherwise = tvs
fieldMap = fromListWith (++) $ map (\(cn,fn,_) -> (cn, [fn])) fields
conList = map (\c -> (c, Map.findWithDefault [] (view name c) fieldMap)) cons
maybeMethodName = fmap (mkName . view _2) maybeLensClass
isTraversal <- do
let notSingular = filter ((/= 1) . length . snd) conList
showCon (c, fs) = pprint (view name c) ++ " { " ++ concat (intersperse ", " $ map pprint fs) ++ " }"
case (cfg^.buildTraversals, cfg^.partialLenses) of
(True, True) -> fail "Cannot makeLensesWith both of the flags buildTraversals and partialLenses."
(False, True) -> return False
(True, False) | List.null notSingular -> return False
| otherwise -> return True
(False, False) | List.null notSingular -> return False
| otherwise -> fail . unlines $
[ "Cannot use 'makeLensesWith' with constructors that don't map just one field"
, "to a lens, without using either the buildTraversals or partialLenses flags."
, if length conList == 1
then "The following constructor failed this criterion for the " ++ pprint lensName ++ " lens:"
else "The following constructors failed this criterion for the " ++ pprint lensName ++ " lens:"
] ++ map showCon conList
let decl = SigD lensName
. ForallT tvs' qs
. apps (if isTraversal then ConT ''Traversal else ConT ''Lens)
$ if cfg^.simpleLenses then [aty,aty,cty,cty] else [aty,bty,cty,dty]
body <- makeFieldLensBody isTraversal lensName conList maybeMethodName
#ifndef INLINING
return $ if cfg^.generateSignatures then [decl, body] else [body]
#else
inlining <- inlinePragma lensName
return $ if cfg^.generateSignatures then [decl, body, inlining] else [body, inlining]
#endif
let defs = Prelude.concat bodies
case maybeLensClass of
Nothing -> return defs
Just (clsNameString, methodNameString) -> do
let clsName = mkName clsNameString
methodName = mkName methodNameString
Prelude.sequence $
filter (\_ -> cfg^.createClass) [
classD (return []) clsName [PlainTV t] [] (
sigD methodName (appsT (conT ''Lens) [varT t, varT t, conT tyConName, conT tyConName]) :
map return defs)]
++ filter (\_ -> cfg^.createInstance) [
instanceD (return []) (conT clsName `appT` conT tyConName) [
funD methodName [clause [varP a] (normalB (varE a)) []]
#ifdef INLINING
, inlinePragma methodName
#endif
]]
++ filter (\_ -> not $ cfg^.createClass) (map return defs)
getLensFields :: (String -> Maybe String) -> Con -> Q [(Name, (Name, Name, Type))]
getLensFields f (RecC cn fs)
= return . catMaybes
$ map (\(fn,_,t) -> (\ln -> (mkName ln, (cn,fn,t))) <$> f (nameBase fn)) fs
getLensFields _ _
= return []
unifyTypes :: [TyVarBndr] -> [Type] -> Q ([TyVarBndr], Type)
unifyTypes tvs tys = return (tvs, head tys)
#if !(MIN_VERSION_template_haskell(2,7,0))
instance Applicative Q where
pure = return
(<*>) = ap
#endif
#ifdef INLINING
inlinePragma :: Name -> Q Dec
#if MIN_VERSION_template_haskell(2,8,0)
# ifdef OLD_INLINE_PRAGMAS
inlinePragma methodName = pragInlD methodName $ inlineSpecNoPhase Inline False
# else
inlinePragma methodName = pragInlD methodName Inline FunLike AllPhases
# endif
#else
inlinePragma methodName = pragInlD methodName $ inlineSpecNoPhase True False
#endif
#endif