#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704
#endif
module Control.Lens.TH
( LensRules(LensRules)
, lensIso
, lensField
, lensClass
, lensFlags
, LensFlag(..)
, simpleLenses, handleSingletons, singletonIso, singletonRequired, createClass, createInstance, classRequired
, makeClassy, makeClassyFor
, makeIso
, makeLenses, makeLensesFor
, makeLensesWith
, lensRules
, classyRules
, isoRules
, defaultRules
) where
import Control.Applicative
import Control.Lens.Fold
import Control.Lens.Getter
import Control.Lens.Iso
import Control.Lens.Setter
import Control.Lens.Type
import Control.Lens.Traversal
import Control.Monad
import Data.Char (toLower)
import Data.Foldable
import Data.List as List
import Data.Map as Map hiding (toList,map,filter)
import Data.Map.Lens
import Data.Maybe (isNothing,isJust)
import Data.Monoid
import Data.Set as Set hiding (toList,map,filter)
import Data.Set.Lens
import Data.Traversable
import Language.Haskell.TH
import Language.Haskell.TH.Lens
data LensFlag
= SimpleLenses
| SingletonAndField
| SingletonIso
| HandleSingletons
| SingletonRequired
| CreateClass
| CreateInstance
| ClassRequired
deriving (Eq,Ord,Show,Read)
simpleLenses :: Simple Lens LensRules Bool
simpleLenses = lensFlags.contains SimpleLenses
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
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]
where
top (c:cs) = Just (toLower c:cs)
top _ = Nothing
field ('_':c:cs) = Just (toLower c:cs)
field _ = Nothing
freshMap :: Set Name -> Q (Map Name Name)
freshMap ns = Map.fromList <$> for (toList ns) (\ n -> (,) n <$> newName (nameBase n))
makeIsoTo :: Name -> ExpQ
makeIsoTo conName = lamE [varP (mkName "f"), conP conName [varP (mkName "a")]] $
appsE [ varE (mkName "fmap")
, conE conName
, varE (mkName "f") `appE` varE (mkName "a")
]
makeIsoFrom :: Name -> ExpQ
makeIsoFrom conName = lamE [varP (mkName "f"), varP (mkName "a")] $
appsE [ varE (mkName "fmap")
, lamE [conP conName [varP (mkName "b")]] $ varE (mkName "b")
, varE (mkName "f") `appE` (conE conName `appE` varE (mkName "a"))
]
makeIsoBody :: Name -> Name -> (Name -> ExpQ) -> (Name -> ExpQ) -> DecQ
makeIsoBody lensName conName f g = funD lensName [clause [] (normalB body) []] where
body = appsE [ varE (mkName "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
inlining <- pragInlD isoName $ inlineSpecNoPhase True False
return [decl, body, inlining]
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
inlining <- pragInlD lensName $ inlineSpecNoPhase True False
return [decl, body, inlining]
_ -> return []
return $ isoDecls ++ accessorDecls
data FieldDesc = FieldDesc
{ _fieldName :: Name
, _fieldType :: Type
, _fieldTypeVarsBoundElsewhere :: Set Name
}
thd :: (a,b,c) -> c
thd (_,_,c) = c
fieldDescs :: Set Name -> [(Name,Strict,Type)] -> [FieldDesc]
fieldDescs acc ((nm,_,ty):rest) =
FieldDesc nm ty (acc `Set.union` setOf typeVars (map thd rest)) :
fieldDescs (acc `Set.union` setOf typeVars ty) rest
fieldDescs _ [] = []
conFieldDescs :: Con -> [FieldDesc]
conFieldDescs (RecC _ fields) = fieldDescs mempty fields
conFieldDescs _ = []
commonFieldDescs :: [Con] -> [FieldDesc]
commonFieldDescs = toList . Prelude.foldr walk mempty where
walk con m = Prelude.foldr step m (conFieldDescs con)
step d@(FieldDesc nm ty bds) m = case m^.at nm of
Just (FieldDesc _ _ bds') -> at nm .~ Just (FieldDesc nm ty (bds `Set.union` bds')) $ m
Nothing -> at nm .~ Just d $ m
errorClause :: Name -> Name -> Name -> ClauseQ
errorClause lensName fieldName conName
= clause [] (normalB (varE (mkName "error") `appE` litE (stringL err))) []
where
err = show lensName ++ ": no matching field "
++ show fieldName ++ " in constructor "
++ show conName
makeFieldLensBody :: Name -> Name -> [Con] -> Maybe Name -> Q Dec
makeFieldLensBody lensName fieldName cons maybeMethodName = case maybeMethodName of
Just methodName -> do
go <- newName "go"
funD lensName [ clause [] (normalB (infixApp (varE methodName) (varE (mkName ".")) (varE go))) [funD go (map clauses cons)]]
Nothing -> funD lensName (map clauses cons)
where
clauses (RecC conName fields) = case List.findIndex (\(n,_,_) -> n == fieldName) fields of
Just i -> do
names <- for fields $ \(n,_,_) -> newName (nameBase n)
f <- newName "f"
x <- newName "y"
clause [varP f, conP conName $ map varP names] (normalB
(appsE [ varE (mkName "fmap")
, lamE [varP x] $ appsE $ conE conName : map varE (element i .~ x $ names)
, varE f `appE` varE (names^.element i)
])) []
Nothing -> errorClause lensName fieldName conName
clauses con = errorClause lensName fieldName (con^.name)
makeFieldLenses :: LensRules
-> Cxt
-> Name
-> [TyVarBndr]
-> [Con]
-> Q [Dec]
makeFieldLenses cfg ctx tyConName tyArgs0 cons = do
let tyArgs = map plain tyArgs0
x <- newName "x"
let maybeLensClass = do
guard $ tyArgs == []
view lensClass cfg (nameBase tyConName)
maybeClassName = fmap (^._1.to mkName) maybeLensClass
aty | isJust maybeClassName = VarT x
| otherwise = appArgs (ConT tyConName) tyArgs
vs = setOf typeVars tyArgs
fieldMap = commonFieldDescs cons
classDecls <- case maybeLensClass of
Nothing -> return []
Just (clsNameString, methodNameString) -> do
let clsName = mkName clsNameString
methodName = mkName methodNameString
t <- newName "t"
a <- newName "a"
Prelude.sequence $
filter (\_ -> cfg^.createClass)
[ classD (return []) clsName [PlainTV t] []
[ sigD methodName $ appsT (return (ConT ''Lens)) [varT t, varT t, conT tyConName, conT tyConName] ]]
++ filter (\_ -> cfg^.createInstance)
[ instanceD (return []) (conT clsName `appT` conT tyConName)
[ funD methodName [clause [varP a] (normalB (varE a)) []]
, pragInlD methodName $ inlineSpecNoPhase True False ]]
bodies <- for (toList fieldMap) $ \ (FieldDesc nm cty bds) ->
case mkName <$> view lensField cfg (nameBase nm) of
Nothing -> return []
Just lensName -> do
m <- freshMap $ Set.difference vs bds
let 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 -> ClassP n [VarT x] : ps
_ -> ps
tvs' | isJust maybeClassName = PlainTV x : tvs
| otherwise = tvs
let decl = SigD lensName $ ForallT tvs' qs $
apps (ConT ''Lens) $
if cfg^.simpleLenses
then [aty,aty,cty,cty]
else [aty,bty,cty,dty]
body <- makeFieldLensBody lensName nm cons $ fmap (mkName . view _2) maybeLensClass
inlining <- pragInlD lensName $ inlineSpecNoPhase True False
return [decl, body, inlining]
return $ classDecls ++ Prelude.concat bodies
makeLensesWith :: LensRules -> Name -> Q [Dec]
makeLensesWith cfg nm = reify nm >>= \inf -> case inf of
TyConI dt -> case dt of
NewtypeD ctx tyConName args (NormalC dataConName [(_,ty)]) _ | cfg^.handleSingletons ->
makeIsoLenses cfg ctx tyConName args dataConName Nothing ty
DataD ctx tyConName args [NormalC dataConName [(_,ty)]] _ | cfg^.handleSingletons ->
makeIsoLenses cfg ctx tyConName args dataConName Nothing ty
NewtypeD ctx tyConName args (RecC dataConName [(fld,_,ty)]) _ | cfg^.handleSingletons ->
makeIsoLenses cfg ctx tyConName args dataConName (Just fld) ty
DataD ctx tyConName args [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"
DataD ctx tyConName args dataCons _ ->
makeFieldLenses cfg ctx tyConName args dataCons
_ -> fail "Unsupported data type"
_ -> fail "Expected the name of a data type or newtype"
makeLenses :: Name -> Q [Dec]
makeLenses = makeLensesWith lensRules
makeIso :: Name -> Q [Dec]
makeIso = makeLensesWith isoRules
isoRules :: LensRules
isoRules
= singletonRequired .~ True
$ singletonAndField .~ True
$ defaultRules
makeClassy :: Name -> Q [Dec]
makeClassy = makeLensesWith classyRules
classyRules :: LensRules
classyRules = lensIso .~ const Nothing
$ handleSingletons .~ False
$ lensClass .~ classy
$ classRequired .~ True
$ defaultRules
classy :: String -> Maybe (String, String)
classy n@(a:as) = Just ("Has" ++ n, toLower a:as)
classy _ = Nothing
makeLensesFor :: [(String, String)] -> Name -> Q [Dec]
makeLensesFor fields = makeLensesWith
$ lensField .~ (`Prelude.lookup` fields)
$ lensRules
lensRules :: LensRules
lensRules
= lensIso .~ const Nothing
$ lensClass .~ const Nothing
$ handleSingletons .~ True
$ defaultRules
makeClassyFor :: String -> String -> [(String, String)] -> Name -> Q [Dec]
makeClassyFor clsName funName fields = makeLensesWith
$ lensClass .~ const (Just (clsName,funName))
$ lensField .~ (`Prelude.lookup` fields)
$ classyRules
#if !(MIN_VERSION_template_haskell(2,7,0))
instance Applicative Q where
pure = return
(<*>) = ap
#endif