#ifdef 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_
, makePrisms
, makeClassyPrisms
, makeWrapped
, makeFields
, declareLenses, declareLensesFor
, declareClassy, declareClassyFor
, declarePrisms
, declareWrapped
, declareFields
, makeLensesWith
, declareLensesWith
, defaultFieldRules
, camelCaseFields
, underscoreFields
, abbreviatedFields
, LensRules
, DefName(..)
, lensRules
, lensRulesFor
, classyRules
, classyRules_
, lensField
, lensClass
, simpleLenses
, createClass
, generateSignatures
, generateUpdateableOptics
, generateLazyPatterns
) 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 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
#ifdef HLINT
#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 (Name -> [Name] -> Name -> [DefName])
lensField f r = fmap (\x -> r { _fieldToDef = x}) (f (_fieldToDef r))
lensClass :: Lens' LensRules (Name -> Maybe (Name, Name))
lensClass f r = fmap (\x -> r { _classyLenses = x }) (f (_classyLenses r))
lensRules :: LensRules
lensRules = LensRules
{ _simpleLenses = False
, _generateSigs = True
, _generateClasses = False
, _allowIsos = True
, _allowUpdates = True
, _lazyPatterns = False
, _classyLenses = const Nothing
, _fieldToDef = \_ _ n ->
case nameBase n of
'_':x:xs -> [TopName (mkName (toLower x:xs))]
_ -> []
}
lensRulesFor ::
[(String, String)] ->
LensRules
lensRulesFor fields = lensRules & lensField .~ mkNameLookup fields
mkNameLookup :: [(String,String)] -> Name -> [Name] -> Name -> [DefName]
mkNameLookup kvs _ _ field =
[ TopName (mkName v) | (k,v) <- kvs, k == nameBase field]
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 = \_ _ n ->
case nameBase n of
'_':x:xs -> [TopName (mkName (toLower x:xs))]
_ -> []
}
classyRulesFor
:: (String -> Maybe (String, String)) ->
[(String, String)] ->
LensRules
classyRulesFor classFun fields = classyRules
& lensClass .~ (over (mapped . both) mkName . classFun . nameBase)
& lensField .~ mkNameLookup 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
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
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 cons _ -> Just DataDecl
{ dataContext = ctx
, tyConName = Just tyName
, dataParameters = args
, fullType = apps $ ConT tyName
, constructors = cons
}
DataInstD ctx familyName args 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 :: Name -> [Name] -> Name -> [DefName]
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 :: Name -> [Name] -> Name -> [DefName]
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 :: Name -> [Name] -> Name -> [DefName]
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
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
_ -> 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)
where dropFieldName (_, str, typ) = (str, typ)