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)
class Field (n :: Symbol) a a' v v' | n a -> v, n a' -> v', n a v' -> a', n a' v -> a where
fieldLens :: FieldName n -> Lens a a' v v'
type Field' n a v =
Field n a a v v
data FieldName (t :: Symbol)
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 $ (,) (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
DataD [] typeName varBndrs [NormalC typeName conTypes] derivingNames
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)
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
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)) []]
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])) [])]
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
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
fieldLens = const $(pure fieldLensLambda)
|]
instance Field "1" (Identity v1) (Identity v1') v1 v1' where
fieldLens = const $ \f -> fmap Identity . f . runIdentity
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
fieldLens = const $(pure fieldLensLambda)
|]