generic-accessors 0.4.2.0 → 0.5.0.0

raw patch · 4 files changed

+215/−210 lines, 4 filesdep +lensPVP ok

version bump matches the API change (PVP)

Dependencies added: lens

API changes (from Hackage documentation)

Files

• CHANGELOG.md +16/−10
• generic-accessors.cabal +7/−2
• src/Accessors.hs +191/−197
• tests/Tests.hs +1/−1

@@ -1,21 +1,27 @@-0.1+0.5.0.0 ----* Initial release (moved from Plot-ho-matic repo)+* Use lenses intead of hand-rolled Getter/Setters+* add describeField function+* add sameFieldType function -0.2 (broken, do not use)+0.4.1 ----* Add setters-* Make getters support more types than Double+* add version of flatten which returns name as [String] +0.4+---+* Revive convenience show functions+* Ints and Bools are no longer shown as floats+ 0.3 --- * Fix setters -0.4+0.2 (broken, do not use) ----* Revive convenience show functions-* Ints and Bools are no longer shown as floats+* Add setters+* Make getters support more types than Double -0.4.1+0.1 ----* add version of flatten which returns name as [String]+* Initial release (moved from Plot-ho-matic repo)

@@ -1,5 +1,5 @@ name:                generic-accessors-version:             0.4.2.0+version:             0.5.0.0 synopsis:            stringly-named getters for generic data license:             BSD3 license-file:        LICENSE@@ -15,9 +15,13 @@   CHANGELOG.md   README.md description: {-Get a Tree or list of (String, a -> Double) pairs for use in plotting and data inspection+Get a Tree or list of (String, Lens a X) pairs for use in plotting and data inspection } +source-repository head+  type:     git+  location: git://github.com/ghorn/generic-accessors.git+ library   hs-source-dirs:    src   default-language:  Haskell2010@@ -25,6 +29,7 @@   build-depends:     base >= 4.6.0.0 && < 5                      , linear                      , spatial-math >= 0.2.0+                     , lens    ghc-options:      -O2 -Wall   ghc-prof-options: -O2 -Wall -prof -fprof-auto -fprof-cafs -rtsopts

@@ -1,17 +1,18 @@ {-# OPTIONS_GHC -Wall #-}---{-# OPTIONS_GHC -ddump-deriv #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}  module Accessors        ( Lookup(..)        , AccessorTree(..)-       , Setter(..)-       , Getter(..)+       , Field(..)        , accessors+       , describeField+       , sameFieldType        , flatten        , flatten'        , showTree@@ -20,6 +21,7 @@  import GHC.Generics +import Control.Lens ( Lens', (^.) ) import Data.List ( intercalate ) import qualified Linear import GHC.Word@@ -30,7 +32,7 @@ import SpatialMathT ( V3T(..), Rot(..) )  showAccTree :: String -> AccessorTree a -> [String]-showAccTree spaces (ATGetter _) = [spaces ++ "ATGetter {}"]+showAccTree spaces (Field _) = [spaces ++ "Field {}"] showAccTree spaces (Data name trees) =   (spaces ++ "Data " ++ show name) :   concatMap (showChild (spaces ++ "    ")) trees@@ -43,41 +45,51 @@   show = unlines . showAccTree ""  data AccessorTree a = Data (String,String) [(String, AccessorTree a)]-                    | ATGetter (Getter a, Setter a)+                    | Field (Field a) -data Getter a =-  GetBool (a -> Bool)-  | GetDouble (a -> Double)-  | GetFloat (a -> Float)-  | GetInt (a -> Int)-  | GetString (a -> String)-  | GetSorry -- ^ not yet implemented+data Field a =+  FieldBool (Lens' a Bool)+  | FieldDouble (Lens' a Double)+  | FieldFloat (Lens' a Float)+  | FieldInt (Lens' a Int)+  | FieldString (Lens' a String)+  | FieldSorry -- ^ a field which is not yet supported -data Setter a =-  SetBool (Bool -> a -> a)-  | SetDouble (Double -> a -> a)-  | SetFloat (Float -> a -> a)-  | SetInt (Int -> a -> a)-  | SetString (String -> a -> a)-  | SetSorry -- ^ not yet implemented+-- | Return the type of field, such as "Bool", "Double", "String", etc.+describeField :: Field a -> String+describeField (FieldBool _) = "Bool"+describeField (FieldDouble _) = "Double"+describeField (FieldFloat _) = "Float"+describeField (FieldInt _) = "Int"+describeField (FieldString _) = "String"+describeField FieldSorry = "Sorry" -accessors :: Lookup a => a -> AccessorTree a-accessors x = toAccessorTree x id (\new _ -> new)---accessors = flip (flip toAccessorTree id) id+-- | Returns True if the __type__ of fields is the same.+sameFieldType :: Field a -> Field b -> Bool+sameFieldType (FieldBool _) (FieldBool _) = True+sameFieldType (FieldDouble _) (FieldDouble _) = True+sameFieldType (FieldFloat _) (FieldFloat _) = True+sameFieldType (FieldInt _) (FieldInt _) = True+sameFieldType (FieldString _) (FieldString _) = True+sameFieldType FieldSorry FieldSorry = True+sameFieldType _ _ = False +accessors :: Lookup a => AccessorTree a+accessors = toAccessorTree id+ showMsgs :: [String] -> String showMsgs = intercalate "." -flatten :: AccessorTree a -> [(String, Getter a, Setter a)]+flatten :: AccessorTree a -> [(String, Field a)] flatten = map f . flatten'   where-    f (x,y,z) = (showMsgs x, y, z)+    f (x,y) = (showMsgs x, y) -flatten' :: AccessorTree a -> [([String], Getter a, Setter a)]+flatten' :: AccessorTree a -> [([String], Field a)] flatten' = flattenChain []   where-    flattenChain :: [String] -> AccessorTree a -> [([String], Getter a, Setter a)]-    flattenChain msgs (ATGetter (get, set)) = [(reverse msgs, get, set)]+    flattenChain :: [String] -> AccessorTree a -> [([String], Field a)]+    flattenChain msgs (Field lens) = [(reverse msgs, lens)]     flattenChain msgs (Data (_,_) trees) = concatMap f trees       where         f (name,tree) = flattenChain (name:msgs) tree@@ -85,235 +97,218 @@ -- | Things which you can make a tree of labeled getters for. -- You should derive this using GHC.Generics. class Lookup a where-  toAccessorTree :: a -> (b -> a) -> (a -> b -> b) -> AccessorTree b+  toAccessorTree :: Lens' b a -> AccessorTree b -  default toAccessorTree :: (Generic a, GLookup (Rep a)) => a -> (b -> a) -> (a -> b -> b) -> AccessorTree b-  toAccessorTree x get set = gtoAccessorTree (from x) (from . get) (set . to)+  default toAccessorTree :: (Generic a, GLookup (Rep a))+                            => Lens' b a -> AccessorTree b+  toAccessorTree lens0 = gtoAccessorTree (lens0 . repLens)+    where+      repLens :: Lens' a (Rep a p)+      repLens f y = fmap to (f (from y))  class GLookup f where-  gtoAccessorTree :: f a -> (b -> f a) -> (f a -> b -> b) -> AccessorTree b+  gtoAccessorTree :: Lens' b (f a) -> AccessorTree b  class GLookupS f where-  gtoAccessorTreeS :: f a -> (b -> f a) -> (f a -> b -> b) -> [(String, AccessorTree b)]+  gtoAccessorTreeS :: Lens' b (f a)+                      -> [(String, AccessorTree b)] +instance Lookup f => GLookup (Rec0 f) where+  gtoAccessorTree lens0 = toAccessorTree (lens0 . rec0Lens)+    where+      rec0Lens :: Lens' (Rec0 f a) f+      rec0Lens f y = fmap K1 (f (unK1 y))++instance (Selector s, GLookup a) => GLookupS (S1 s a) where+  gtoAccessorTreeS lens0 = [(selname, gtoAccessorTree (lens0 . m1Lens))]+    where+      m1Lens :: Lens' (S1 s f p) (f p)+      m1Lens f y = fmap M1 (f (unM1 y))++      selname = case selName selError of+        "" -> "()"+        y -> y++      selError :: S1 s a p+      selError = error $ "generic-accessors: selName should never access data"+++instance GLookupS U1 where+  gtoAccessorTreeS _ = []++instance (GLookupS f, GLookupS g) => GLookupS (f :*: g) where+  gtoAccessorTreeS lens0 = tf ++ tg+    where+      tf = gtoAccessorTreeS (lens0 . leftLens)+      tg = gtoAccessorTreeS (lens0 . rightLens)++      leftLens ::  Lens' ((f :*: g) a) (f a)+      leftLens  f (x :*: y) = fmap (\x' -> x' :*: y ) (f x)+      rightLens :: Lens' ((f :*: g) a) (g a)+      rightLens f (x :*: y) = fmap (\y' -> x  :*: y') (f y)++instance (Datatype d, Constructor c, GLookupS a)+         => GLookup (D1 d (C1 c a)) where+  gtoAccessorTree lens0 = Data (datatypeName datatypeError, conName conError) con+    where+      conError :: C1 c a p+      conError = error $ "generic-accessors: conName should never access data"++      datatypeError :: D1 d (C1 c a) p+      datatypeError = error $ "generic-accessors: datatypeName should never access data"++      con = gtoAccessorTreeS (lens0 . m1m1Lens)++      m1m1Lens :: Lens' (D1 d (C1 c f) p) (f p)+      m1m1Lens f y = fmap (M1 . M1) (f (unM1 (unM1 y)))+ -- some instance from linear instance Lookup a => Lookup (Linear.V0 a) where-  toAccessorTree _ _ _ =+  toAccessorTree _ =     Data ("V0", "V0") [] instance Lookup a => Lookup (Linear.V1 a) where-  toAccessorTree xyz get set =-    Data ("V1", "V1") [ ("x", toAccessorTree (getX xyz) (getX . get) setX)+  toAccessorTree lens0 =+    Data ("V1", "V1") [ ("x", toAccessorTree (lens0 . Linear._x))                       ]-    where-      getX (Linear.V1 x) = x-      setX x new = set (Linear.V1 x) new+ instance Lookup a => Lookup (Linear.V2 a) where-  toAccessorTree (Linear.V2 x0 y0) get set =-    Data ("V2", "V2") [ ("x", toAccessorTree x0 (getX . get) setX)-                      , ("y", toAccessorTree y0 (getY . get) setY)+  toAccessorTree lens0 =+    Data ("V2", "V2") [ ("x", toAccessorTree (lens0 . Linear._x))+                      , ("y", toAccessorTree (lens0 . Linear._y))                       ]-    where-      getX (Linear.V2 x _) = x-      getY (Linear.V2 _ y) = y -      setX x new = set (Linear.V2 x (getY (get new))) new-      setY y new = set (Linear.V2 (getX (get new)) y) new- instance Lookup a => Lookup (Linear.V3 a) where-  toAccessorTree (Linear.V3 x0 y0 z0) get set =-    Data ("V3", "V3") [ ("x", toAccessorTree x0 (getX . get) setX)-                      , ("y", toAccessorTree y0 (getY . get) setY)-                      , ("z", toAccessorTree z0 (getZ . get) setZ)+  toAccessorTree lens0 =+    Data ("V3", "V3") [ ("x", toAccessorTree (lens0 . Linear._x))+                      , ("y", toAccessorTree (lens0 . Linear._y))+                      , ("z", toAccessorTree (lens0 . Linear._z))                       ]-    where-      getX (Linear.V3 x _ _) = x-      getY (Linear.V3 _ y _) = y-      getZ (Linear.V3 _ _ z) = z-      setX x new = set (Linear.V3 x y z) new-        where-          Linear.V3 _ y z = get new-      setY y new = set (Linear.V3 x y z) new-        where-          Linear.V3 x _ z = get new-      setZ z new = set (Linear.V3 x y z) new-        where-          Linear.V3 x y _ = get new instance Lookup a => Lookup (Linear.V4 a) where-  toAccessorTree (Linear.V4 x0 y0 z0 w0) get set =-    Data ("V4", "V4") [ ("x", toAccessorTree x0 (getX . get) setX)-                      , ("y", toAccessorTree y0 (getY . get) setY)-                      , ("z", toAccessorTree z0 (getZ . get) setZ)-                      , ("w", toAccessorTree w0 (getW . get) setW)+  toAccessorTree lens0 =+    Data ("V4", "V4") [ ("x", toAccessorTree (lens0 . Linear._x))+                      , ("y", toAccessorTree (lens0 . Linear._y))+                      , ("z", toAccessorTree (lens0 . Linear._z))+                      , ("w", toAccessorTree (lens0 . Linear._w))                       ]-    where-      getX (Linear.V4 x _ _ _) = x-      getY (Linear.V4 _ y _ _) = y-      getZ (Linear.V4 _ _ z _) = z-      getW (Linear.V4 _ _ _ w) = w-      setX x new = set (Linear.V4 x y z w) new-        where-          Linear.V4 _ y z w = get new-      setY y new = set (Linear.V4 x y z w) new-        where-          Linear.V4 x _ z w = get new-      setZ z new = set (Linear.V4 x y z w) new-        where-          Linear.V4 x y _ w = get new-      setW w new = set (Linear.V4 x y z w) new-        where-          Linear.V4 x y z _ = get new instance Lookup a => Lookup (Linear.Quaternion a) where-  toAccessorTree (Linear.Quaternion q0 (Linear.V3 x0 y0 z0)) get set =+  toAccessorTree lens0 =     Data ("Quaternion", "Quaternion")-    [ ("q0", toAccessorTree q0 (getQ0 . get) setQ0)-    , ("q1", toAccessorTree x0 (getQ1 . get) setQ1)-    , ("q2", toAccessorTree y0 (getQ2 . get) setQ2)-    , ("q3", toAccessorTree z0 (getQ3 . get) setQ3)+    [ ("q0", toAccessorTree (lens0 . Linear._e))+    , ("q1", toAccessorTree (lens0 . Linear._i))+    , ("q2", toAccessorTree (lens0 . Linear._j))+    , ("q3", toAccessorTree (lens0 . Linear._k))     ]-    where-      getQ0 (Linear.Quaternion q _) = q-      getQ1 (Linear.Quaternion _ (Linear.V3 x _ _)) = x-      getQ2 (Linear.Quaternion _ (Linear.V3 _ y _)) = y-      getQ3 (Linear.Quaternion _ (Linear.V3 _ _ z)) = z -      setQ0 q new = set (Linear.Quaternion q (Linear.V3 x y z)) new-        where-          Linear.Quaternion _ (Linear.V3 x y z) = get new-      setQ1 x new = set (Linear.Quaternion q (Linear.V3 x y z)) new-        where-          Linear.Quaternion q (Linear.V3 _ y z) = get new-      setQ2 y new = set (Linear.Quaternion q (Linear.V3 x y z)) new-        where-          Linear.Quaternion q (Linear.V3 x _ z) = get new-      setQ3 z new = set (Linear.Quaternion q (Linear.V3 x y z)) new-        where-          Linear.Quaternion q (Linear.V3 x y _) = get new---instance Lookup f => GLookup (Rec0 f) where-  gtoAccessorTree x get set = toAccessorTree (unK1 x) (unK1 . get) (set . K1)--instance (Selector s, GLookup a) => GLookupS (S1 s a) where-  gtoAccessorTreeS x get set = [(selname, gtoAccessorTree (unM1 x) (unM1 . get) (set . M1))]-    where-      selname = case selName x of-        [] -> "()"-        y -> y--instance GLookupS U1 where-  gtoAccessorTreeS _ _ _ = []--instance (GLookupS f, GLookupS g) => GLookupS (f :*: g) where-  gtoAccessorTreeS (x0 :*: y0) get set = tf ++ tg-    where-      tf = gtoAccessorTreeS x0 (getLeft  . get) setLeft-      tg = gtoAccessorTreeS y0 (getRight . get) setRight--      getLeft  (x :*: _) = x-      getRight (_ :*: y) = y--      setLeft  x new = set (x :*: getRight (get new)) new-      setRight y new = set (getLeft (get new) :*: y) new--instance (Datatype d, Constructor c, GLookupS a) => GLookup (D1 d (C1 c a)) where-  gtoAccessorTree d@(M1 c) get set = Data (datatypeName d, conName c) con-    where-      con = gtoAccessorTreeS (unM1 c) (unM1 . unM1 . get) (set . M1 . M1)- -- basic types instance Lookup () where -- hack to get dummy tree-  toAccessorTree _ _ _ = ATGetter (GetSorry, SetSorry)+  toAccessorTree _ = Field FieldSorry instance Lookup Int where-  toAccessorTree _ get set = ATGetter (GetInt get, SetInt set)+  toAccessorTree lens = Field (FieldInt lens) instance Lookup Float where-  toAccessorTree _ get set = ATGetter (GetFloat get, SetFloat set)+  toAccessorTree lens = Field (FieldFloat lens) instance Lookup Double where-  toAccessorTree _ get set = ATGetter (GetDouble get, SetDouble set)+  toAccessorTree lens = Field (FieldDouble lens) instance Lookup Bool where-  toAccessorTree _ get set = ATGetter (GetBool get, SetBool set)+  toAccessorTree lens = Field (FieldBool lens) instance Lookup String where-  toAccessorTree _ get set = ATGetter (GetString get, SetString set)+  toAccessorTree lens = Field (FieldString lens)  -- Word types instance Lookup Word where-  toAccessorTree _ get _ = ATGetter (GetDouble (realToFrac . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens)) instance Lookup Word8 where-  toAccessorTree _ get _ = ATGetter (GetDouble (realToFrac . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens)) instance Lookup Word16 where-  toAccessorTree _ get _ = ATGetter (GetDouble (realToFrac . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens)) instance Lookup Word32 where-  toAccessorTree _ get _ = ATGetter (GetDouble (realToFrac . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens)) instance Lookup Word64 where-  toAccessorTree _ get _ = ATGetter (GetDouble (realToFrac . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens))  -- Int types instance Lookup Int8 where-  toAccessorTree _ get _ = ATGetter (GetInt (fromIntegral . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens)) instance Lookup Int16 where-  toAccessorTree _ get _ = ATGetter (GetInt (fromIntegral . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens)) instance Lookup Int32 where-  toAccessorTree _ get _ = ATGetter (GetInt (fromIntegral . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens)) instance Lookup Int64 where-  toAccessorTree _ get _ = ATGetter (GetInt (fromIntegral . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens)) --- todo(greg): some of these getters can fit in ints -- C types+-- todo(greg): some of these have inappropriate fields instance Lookup CChar where-  toAccessorTree _ get _set = ATGetter (GetDouble (realToFrac . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens)) instance Lookup CSChar where-  toAccessorTree _ get _set = ATGetter (GetDouble (realToFrac . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens)) instance Lookup CUChar where-  toAccessorTree _ get _set = ATGetter (GetDouble (realToFrac . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens)) instance Lookup CShort where-  toAccessorTree _ get _set = ATGetter (GetDouble (realToFrac . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens)) instance Lookup CUShort where-  toAccessorTree _ get _set = ATGetter (GetDouble (realToFrac . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens)) instance Lookup CInt where-  toAccessorTree _ get _set = ATGetter (GetDouble (realToFrac . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens)) instance Lookup CUInt where-  toAccessorTree _ get _set = ATGetter (GetDouble (realToFrac . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens)) instance Lookup CLong where-  toAccessorTree _ get _set = ATGetter (GetDouble (realToFrac . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens)) instance Lookup CULong where-  toAccessorTree _ get _set = ATGetter (GetDouble (realToFrac . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens)) instance Lookup CPtrdiff where-  toAccessorTree _ get _set = ATGetter (GetDouble (realToFrac . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens)) instance Lookup CSize where-  toAccessorTree _ get _set = ATGetter (GetDouble (realToFrac . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens)) instance Lookup CWchar where-  toAccessorTree _ get _set = ATGetter (GetDouble (realToFrac . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens)) instance Lookup CSigAtomic where-  toAccessorTree _ get _set = ATGetter (GetDouble (realToFrac . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens)) instance Lookup CLLong where-  toAccessorTree _ get _set = ATGetter (GetDouble (realToFrac . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens)) instance Lookup CULLong where-  toAccessorTree _ get _set = ATGetter (GetDouble (realToFrac . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens)) instance Lookup CIntPtr where-  toAccessorTree _ get _set = ATGetter (GetDouble (realToFrac . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens)) instance Lookup CUIntPtr where-  toAccessorTree _ get _set = ATGetter (GetDouble (realToFrac . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens)) instance Lookup CIntMax where-  toAccessorTree _ get _set = ATGetter (GetDouble (realToFrac . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens)) instance Lookup CUIntMax where-  toAccessorTree _ get _set = ATGetter (GetDouble (realToFrac . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens)) instance Lookup CClock where-  toAccessorTree _ get _set = ATGetter (GetDouble (realToFrac . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . clockLens))+    where+      clockLens f (CClock x) = fmap (CClock . fromIntegral) (f (fromIntegral x)) instance Lookup CTime where-  toAccessorTree _ get _set = ATGetter (GetDouble (realToFrac . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . timeLens))+    where+      timeLens f (CTime x) = fmap (CTime . fromIntegral) (f (fromIntegral x)) instance Lookup CUSeconds where-  toAccessorTree _ get _set = ATGetter (GetDouble (realToFrac . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . usecondsLens))+    where+      usecondsLens f (CUSeconds x) = fmap (CUSeconds . fromIntegral) (f (fromIntegral x)) instance Lookup CSUSeconds where-  toAccessorTree _ get _set = ATGetter (GetDouble (realToFrac . get), SetSorry)+  toAccessorTree lens0 = Field (FieldInt (lens0 . susecondsLens))+    where+      susecondsLens f (CSUSeconds x) = fmap (CSUSeconds . fromIntegral) (f (fromIntegral x)) instance Lookup CFloat where-  toAccessorTree _ get set = ATGetter (GetFloat (realToFrac . get), SetFloat (set . realToFrac))+  toAccessorTree lens0 = Field (FieldDouble (lens0 . realFracLens)) instance Lookup CDouble where-  toAccessorTree _ get set = ATGetter (GetDouble (realToFrac . get), SetDouble (set . realToFrac))+  toAccessorTree lens0 = Field (FieldDouble (lens0 . realFracLens)) +{-# INLINE integralLens #-}+integralLens :: Integral a => Lens' a Int+integralLens f x = fmap fromIntegral (f (fromIntegral x))++{-# INLINE realFracLens #-}+realFracLens :: (Fractional a, Real a) => Lens' a Double+realFracLens f x = fmap realToFrac (f (realToFrac x))+ -- other types instance Lookup a => Lookup (Rot f1 f2 a) where-  toAccessorTree x get set = toAccessorTree (unR x) (unR . get) (set . Rot)+  toAccessorTree lens0 = toAccessorTree (lens0 . (\f x -> fmap Rot (f (unR x)))) instance Lookup a => Lookup (V3T f a) where-  toAccessorTree x get set = toAccessorTree (unV x) (unV . get) (set . V3T)+  toAccessorTree lens0 = toAccessorTree (lens0 . (\f x -> fmap V3T (f (unV x)))) instance Lookup a => Lookup (Euler a)  showAccTrees :: (Double -> String) -> a -> [(String, AccessorTree a)] -> String -> [String]@@ -321,17 +316,17 @@   where     cs = zipWith (showRecordField show' x spaces) trees ("{ " : repeat ", ") -showVal :: Getter a -> (Double -> String) -> a -> String-showVal (GetBool get) _ x = show (get x)-showVal (GetInt get) _ x = show (get x)-showVal (GetDouble get) show' x = show' (get x)-showVal (GetFloat get) show' x = show' (realToFrac (get x))-showVal (GetString get) _ x = get x-showVal GetSorry _ _ = ""+showVal :: Field a -> (Double -> String) -> a -> String+showVal (FieldBool lens) _ x = show (x ^. lens)+showVal (FieldInt lens) _ x = show (x ^. lens)+showVal (FieldDouble lens) show' x = show' (x ^. lens)+showVal (FieldFloat lens) show' x = show' (realToFrac (x ^. lens))+showVal (FieldString lens) _ x = x ^. lens+showVal FieldSorry _ _ = ""  showRecordField :: (Double -> String) -> a -> String -> (String, AccessorTree a) -> String -> [String]-showRecordField show' x spaces (getterName, ATGetter (get, _)) prefix =-  [spaces ++ prefix ++ getterName ++ " = " ++ showVal get show' x]+showRecordField show' x spaces (getterName, (Field field)) prefix =+  [spaces ++ prefix ++ getterName ++ " = " ++ showVal field show' x] showRecordField show' x spaces (getterName, Data (_,cons) trees) prefix =   (spaces ++ prefixNameEq ++ cons) : showAccTrees show' x trees newSpaces   where@@ -346,7 +341,7 @@ -- | Show a tree of values showTree :: AccessorTree a -> (Double -> String) -> a -> String showTree (Data (_,cons) trees) show' x = initUnlines $ cons : showAccTrees show' x trees ""-showTree (ATGetter (get,_)) show' x = showVal get show' x+showTree (Field field) show' x = showVal field show' x  -- | Show a list of values -- .@@ -354,14 +349,13 @@ showFlat :: forall a . AccessorTree a -> Bool -> (Double -> String) -> a -> String showFlat at align show' x = initUnlines $ map f fl   where-    fst3 (z,_,_) = z-    n = maximum (map (length . fst3) fl)+    n = maximum (map (length . fst) fl) -    f (name, get, _) = name ++ spaces ++ " = " ++ showVal get show' x+    f (name, lens) = name ++ spaces ++ " = " ++ showVal lens show' x       where         spaces           | align = replicate (n - length name) ' '           | otherwise = "" -    fl :: [(String, Getter a, Setter a)]+    fl :: [(String, Field a)]     fl = flatten at

@@ -55,7 +55,7 @@ foo = MkFoo 2 (Xyz 6 7 8 9) True False yo (MkOne 17)  yup :: AccessorTree Foo-yup = accessors foo+yup = accessors   accessorTests :: Test