{-# LANGUAGE CPP, UndecidableInstances #-} -- | -- The contents of this module may seem a bit overwhelming. -- Don't worry, -- all it does is just cover instances and datatypes of records and tuples of -- huge arities. -- -- You don't actually need to ever use this module, -- since all the functionality you may need is presented -- by the quasiquoters exported in the root module. module Record.Types where import BasePrelude hiding (Proxy) import Data.Functor.Identity import GHC.TypeLits import Record.Lens (Lens) import Language.Haskell.TH import Foreign.Storable import Foreign.Ptr (plusPtr) import qualified TemplateHaskell.Compat.V0208 as A -- * ------------------------- -- | -- Defines a lens to manipulate some value of a type by a type-level name, -- using the string type literal functionality. -- -- Instances are provided for all records and for tuples of arity of up to 24. -- -- Here's how you can use it with tuples: -- -- >trd :: Field "3" v v' a' a => a -> v -- >trd = view . fieldLens (undefined :: FieldName "3") -- The function above will get you the third item of any tuple, which has it. class Field (n :: Symbol) a a' v v' | n a -> v, n a' -> v', n a v' -> a', n a' v -> a where -- | -- A polymorphic lens. E.g.: -- -- >ageLens :: Field "age" v v' a' a => Lens a a' v v' -- >ageLens = fieldLens (undefined :: FieldName "age") fieldLens :: FieldName n -> Lens a a' v v' -- | -- A simplified field constraint, -- which excludes the possibility of type-changing updates. type Field' n a v = Field n a a v v -- | -- A specialised version of "Data.Proxy.Proxy". -- Defined for compatibility with \"base-4.6\", -- since @Proxy@ was only defined in \"base-4.7\". data FieldName (t :: Symbol) -- * Record Types ------------------------- -- Generate Record types return $ flip map [1 .. 24] $ \arity -> let typeName = mkName $ "Record" <> show arity varBndrs = do i <- [1 .. arity] let n = KindedTV (mkName ("n" <> show i)) (ConT ''Symbol) v = PlainTV (mkName ("v" <> show i)) in [n, v] conTypes = do i <- [1 .. arity] return $ (,) (A.notStrict) (VarT (mkName ("v" <> show i))) derivingNames = #if MIN_VERSION_base(4,7,0) [''Show, ''Eq, ''Ord, ''Typeable, ''Generic] #else [''Show, ''Eq, ''Ord, ''Generic] #endif in A.dataD [] typeName varBndrs [NormalC typeName conTypes] derivingNames -- Generate instances of Foreign.Storable return $ flip map [1 .. 24] $ \arity -> let typeName = mkName $ "Record" <> show arity recordType = foldl (\a i -> AppT (AppT a (VarT (mkName ("n" <> show i)))) (VarT (mkName ("v" <> show i)))) (ConT typeName) [1 .. arity] #if MIN_VERSION_template_haskell(2,10,0) -- In TH with `ConstraintKinds` the context is just simply a type context = map (\i -> AppT (ConT (mkName "Storable")) (VarT (mkName ("v" <> show i)))) [1 .. arity] #else context = map (\i -> ClassP (mkName "Storable") [VarT (mkName ("v" <> show i))]) [1 .. arity] #endif nameE = VarE . mkName -- The sum of the sizes of all types sizeOfFun' n = foldr (\a b -> AppE (AppE (nameE "+") a) b) (LitE (IntegerL 0)) $ map (\i -> AppE (nameE "sizeOf") (SigE (nameE "undefined") (VarT (mkName ("v" <> show i))))) [1..n] sizeOfFun = FunD (mkName "sizeOf") [Clause [WildP] (NormalB (sizeOfFun' arity)) []] -- Set the alignment to the maximum alignment of the types alignmentFun = FunD (mkName "alignment") [(Clause [WildP] (NormalB (AppE (nameE "maximum") $ ListE $ map (\i -> AppE (nameE "sizeOf") (SigE (nameE "undefined") (VarT (mkName ("v" <> show i))))) [1..arity])) [])] -- Peek every variable, remember to add the size of the elements already seen to the ptr peekFun = FunD (mkName "peek") [(Clause [VarP (mkName "ptr")] (NormalB (DoE $ map (\i -> BindS (BangP (VarP (mkName ("x" <> show i)))) (AppE (nameE "peek") (AppE (AppE (nameE "plusPtr") (nameE "ptr")) (sizeOfFun' (i - 1))))) [1..arity] ++ [NoBindS (AppE (nameE "return") (foldl (\a i -> AppE a (nameE ("x" <> show i))) (ConE typeName) [1 .. arity]))])) [])] typePattern = ConP typeName (map (\i -> VarP (mkName ("v" <> show i))) [1..arity]) pokeFun = FunD (mkName "poke") [(Clause [VarP (mkName "ptr"), typePattern] (NormalB (DoE $ map (\i -> NoBindS (AppE (AppE (VarE (mkName "poke")) (AppE (AppE (nameE "plusPtr") (nameE "ptr")) (sizeOfFun' (i - 1)))) (nameE ("v" <> show i)))) [1..arity])) [])] inlineFun name = PragmaD $ InlineP (mkName name) Inline FunLike AllPhases in A.instanceD context (AppT (ConT (mkName "Storable")) recordType) [sizeOfFun, inlineFun "sizeOf", alignmentFun, inlineFun "alignment" , peekFun, inlineFun "peek", pokeFun, inlineFun "poke"] -- * ------------------------- return $ do arity <- [1 .. 24] nIndex <- [1 .. arity] return $ let typeName = mkName $ "Record" <> show arity selectedNVarName = mkName $ "n" <> show nIndex selectedVVarName = mkName $ "v" <> show nIndex selectedV'VarName = mkName $ "v" <> show nIndex <> "'" recordType = foldl (\a i -> AppT (AppT a (VarT (mkName ("n" <> show i)))) (VarT (mkName ("v" <> show i)))) (ConT typeName) [1 .. arity] record'Type = foldl (\a i -> AppT (AppT a (VarT (mkName ("n" <> show i)))) (VarT (if i == nIndex then selectedV'VarName else mkName ("v" <> show i)))) (ConT typeName) [1 .. arity] fieldLensLambda = LamE [VarP fVarName, ConP typeName (fmap VarP indexedVVarNames)] exp where fVarName = mkName "f" indexedVVarNames = fmap (\i -> mkName ("v" <> show i)) [1..arity] exp = AppE (AppE (VarE 'fmap) (consLambda)) (AppE (VarE fVarName) (VarE selectedVVarName)) where consLambda = LamE [VarP selectedV'VarName] exp where exp = foldl AppE (ConE typeName) $ map VarE $ map (\(i, n) -> if i == nIndex then selectedV'VarName else mkName ("v" <> show i)) $ zip [1 .. arity] indexedVVarNames in head $ unsafePerformIO $ runQ $ [d| instance Field $(varT selectedNVarName) $(pure recordType) $(pure record'Type) $(varT selectedVVarName) $(varT selectedV'VarName) where {-# INLINE fieldLens #-} fieldLens = const $(pure fieldLensLambda) |] instance Field "1" (Identity v1) (Identity v1') v1 v1' where fieldLens = const $ \f -> fmap Identity . f . runIdentity -- Generate Field instances for tuples return $ do arity <- [2 .. 24] nIndex <- [1 .. arity] return $ let typeName = tupleTypeName arity conName = tupleDataName arity selectedVVarName = mkName $ "v" <> show nIndex selectedV'VarName = mkName $ "v" <> show nIndex <> "'" tupleType = foldl (\a i -> AppT a (VarT (mkName ("v" <> show i)))) (ConT typeName) [1 .. arity] tuple'Type = foldl (\a i -> AppT a (VarT (if i == nIndex then selectedV'VarName else mkName ("v" <> show i)))) (ConT typeName) [1 .. arity] fieldLensLambda = LamE [VarP fVarName, ConP conName (fmap VarP indexedVVarNames)] exp where fVarName = mkName "f" indexedVVarNames = fmap (\i -> mkName ("v" <> show i)) [1..arity] exp = AppE (AppE (VarE 'fmap) (consLambda)) (AppE (VarE fVarName) (VarE selectedVVarName)) where consLambda = LamE [VarP selectedV'VarName] exp where exp = foldl AppE (ConE conName) $ map VarE $ map (\(i, n) -> if i == nIndex then selectedV'VarName else mkName ("v" <> show i)) $ zip [1 .. arity] indexedVVarNames in head $ unsafePerformIO $ runQ $ [d| instance Field $(pure (LitT (StrTyLit (show nIndex)))) $(pure tupleType) $(pure tuple'Type) $(varT selectedVVarName) $(varT selectedV'VarName) where {-# INLINE fieldLens #-} fieldLens = const $(pure fieldLensLambda) |]