{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
#ifdef TRUSTWORTHY
{-# LANGUAGE Trustworthy #-}
#endif
#ifndef MIN_VERSION_base
#define MIN_VERSION_base(x,y,z) 1
#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, makeClassy_
, makeFields
, makePrisms
, makeClassyPrisms
, makeWrapped
, declareLenses, declareLensesFor
, declareClassy, declareClassyFor
, declareFields
, declarePrisms
, declareWrapped
, makeLensesWith
, declareLensesWith
, LensRules
, lensRules
, lensRulesFor
, classyRules
, classyRules_
, defaultFieldRules
, camelCaseFields
, underscoreFields
, abbreviatedFields
, lensField
, FieldNamer
, DefName(..)
, lensClass
, ClassyNamer
, simpleLenses
, createClass
, generateSignatures
, generateUpdateableOptics
, generateLazyPatterns
, underscoreNoPrefixNamer
, lookingupNamer
, mappingNamer
, camelCaseNamer
, underscoreNamer
, abbreviatedNamer
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
#if !(MIN_VERSION_template_haskell(2,7,0))
import Control.Monad (ap)
#endif
import qualified Control.Monad.Trans as Trans
import Control.Monad.Trans.Writer
import Control.Lens.Fold
import Control.Lens.Getter
import Control.Lens.Lens
import Control.Lens.Setter
import Control.Lens.Tuple
import Control.Lens.Traversal
import Control.Lens.Internal.TH
import Control.Lens.Internal.FieldTH
import Control.Lens.Internal.PrismTH
import Control.Lens.Wrapped ()
import Control.Lens.Type ()
import Data.Char (toLower, isUpper)
import Data.Foldable hiding (concat, any)
import Data.List as List
import Data.Map as Map hiding (toList,map,filter)
import Data.Maybe (maybeToList)
import Data.Monoid
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
import Language.Haskell.TH.Syntax
#ifdef HLINT
{-# ANN module "HLint: ignore Eta reduce" #-}
{-# ANN module "HLint: ignore Use fewer imports" #-}
{-# ANN module "HLint: ignore Use foldl" #-}
#endif
simpleLenses :: Lens' LensRules Bool
simpleLenses f r = fmap (\x -> r { _simpleLenses = x}) (f (_simpleLenses r))
generateSignatures :: Lens' LensRules Bool
generateSignatures f r =
fmap (\x -> r { _generateSigs = x}) (f (_generateSigs r))
generateUpdateableOptics :: Lens' LensRules Bool
generateUpdateableOptics f r =
fmap (\x -> r { _allowUpdates = x}) (f (_allowUpdates r))
generateLazyPatterns :: Lens' LensRules Bool
generateLazyPatterns f r =
fmap (\x -> r { _lazyPatterns = x}) (f (_lazyPatterns r))
createClass :: Lens' LensRules Bool
createClass f r =
fmap (\x -> r { _generateClasses = x}) (f (_generateClasses r))
lensField :: Lens' LensRules FieldNamer
lensField f r = fmap (\x -> r { _fieldToDef = x}) (f (_fieldToDef r))
type FieldNamer = Name
-> [Name]
-> Name
-> [DefName]
lensClass :: Lens' LensRules ClassyNamer
lensClass f r = fmap (\x -> r { _classyLenses = x }) (f (_classyLenses r))
type ClassyNamer = Name
-> Maybe (Name, Name)
lensRules :: LensRules
lensRules = LensRules
{ _simpleLenses = False
, _generateSigs = True
, _generateClasses = False
, _allowIsos = True
, _allowUpdates = True
, _lazyPatterns = False
, _classyLenses = const Nothing
, _fieldToDef = underscoreNoPrefixNamer
}
underscoreNoPrefixNamer :: FieldNamer
underscoreNoPrefixNamer _ _ n =
case nameBase n of
'_':x:xs -> [TopName (mkName (toLower x:xs))]
_ -> []
lensRulesFor ::
[(String, String)] ->
LensRules
lensRulesFor fields = lensRules & lensField .~ lookingupNamer fields
lookingupNamer :: [(String,String)] -> FieldNamer
lookingupNamer kvs _ _ field =
[ TopName (mkName v) | (k,v) <- kvs, k == nameBase field]
mappingNamer :: (String -> [String])
-> FieldNamer
mappingNamer mapper _ _ = fmap (TopName . mkName) . mapper . nameBase
classyRules :: LensRules
classyRules = LensRules
{ _simpleLenses = True
, _generateSigs = True
, _generateClasses = True
, _allowIsos = False
, _allowUpdates = True
, _lazyPatterns = False
, _classyLenses = \n ->
case nameBase n of
x:xs -> Just (mkName ("Has" ++ x:xs), mkName (toLower x:xs))
[] -> Nothing
, _fieldToDef = underscoreNoPrefixNamer
}
classyRulesFor
:: (String -> Maybe (String, String)) ->
[(String, String)] ->
LensRules
classyRulesFor classFun fields = classyRules
& lensClass .~ (over (mapped . both) mkName . classFun . nameBase)
& lensField .~ lookingupNamer fields
classyRules_ :: LensRules
classyRules_
= classyRules & lensField .~ \_ _ n -> [TopName (mkName ('_':nameBase n))]
makeLenses :: Name -> DecsQ
makeLenses = makeFieldOptics lensRules
makeClassy :: Name -> DecsQ
makeClassy = makeFieldOptics classyRules
makeClassy_ :: Name -> DecsQ
makeClassy_ = makeFieldOptics classyRules_
makeLensesFor :: [(String, String)] -> Name -> DecsQ
makeLensesFor fields = makeFieldOptics (lensRulesFor fields)
makeClassyFor :: String -> String -> [(String, String)] -> Name -> DecsQ
makeClassyFor clsName funName fields = makeFieldOptics $
classyRulesFor (const (Just (clsName, funName))) fields
makeLensesWith :: LensRules -> Name -> DecsQ
makeLensesWith = makeFieldOptics
declareLenses :: DecsQ -> DecsQ
declareLenses
= declareLensesWith
$ lensRules
& lensField .~ \_ _ n -> [TopName n]
declareLensesFor :: [(String, String)] -> DecsQ -> DecsQ
declareLensesFor fields
= declareLensesWith
$ lensRulesFor fields
& lensField .~ \_ _ n -> [TopName n]
declareClassy :: DecsQ -> DecsQ
declareClassy
= declareLensesWith
$ classyRules
& lensField .~ \_ _ n -> [TopName n]
declareClassyFor ::
[(String, (String, String))] -> [(String, String)] -> DecsQ -> DecsQ
declareClassyFor classes fields
= declareLensesWith
$ classyRulesFor (`Prelude.lookup`classes) fields
& lensField .~ \_ _ n -> [TopName n]
declarePrisms :: DecsQ -> DecsQ
declarePrisms = declareWith $ \dec -> do
emit =<< Trans.lift (makeDecPrisms True dec)
return dec
declareWrapped :: DecsQ -> DecsQ
declareWrapped = declareWith $ \dec -> do
maybeDecs <- Trans.lift (makeWrappedForDec dec)
forM_ maybeDecs emit
return dec
declareFields :: DecsQ -> DecsQ
declareFields = declareLensesWith defaultFieldRules
declareLensesWith :: LensRules -> DecsQ -> DecsQ
declareLensesWith rules = declareWith $ \dec -> do
emit =<< Trans.lift (makeFieldOpticsForDec rules dec)
return $ stripFields dec
deNewtype :: Dec -> Dec
#if MIN_VERSION_template_haskell(2,11,0)
deNewtype (NewtypeD ctx tyName args kind c d) = DataD ctx tyName args kind [c] d
deNewtype (NewtypeInstD ctx tyName args kind c d) = DataInstD ctx tyName args kind [c] d
#else
deNewtype (NewtypeD ctx tyName args c d) = DataD ctx tyName args [c] d
deNewtype (NewtypeInstD ctx tyName args c d) = DataInstD ctx tyName args [c] d
#endif
deNewtype d = d
freshMap :: Set Name -> Q (Map Name Name)
freshMap ns = Map.fromList <$> for (toList ns) (\ n -> (,) n <$> newName (nameBase n))
apps :: Type -> [Type] -> Type
apps = Prelude.foldl AppT
makeDataDecl :: Dec -> Maybe DataDecl
makeDataDecl dec = case deNewtype dec of
DataD ctx tyName args
#if MIN_VERSION_template_haskell(2,11,0)
_
#endif
cons _ -> Just DataDecl
{ dataContext = ctx
, tyConName = Just tyName
, dataParameters = args
, fullType = apps $ ConT tyName
, constructors = cons
}
DataInstD ctx familyName args
#if MIN_VERSION_template_haskell(2,11,0)
_
#endif
cons _ -> Just DataDecl
{ dataContext = ctx
, tyConName = Nothing
, dataParameters = map PlainTV vars
, fullType = \tys -> apps (ConT familyName) $
substType (Map.fromList $ zip vars tys) args
, constructors = cons
}
where
vars = toList $ setOf typeVars args
_ -> Nothing
data DataDecl = DataDecl
{ dataContext :: Cxt
, tyConName :: Maybe Name
, dataParameters :: [TyVarBndr]
, fullType :: [Type] -> Type
, constructors :: [Con]
}
makeWrapped :: Name -> DecsQ
makeWrapped nm = do
inf <- reify nm
case inf of
TyConI decl -> do
maybeDecs <- makeWrappedForDec decl
maybe (fail "makeWrapped: Unsupported data type") return maybeDecs
_ -> fail "makeWrapped: Expected the name of a newtype or datatype"
makeWrappedForDec :: Dec -> Q (Maybe [Dec])
makeWrappedForDec decl = case makeDataDecl decl of
Just dataDecl | [con] <- constructors dataDecl
, [field] <- toListOf (conFields._2) con
-> do wrapped <- makeWrappedInstance dataDecl con field
rewrapped <- makeRewrappedInstance dataDecl
return (Just [rewrapped, wrapped])
_ -> return Nothing
makeRewrappedInstance :: DataDecl -> DecQ
makeRewrappedInstance dataDecl = do
t <- varT <$> newName "t"
let typeArgs = map (view name) (dataParameters dataDecl)
typeArgs' <- do
m <- freshMap (Set.fromList typeArgs)
return (substTypeVars m typeArgs)
let appliedType = return (fullType dataDecl (map VarT typeArgs))
appliedType' = return (fullType dataDecl (map VarT typeArgs'))
#if MIN_VERSION_template_haskell(2,10,0)
eq = AppT. AppT EqualityT <$> appliedType' <*> t
#else
eq = equalP appliedType' t
#endif
klass = conT rewrappedTypeName `appsT` [appliedType, t]
instanceD (cxt [eq]) klass []
makeWrappedInstance :: DataDecl-> Con -> Type -> DecQ
makeWrappedInstance dataDecl con fieldType = do
let conName = view name con
let typeArgs = toListOf typeVars (dataParameters dataDecl)
let appliedType = fullType dataDecl (map VarT typeArgs)
let unwrappedATF = tySynInstD' unwrappedTypeName [return appliedType] (return fieldType)
let klass = conT wrappedTypeName `appT` return appliedType
let wrapFun = conE conName
let unwrapFun = newName "x" >>= \x -> lam1E (conP conName [varP x]) (varE x)
let body = appsE [varE isoValName, unwrapFun, wrapFun]
let isoMethod = funD _wrapped'ValName [clause [] (normalB body) []]
instanceD (cxt []) klass [unwrappedATF, isoMethod]
#if !(MIN_VERSION_template_haskell(2,7,0))
instance Applicative Q where
pure = return
(<*>) = ap
#endif
overHead :: (a -> a) -> [a] -> [a]
overHead _ [] = []
overHead f (x:xs) = f x : xs
underscoreFields :: LensRules
underscoreFields = defaultFieldRules & lensField .~ underscoreNamer
underscoreNamer :: FieldNamer
underscoreNamer _ _ field = maybeToList $ do
_ <- prefix field'
method <- niceLens
cls <- classNaming
return (MethodName (mkName cls) (mkName method))
where
field' = nameBase field
prefix ('_':xs) | '_' `List.elem` xs = Just (takeWhile (/= '_') xs)
prefix _ = Nothing
niceLens = prefix field' <&> \n -> drop (length n + 2) field'
classNaming = niceLens <&> ("Has_" ++)
camelCaseFields :: LensRules
camelCaseFields = defaultFieldRules
camelCaseNamer :: FieldNamer
camelCaseNamer tyName fields field = maybeToList $ do
fieldPart <- stripPrefix expectedPrefix (nameBase field)
method <- computeMethod fieldPart
let cls = "Has" ++ fieldPart
return (MethodName (mkName cls) (mkName method))
where
expectedPrefix = optUnderscore ++ overHead toLower (nameBase tyName)
optUnderscore = ['_' | any (isPrefixOf "_" . nameBase) fields ]
computeMethod (x:xs) | isUpper x = Just (toLower x : xs)
computeMethod _ = Nothing
abbreviatedFields :: LensRules
abbreviatedFields = defaultFieldRules { _fieldToDef = abbreviatedNamer }
abbreviatedNamer :: FieldNamer
abbreviatedNamer _ fields field = maybeToList $ do
fieldPart <- stripMaxLc (nameBase field)
method <- computeMethod fieldPart
let cls = "Has" ++ fieldPart
return (MethodName (mkName cls) (mkName method))
where
stripMaxLc f = do x <- stripPrefix optUnderscore f
case break isUpper x of
(p,s) | List.null p || List.null s -> Nothing
| otherwise -> Just s
optUnderscore = ['_' | any (isPrefixOf "_" . nameBase) fields ]
computeMethod (x:xs) | isUpper x = Just (toLower x : xs)
computeMethod _ = Nothing
makeFields :: Name -> DecsQ
makeFields = makeFieldOptics camelCaseFields
defaultFieldRules :: LensRules
defaultFieldRules = LensRules
{ _simpleLenses = True
, _generateSigs = True
, _generateClasses = True
, _allowIsos = False
, _allowUpdates = True
, _lazyPatterns = False
, _classyLenses = const Nothing
, _fieldToDef = camelCaseNamer
}
declareWith :: (Dec -> Declare Dec) -> DecsQ -> DecsQ
declareWith fun = (runDeclare . traverseDataAndNewtype fun =<<)
type Declare = WriterT (Endo [Dec]) Q
runDeclare :: Declare [Dec] -> DecsQ
runDeclare dec = do
(out, endo) <- runWriterT dec
return $ out ++ appEndo endo []
emit :: [Dec] -> Declare ()
emit decs = tell $ Endo (decs++)
traverseDataAndNewtype :: (Applicative f) => (Dec -> f Dec) -> [Dec] -> f [Dec]
traverseDataAndNewtype f decs = traverse go decs
where
go dec = case dec of
DataD{} -> f dec
NewtypeD{} -> f dec
DataInstD{} -> f dec
NewtypeInstD{} -> f dec
InstanceD ctx inst body -> InstanceD ctx inst <$> traverse go body
_ -> pure dec
stripFields :: Dec -> Dec
stripFields dec = case dec of
#if MIN_VERSION_template_haskell(2,11,0)
DataD ctx tyName tyArgs kind cons derivings ->
DataD ctx tyName tyArgs kind (map deRecord cons) derivings
NewtypeD ctx tyName tyArgs kind con derivings ->
NewtypeD ctx tyName tyArgs kind (deRecord con) derivings
DataInstD ctx tyName tyArgs kind cons derivings ->
DataInstD ctx tyName tyArgs kind (map deRecord cons) derivings
NewtypeInstD ctx tyName tyArgs kind con derivings ->
NewtypeInstD ctx tyName tyArgs kind (deRecord con) derivings
#else
DataD ctx tyName tyArgs cons derivings ->
DataD ctx tyName tyArgs (map deRecord cons) derivings
NewtypeD ctx tyName tyArgs con derivings ->
NewtypeD ctx tyName tyArgs (deRecord con) derivings
DataInstD ctx tyName tyArgs cons derivings ->
DataInstD ctx tyName tyArgs (map deRecord cons) derivings
NewtypeInstD ctx tyName tyArgs con derivings ->
NewtypeInstD ctx tyName tyArgs (deRecord con) derivings
#endif
_ -> dec
deRecord :: Con -> Con
deRecord con@NormalC{} = con
deRecord con@InfixC{} = con
deRecord (ForallC tyVars ctx con) = ForallC tyVars ctx $ deRecord con
deRecord (RecC conName fields) = NormalC conName (map dropFieldName fields)
#if MIN_VERSION_template_haskell(2,11,0)
deRecord con@GadtC{} = con
deRecord (RecGadtC ns fields retTy) = GadtC ns (map dropFieldName fields) retTy
#endif
#if MIN_VERSION_template_haskell(2,11,0)
dropFieldName :: VarBangType -> BangType
#else
dropFieldName :: VarStrictType -> StrictType
#endif
dropFieldName (_, str, typ) = (str, typ)