record 0.2.1 → 0.2.2

raw patch · 3 files changed

+128/−60 lines, 3 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• library/Record.hs +6/−6
• library/Record/Types.hs +106/−34
• record.cabal +16/−20

@@ -107,8 +107,8 @@ renderSingleLens :: T.Text -> Exp renderSingleLens =   AppE (VarE 'Types.fieldLens) .-  SigE (ConE 'Types.Field) .-  AppT (ConT ''Types.Field) .+  SigE (VarE 'undefined) .+  AppT (ConT ''Types.FieldName) .   LitT . StrTyLit . T.unpack  renderRecordType :: Parser.RecordType -> Either String Type@@ -209,8 +209,8 @@             (sortWith fst l)       where         proxy n =-          SigE (ConE 'Types.Field) -               (AppT (ConT ''Types.Field) (LitT (StrTyLit (T.unpack n))))+          SigE (VarE 'undefined) +               (AppT (ConT ''Types.FieldName) (LitT (StrTyLit (T.unpack n))))  renderLit :: Parser.Lit -> Lit renderLit =@@ -226,7 +226,7 @@ --  -- E.g., -- --- >(\_ v1 _ v2 -> Record2 v1 v2) :: Types.Field n1 -> v1 -> Types.Field n2 -> v2 -> Record2 n1 v1 n2 v2+-- >(\_ v1 _ v2 -> Record2 v1 v2) :: Types.FieldName n1 -> v1 -> Types.FieldName n2 -> v2 -> Record2 n1 v1 n2 v2 --  -- We can set the name signatures by passing -- proxies with explicit signatures to this lambda.@@ -256,7 +256,7 @@             []         argTypes =           concat $ flip map [1 .. arity] $ \i -> -            AppT (ConT ''Types.Field) (VarT (mkName ("n" <> show i))) :+            AppT (ConT ''Types.FieldName) (VarT (mkName ("n" <> show i))) :             VarT (mkName ("v" <> show i)) :             []         resultType conName =

@@ -1,12 +1,12 @@ {-# LANGUAGE CPP, UndecidableInstances #-} -- |--- The contents of this module may seem a bit overwhelming. +-- 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 +-- since all the functionality you may need is presented -- by the quasiquoters exported in the root module. module Record.Types where @@ -15,6 +15,8 @@ import GHC.TypeLits import Record.Lens (Lens) import Language.Haskell.TH+import Foreign.Storable+import Foreign.Ptr (plusPtr)   -- *@@ -24,28 +26,33 @@ -- | -- 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 :: FieldLens "3" v v' a' a => a -> v--- >trd = view . fieldLens (Field :: Field "3")+--+-- >trd :: Field "3" v v' a' a => a -> v+-- >trd = view . fieldLens (FieldName :: FieldName "3") -- The function above will get you the third item of any tuple, which has it.-class FieldLens (n :: Symbol) a a' v v' | n a -> v, n a' -> v', n a v' -> a', n a' v -> a where+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 :: FieldLens "age" v v' a' a => Lens a a' v v'-  -- >ageLens = fieldLens (Field :: Field "age") -  fieldLens :: Field n -> Lens a a' v v'+  --+  -- >ageLens :: Field "age" v v' a' a => Lens a a' v v'+  -- >ageLens = fieldLens (FieldName :: 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\", +-- Defined for compatibility with \"base-4.6\", -- since @Proxy@ was only defined in \"base-4.7\".-data Field (t :: Symbol) = Field+data FieldName (t :: Symbol)   -- * Record Types@@ -77,6 +84,71 @@       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+    InstanceD context (AppT (ConT (mkName "Storable")) recordType)+              [sizeOfFun, inlineFun "sizeOf", alignmentFun, inlineFun "alignment"+              , peekFun, inlineFun "peek", pokeFun, inlineFun "poke"]+ -- * ------------------------- @@ -100,7 +172,7 @@               [1 .. arity]       record'Type =         foldl (\a i -> AppT (AppT a (VarT (mkName ("n" <> show i))))-                            (VarT (if i == nIndex then selectedV'VarName +                            (VarT (if i == nIndex then selectedV'VarName                                                   else mkName ("v" <> show i))))               (ConT typeName)               [1 .. arity]@@ -121,28 +193,28 @@                   exp =                     foldl AppE (ConE typeName) $                     map VarE $-                    map (\(i, n) -> if i == nIndex then selectedV'VarName +                    map (\(i, n) -> if i == nIndex then selectedV'VarName                                                    else mkName ("v" <> show i)) $                     zip [1 .. arity] indexedVVarNames       in         head $ unsafePerformIO $ runQ $         [d|-          instance FieldLens $(varT selectedNVarName)-                              $(pure recordType)-                              $(pure record'Type)-                              $(varT selectedVVarName)-                              $(varT selectedV'VarName)-                              where+          instance Field $(varT selectedNVarName)+                         $(pure recordType)+                         $(pure record'Type)+                         $(varT selectedVVarName)+                         $(varT selectedV'VarName)+                         where             {-# INLINE fieldLens #-}             fieldLens = const $(pure fieldLensLambda)         |] -        -instance FieldLens "1" (Identity v1) (Identity v1') v1 v1' where++instance Field "1" (Identity v1) (Identity v1') v1 v1' where   fieldLens = const $ \f -> fmap Identity . f . runIdentity  --- Generate FieldLens instances for tuples+-- Generate Field instances for tuples return $ do   arity <- [2 .. 24]   nIndex <- [1 .. arity]@@ -161,7 +233,7 @@               (ConT typeName)               [1 .. arity]       tuple'Type =-        foldl (\a i -> AppT a (VarT (if i == nIndex then selectedV'VarName +        foldl (\a i -> AppT a (VarT (if i == nIndex then selectedV'VarName                                                     else mkName ("v" <> show i))))               (ConT typeName)               [1 .. arity]@@ -182,18 +254,18 @@                   exp =                     foldl AppE (ConE conName) $                     map VarE $-                    map (\(i, n) -> if i == nIndex then selectedV'VarName +                    map (\(i, n) -> if i == nIndex then selectedV'VarName                                                    else mkName ("v" <> show i)) $                     zip [1 .. arity] indexedVVarNames       in         head $ unsafePerformIO $ runQ $         [d|-          instance FieldLens $(pure (LitT (StrTyLit (show nIndex))))-                              $(pure tupleType)-                              $(pure tuple'Type)-                              $(varT selectedVVarName)-                              $(varT selectedV'VarName)-                              where+          instance Field $(pure (LitT (StrTyLit (show nIndex))))+                         $(pure tupleType)+                         $(pure tuple'Type)+                         $(varT selectedVVarName)+                         $(varT selectedV'VarName)+                         where             {-# INLINE fieldLens #-}             fieldLens = const $(pure fieldLensLambda)         |]

@@ -1,7 +1,7 @@ name:   record version:-  0.2.1+  0.2.2 synopsis:   First class records implemented with quasi-quotation description:@@ -50,11 +50,7 @@   default: True   manual: True -flag demo-  description: Build Demo-  default: False - library   hs-source-dirs:     library@@ -100,16 +96,20 @@     Haskell2010   if !flag(doctest)     buildable: False-  else-    build-depends:-      doctest == 0.9.*,-      directory == 1.2.*,-      filepath == 1.3.*,-      base-prelude,-      base+  build-depends:+    doctest == 0.9.*,+    directory == 1.2.*,+    filepath == 1.3.*,+    base-prelude,+    base  -executable demo+-- Well, it's not a benchmark actually, +-- but in Cabal there's no cleaner way to specify an executable, +-- which is not intended for distribution.+benchmark demo+  type: +    exitcode-stdio-1.0   hs-source-dirs:     demo   main-is:@@ -122,10 +122,6 @@     -ddump-splices   default-language:     Haskell2010-  if !flag(demo)-    buildable: False-  else-    build-depends:-      record,-      base-prelude,-      base+  build-depends:+    record,+    base-prelude