generic-accessors 0.5.1.0 → 0.6.0.0

raw patch · 7 files changed

+999/−420 lines, 7 filesdep +binarydep +cerealPVP ok

version bump matches the API change (PVP)

Dependencies added: binary, cereal

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• generic-accessors.cabal +7/−2
• src/Accessors.hs +9/−397
• src/Accessors/Accessors.hs +385/−0
• src/Accessors/Dynamic.hs +221/−0
• src/Accessors/Instances.hs +219/−0
• tests/Tests.hs +152/−21

@@ -1,3 +1,9 @@+0.6.0.0+---+* Split Datatype/Constructor/Field more cleanly.+* Add support for Enums with no fields.+* Add a dynamic representation for dynamic updating.+ 0.5.1.0 --- * Add tuple instances

@@ -1,5 +1,5 @@ name:                generic-accessors-version:             0.5.1.0+version:             0.6.0.0 synopsis:            stringly-named getters for generic data license:             BSD3 license-file:        LICENSE@@ -25,11 +25,16 @@ library   hs-source-dirs:    src   default-language:  Haskell2010-  exposed-modules:   Accessors+  exposed-modules:   Accessors,+                     Accessors.Dynamic+  other-modules:     Accessors.Accessors,+                     Accessors.Instances   build-depends:     base >= 4.6.0.0 && < 5                      , linear                      , spatial-math >= 0.2.0                      , lens+                     , cereal+                     , binary    ghc-options:      -O2 -Wall   ghc-prof-options: -O2 -Wall -prof -fprof-auto -fprof-cafs -rtsopts

@@ -1,17 +1,15 @@ {-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}  module Accessors        ( Lookup(..)-       , AccessorTree(..)-       , Field(..)+       , AccessorTree+       , GAData(..)+       , GAConstructor(..)+       , GASimpleEnum(..)+       , GAField(..)+       , GATip(..)        , accessors-       , describeField+       , describeGAField        , sameFieldType        , flatten        , flatten'@@ -19,391 +17,5 @@        , showFlat        ) where -import GHC.Generics--import Control.Lens ( Lens', (^.) )-import Data.List ( intercalate )-import qualified Linear-import GHC.Word-import Data.Int-import Foreign.C.Types--import SpatialMath ( Euler )-import SpatialMathT ( V3T(..), Rot(..) )--showAccTree :: String -> AccessorTree a -> [String]-showAccTree spaces (Field _) = [spaces ++ "Field {}"]-showAccTree spaces (Data name trees) =-  (spaces ++ "Data " ++ show name) :-  concatMap (showChild (spaces ++ "    ")) trees--showChild :: String -> (String, AccessorTree a) -> [String]-showChild spaces (name, tree) =-  (spaces ++ name) : showAccTree (spaces ++ "    ") tree--instance Show (AccessorTree a) where-  show = unlines . showAccTree ""--data AccessorTree a = Data (String,String) [(String, AccessorTree a)]-                    | Field (Field a)--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---- | 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"---- | 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, Field a)]-flatten = map f . flatten'-  where-    f (x,y) = (showMsgs x, y)--flatten' :: AccessorTree a -> [([String], Field a)]-flatten' = flattenChain []-  where-    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---- | Things which you can make a tree of labeled getters for.--- You should derive this using GHC.Generics.-class Lookup a where-  toAccessorTree :: Lens' b a -> AccessorTree b--  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 :: Lens' b (f a) -> AccessorTree b--class GLookupS f where-  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)))---- tuple instances-instance (Lookup a, Lookup b) => Lookup (a, b) where-  toAccessorTree lens0 =-    Data ("(,)", "(,)")-    [ ("(x,_)", toAccessorTree (lens0 . lens1))-    , ("(_,x)", toAccessorTree (lens0 . lens2))-    ]-    where-      lens1 ::  Lens' (a, b) a-      lens1 f (x, y) = fmap (\x' -> (x', y)) (f x)-      lens2 :: Lens' (a, b) b-      lens2 f (x, y) = fmap (\y' -> (x, y')) (f y)--instance (Lookup a, Lookup b, Lookup c) => Lookup (a, b, c) where-  toAccessorTree lens0 =-    Data ("(,,)", "(,,)")-    [ ("(x,_,_)", toAccessorTree (lens0 . lens1))-    , ("(_,x,_)", toAccessorTree (lens0 . lens2))-    , ("(_,_,x)", toAccessorTree (lens0 . lens3))-    ]-    where-      lens1 ::  Lens' (a, b, c) a-      lens1 f (x, y, z) = fmap (\x' -> (x', y, z)) (f x)-      lens2 :: Lens' (a, b, c) b-      lens2 f (x, y, z) = fmap (\y' -> (x, y', z)) (f y)-      lens3 :: Lens' (a, b, c) c-      lens3 f (x, y, z) = fmap (\z' -> (x, y, z')) (f z)--instance (Lookup a, Lookup b, Lookup c, Lookup d) => Lookup (a, b, c, d) where-  toAccessorTree lens0 =-    Data ("(,,,)", "(,,,)")-    [ ("(x,_,_,_)", toAccessorTree (lens0 . lens1))-    , ("(_,x,_,_)", toAccessorTree (lens0 . lens2))-    , ("(_,_,x,_)", toAccessorTree (lens0 . lens3))-    , ("(_,_,_,x)", toAccessorTree (lens0 . lens4))-    ]-    where-      lens1 ::  Lens' (a, b, c, d) a-      lens1 f (x, y, z, w) = fmap (\x' -> (x', y, z, w)) (f x)-      lens2 :: Lens' (a, b, c, d) b-      lens2 f (x, y, z, w) = fmap (\y' -> (x, y', z, w)) (f y)-      lens3 :: Lens' (a, b, c, d) c-      lens3 f (x, y, z, w) = fmap (\z' -> (x, y, z', w)) (f z)-      lens4 :: Lens' (a, b, c, d) d-      lens4 f (x, y, z, w) = fmap (\w' -> (x, y, z, w')) (f w)------ some instance from linear-instance Lookup a => Lookup (Linear.V0 a) where-  toAccessorTree _ =-    Data ("V0", "V0") []-instance Lookup a => Lookup (Linear.V1 a) where-  toAccessorTree lens0 =-    Data ("V1", "V1") [ ("x", toAccessorTree (lens0 . Linear._x))-                      ]--instance Lookup a => Lookup (Linear.V2 a) where-  toAccessorTree lens0 =-    Data ("V2", "V2") [ ("x", toAccessorTree (lens0 . Linear._x))-                      , ("y", toAccessorTree (lens0 . Linear._y))-                      ]--instance Lookup a => Lookup (Linear.V3 a) where-  toAccessorTree lens0 =-    Data ("V3", "V3") [ ("x", toAccessorTree (lens0 . Linear._x))-                      , ("y", toAccessorTree (lens0 . Linear._y))-                      , ("z", toAccessorTree (lens0 . Linear._z))-                      ]-instance Lookup a => Lookup (Linear.V4 a) where-  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))-                      ]-instance Lookup a => Lookup (Linear.Quaternion a) where-  toAccessorTree lens0 =-    Data ("Quaternion", "Quaternion")-    [ ("q0", toAccessorTree (lens0 . Linear._e))-    , ("q1", toAccessorTree (lens0 . Linear._i))-    , ("q2", toAccessorTree (lens0 . Linear._j))-    , ("q3", toAccessorTree (lens0 . Linear._k))-    ]---- basic types-instance Lookup () where -- hack to get dummy tree-  toAccessorTree _ = Field FieldSorry-instance Lookup Int where-  toAccessorTree lens = Field (FieldInt lens)-instance Lookup Float where-  toAccessorTree lens = Field (FieldFloat lens)-instance Lookup Double where-  toAccessorTree lens = Field (FieldDouble lens)-instance Lookup Bool where-  toAccessorTree lens = Field (FieldBool lens)-instance Lookup String where-  toAccessorTree lens = Field (FieldString lens)---- Word types-instance Lookup Word where-  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens))-instance Lookup Word8 where-  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens))-instance Lookup Word16 where-  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens))-instance Lookup Word32 where-  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens))-instance Lookup Word64 where-  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens))---- Int types-instance Lookup Int8 where-  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens))-instance Lookup Int16 where-  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens))-instance Lookup Int32 where-  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens))-instance Lookup Int64 where-  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens))---- C types--- todo(greg): some of these have inappropriate fields-instance Lookup CChar where-  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens))-instance Lookup CSChar where-  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens))-instance Lookup CUChar where-  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens))-instance Lookup CShort where-  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens))-instance Lookup CUShort where-  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens))-instance Lookup CInt where-  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens))-instance Lookup CUInt where-  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens))-instance Lookup CLong where-  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens))-instance Lookup CULong where-  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens))-instance Lookup CPtrdiff where-  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens))-instance Lookup CSize where-  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens))-instance Lookup CWchar where-  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens))-instance Lookup CSigAtomic where-  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens))-instance Lookup CLLong where-  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens))-instance Lookup CULLong where-  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens))-instance Lookup CIntPtr where-  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens))-instance Lookup CUIntPtr where-  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens))-instance Lookup CIntMax where-  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens))-instance Lookup CUIntMax where-  toAccessorTree lens0 = Field (FieldInt (lens0 . integralLens))-instance Lookup CClock where-  toAccessorTree lens0 = Field (FieldInt (lens0 . clockLens))-    where-      clockLens f (CClock x) = fmap (CClock . fromIntegral) (f (fromIntegral x))-instance Lookup CTime where-  toAccessorTree lens0 = Field (FieldInt (lens0 . timeLens))-    where-      timeLens f (CTime x) = fmap (CTime . fromIntegral) (f (fromIntegral x))-instance Lookup CUSeconds where-  toAccessorTree lens0 = Field (FieldInt (lens0 . usecondsLens))-    where-      usecondsLens f (CUSeconds x) = fmap (CUSeconds . fromIntegral) (f (fromIntegral x))-instance Lookup CSUSeconds where-  toAccessorTree lens0 = Field (FieldInt (lens0 . susecondsLens))-    where-      susecondsLens f (CSUSeconds x) = fmap (CSUSeconds . fromIntegral) (f (fromIntegral x))-instance Lookup CFloat where-  toAccessorTree lens0 = Field (FieldDouble (lens0 . realFracLens))-instance Lookup CDouble where-  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 lens0 = toAccessorTree (lens0 . (\f x -> fmap Rot (f (unR x))))-instance Lookup a => Lookup (V3T f a) where-  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]-showAccTrees show' x trees spaces = concat cs ++ [spaces ++ "}"]-  where-    cs = zipWith (showRecordField show' x spaces) trees ("{ " : repeat ", ")--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, (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-    prefixNameEq = prefix ++ getterName ++ " = "-    newSpaces = spaces ++ (replicate (length prefixNameEq) ' ')---- version of (init . unlines) which doesn't throw an error on empty input-initUnlines :: [String] -> [Char]-initUnlines [] = ""-initUnlines xs = init (unlines xs)---- | 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 (Field field) show' x = showVal field show' x---- | Show a list of values--- .--- True --> align the colums, False --> total mayhem-showFlat :: forall a . AccessorTree a -> Bool -> (Double -> String) -> a -> String-showFlat at align show' x = initUnlines $ map f fl-  where-    n = maximum (map (length . fst) fl)--    f (name, lens) = name ++ spaces ++ " = " ++ showVal lens show' x-      where-        spaces-          | align = replicate (n - length name) ' '-          | otherwise = ""--    fl :: [(String, Field a)]-    fl = flatten at+import Accessors.Accessors+import Accessors.Instances ()

@@ -0,0 +1,385 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}++module Accessors.Accessors+       ( Lookup(..)+       , AccessorTree+       , GAData(..)+       , GAConstructor(..)+       , GASimpleEnum(..)+       , GAField(..)+       , GATip(..)+       , accessors+       , describeGAField+       , sameFieldType+       , flatten+       , flatten'+       , showTree+       , showFlat+       ) where++import GHC.Generics++import Control.Lens ( Lens', Prism', (^.), (.~), preview, prism, withPrism )+import Data.List ( intercalate )+import Text.Printf ( printf )++type AccessorTree a = Either (GAField a) (GAData a)++data GAData a = GAData String (GAConstructor a)++data GAConstructor a =+  GAConstructor String [(Maybe String, AccessorTree a)]+  | GASum (GASimpleEnum a)++data GASimpleEnum a =+  GASimpleEnum+  { eConstructors :: [String]+  , eToString :: a -> String+  , eToIndex :: a -> Int+  , eFromString :: a -> String -> Either String a+  , eFromIndex :: a -> Int -> Either String a+  }++data GAField a =+  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 GATip a =+  GATipSimpleEnum (GASimpleEnum a)+  | GATipField (GAField a)++showGAData :: String -> GAData a -> [String]+showGAData spaces (GAData name constructors) =+  (spaces ++ "Data " ++ show name) :+  showGAConstructor (spaces ++ "    ") constructors++showGAConstructor :: String -> GAConstructor a -> [String]+showGAConstructor spaces (GASum e) = [spaces ++ "[" ++ intercalate ", " (eConstructors e) ++ "]"]+showGAConstructor spaces (GAConstructor name fields) =+  (spaces ++ name) : concatMap (showGAField (spaces ++ "    ")) fields++showGAField :: String -> (Maybe String, AccessorTree a) -> [String]+showGAField spaces (name, Left f) = [spaces ++ showMName name ++ " " ++ describeGAField f]+showGAField spaces (name, Right field) =+  showMName name :+  showGAData (spaces ++ "    ") field++showMName :: Maybe String -> String+showMName (Just n) = n+showMName Nothing = "()"++instance Show (GAData a) where+  show = unlines . showGAData ""++-- | Return the type of field, such as "Bool", "Double", "String", etc.+describeGAField :: GAField a -> String+describeGAField (FieldDouble _) = "Double"+describeGAField (FieldFloat _) = "Float"+describeGAField (FieldInt _) = "Int"+describeGAField (FieldString _) = "String"+describeGAField FieldSorry = "Sorry"++-- | Returns True if the __type__ of fields is the same.+sameFieldType :: GAField a -> GAField b -> Bool+sameFieldType (FieldDouble _) (FieldDouble _) = True+sameFieldType (FieldFloat _) (FieldFloat _) = True+sameFieldType (FieldInt _) (FieldInt _) = True+sameFieldType (FieldString _) (FieldString _) = True+sameFieldType FieldSorry FieldSorry = True+sameFieldType (FieldDouble _) _ = False+sameFieldType (FieldFloat _) _ = False+sameFieldType (FieldInt _) _ = False+sameFieldType (FieldString _) _ = False+sameFieldType FieldSorry _ = False++accessors :: Lookup a => AccessorTree a+accessors = toAccessorTree id++showMsgs :: [Maybe String] -> String+showMsgs = intercalate "." . map showMName++flatten :: AccessorTree a -> [(String, GATip a)]+flatten = map f . flatten'+  where+    f (x,y) = (showMsgs x, y)++flatten' :: AccessorTree a -> [([Maybe String], GATip a)]+flatten' = flattenChain []+  where+    flattenChain :: [Maybe String] -> AccessorTree a -> [([Maybe String], GATip a)]+    flattenChain msgs (Left f) = [(reverse msgs, GATipField f)]+    flattenChain msgs (Right (GAData _ (GASum simpleEnum))) = [(reverse msgs, GATipSimpleEnum simpleEnum)]+    flattenChain msgs (Right (GAData _ (GAConstructor _ trees))) = concatMap f trees+      where+        f :: (Maybe String, AccessorTree a) -> [([Maybe String], GATip a)]+        f (name, tree) = flattenChain (name:msgs) tree++-- | Things which you can make a tree of labeled getters for.+-- You should derive this using GHC.Generics.+class Lookup a where+  toAccessorTree :: Lens' b a -> AccessorTree b++  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 :: Lens' b (f a) -> AccessorTree b++class GLookupS f where+  gtoAccessorTreeS :: Lens' b (f a) -> [(Maybe String, AccessorTree b)]++instance Lookup f => GLookup (Rec0 f) where+  gtoAccessorTree :: Lens' b (Rec0 f p) -> AccessorTree b+  gtoAccessorTree lens0 = toAccessorTree (lens0 . rec0Lens)+    where+      rec0Lens :: Lens' (Rec0 f a) f+      rec0Lens f y = fmap K1 (f (unK1 y))++class GEnum a where+  gtoSimpleEnum :: Prism' b (a p) -> [(String, b, b -> Bool)]++instance Constructor c => GEnum (C1 c U1) where+  gtoSimpleEnum :: forall b p . Prism' b (C1 c U1 p) -> [(String, b, b -> Bool)]+  gtoSimpleEnum pr = [(cname, thisOne, isThisOne)]+    where+      thisOne :: b+      thisOne = withPrism pr $ \f _ -> f (M1 U1 :: C1 c U1 p)++      isThisOne :: b -> Bool+      isThisOne b = case preview pr b :: Maybe (C1 c U1 p) of+        Nothing -> False+        Just _ -> True++      cname = conName conError++      conError :: C1 c a p+      conError = error $ "generic-accessors: conName should never access data"++instance (GEnum c1, GEnum c2) => GEnum (c1 :+: c2) where+  gtoSimpleEnum :: forall b p . Prism' b ((c1 :+: c2) p) -> [(String, b, b -> Bool)]+  gtoSimpleEnum pr0 = c1s ++ c2s+    where+      c1s = gtoSimpleEnum ((pr0 . leftPrism) :: Prism' b (c1 p))+      c2s = gtoSimpleEnum ((pr0 . rightPrism) :: Prism' b (c2 p))++      leftPrism :: Prism' ((c1 :+: c2) p) (c1 p)+      leftPrism = prism remitter reviewer+        where+          remitter = L1+          reviewer (L1 l) = Right l+          reviewer x = Left x++      rightPrism :: Prism' ((c1 :+: c2) p) (c2 p)+      rightPrism = prism remitter reviewer+        where+          remitter = R1+          reviewer (R1 l) = Right l+          reviewer x = Left x++instance (Datatype d, GEnum (c1 :+: c2)) => GLookup (D1 d (c1 :+: c2)) where+  gtoAccessorTree :: forall b p . Lens' b (D1 d (c1 :+: c2) p) -> AccessorTree b+  gtoAccessorTree lens0 = Right $ GAData (datatypeName datatypeError) constructor+    where+      datatypeError :: D1 d (c1 :+: c2) p+      datatypeError = error $ "generic-accessors: datatypeName should never access data"++      constructor :: GAConstructor b+      constructor =+        GASum+        GASimpleEnum+        { eConstructors = options+        , eToString = toString+        , eToIndex = toIndex+        , eFromIndex = fromIndex+        , eFromString = fromString+        }+        where+          options = map fst3 simpleEnums+            where+              fst3 (x,_,_) = x++          fromIndex x k+            | k < 0 =+                Left $+                printf "generic-accessors: Error converting Int to Enum: requested negative index (%d)" k+            | k >= length options =+                Left $+                "generic-accessors: Error converting Int to Enum.\n" +++                printf "Requested index %d but there are only %d options." k (length simpleEnums)+            | otherwise = Right $ (lens0 . m1Lens . intLens .~ k) x++          fromString x name = fromString' 0 options+            where+              fromString' k (opt:opts)+                | name == opt = fromIndex x k+                | otherwise = fromString' (k+1) opts+              fromString' _ [] =+                Left $+                "generic-accessors: Error converting from String to Enum: "+                ++ show name ++ "is not one of the constructors."++          toIndex x = x ^. (lens0 . m1Lens . intLens)+          toString x = case safeIndex options index of+            Just r -> r+            Nothing -> error $ unlines+                       [ "generic-accessors: eToString: the \"impossible\" happened"+                       , printf "Enum is out of bounds (index %d, length %d)." index (length options)+                       ]+            where+              index = toIndex x++      simpleEnums :: [(String, (c1 :+: c2) p, (c1 :+: c2) p -> Bool)]+      simpleEnums = gtoSimpleEnum id++      intLens :: Lens' ((c1 :+: c2) p) Int+      intLens f y = fmap fromInt' (f (toInt y))++      fromInt' :: Int -> (c1 :+: c2) p+      fromInt' k = case fromInt k of+        Right r -> r+        Left e -> error e++      fromInt :: Int -> Either String ((c1 :+: c2) p)+      fromInt k = case safeIndex simpleEnums k of+        Nothing -> Left $+                   "generic-accessors:\n" +++                   "Error converting Int to Enum.\n" +++                   printf "Requested index %d but there are only %d options." k (length simpleEnums)+        Just (_, x, _) -> Right x++      toInt :: (c1 :+: c2) p -> Int+      toInt x = toInt' 0 simpleEnums+        where+          toInt' k ((_, _, isVal):others)+            | isVal x = k+            | otherwise = toInt' (k+1) others+          toInt' _ [] =+            error $ unlines+            [ "generic-accessors:"+            , "The \"impossible\" happened converting Enum to Int."+            , "No enum matched the provided one."+            ]++      safeIndex :: [a] -> Int -> Maybe a+      safeIndex (x:_) 0 = Just x+      safeIndex (_:xs) k = safeIndex xs (k-1)+      safeIndex [] _ = Nothing++m1Lens :: Lens' (M1 i c f p) (f p)+m1Lens f y = fmap M1 (f (unM1 y))++instance (Datatype d, Constructor c, GLookupS a) => GLookup (D1 d (C1 c a)) where+  gtoAccessorTree :: forall b p . Lens' b (D1 d (C1 c a) p) -> AccessorTree b+  gtoAccessorTree lens0 = Right $ GAData (datatypeName datatypeError) constructor+    where+      datatypeError :: D1 d (C1 c a) p+      datatypeError = error $ "generic-accessors: datatypeName should never access data"++      constructor :: GAConstructor b+      constructor = gtoAccessorTreeC (lens0 . m1Lens)++gtoAccessorTreeC :: forall c b a p . (Constructor c, GLookupS a) => Lens' b (C1 c a p) -> GAConstructor b+gtoAccessorTreeC lens0 = GAConstructor (conName conError) (gtoAccessorTreeS (lens0 . m1Lens))+  where+    conError :: C1 c a p+    conError = error $ "generic-accessors: conName should never access data"++instance (Selector s, GLookup a) => GLookupS (S1 s a) where+  gtoAccessorTreeS :: Lens' b (S1 s a p) -> [(Maybe String, AccessorTree b)]+  gtoAccessorTreeS lens0 = [(selname, gtoAccessorTree (lens0 . m1Lens))]+    where+      selname = case selName selError of+        "" -> Nothing+        y -> Just y++      selError :: S1 s a p+      selError = error $ "generic-accessors: selName should never access data"++instance GLookupS U1 where+  gtoAccessorTreeS :: Lens' b (U1 p) -> [(Maybe String, AccessorTree b)]+  gtoAccessorTreeS _ = []++instance (GLookupS f, GLookupS g) => GLookupS (f :*: g) where+  gtoAccessorTreeS :: Lens' b ((f :*: g) p) -> [(Maybe String, AccessorTree b)]+  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)+++showAccTrees :: (Double -> String) -> a+                -> [(Maybe String, AccessorTree a)] -> String+                -> [String]+showAccTrees show' x trees spaces = concat cs ++ [spaces ++ "}"]+  where+    cs = zipWith (showRecordField show' x spaces) trees ("{ " : repeat ", ")++showFieldVal :: GAField a -> (Double -> String) -> a -> String+showFieldVal (FieldInt lens) _ x = show (x ^. lens)+showFieldVal (FieldDouble lens) show' x = show' (x ^. lens)+showFieldVal (FieldFloat lens) show' x = show' (realToFrac (x ^. lens))+showFieldVal (FieldString lens) _ x = x ^. lens+showFieldVal FieldSorry _ _ = ""++showTipVal :: GATip a -> (Double -> String) -> a -> String+showTipVal (GATipField f) sh x = showFieldVal f sh x+showTipVal (GATipSimpleEnum simpleEnum) _ x = eToString simpleEnum x++showRecordField :: (Double -> String) -> a -> String -> (Maybe String, AccessorTree a) -> String -> [String]+showRecordField show' x spaces (getterName, (Left field)) prefix =+  [spaces ++ prefix ++ showMName getterName ++ " = " ++ showFieldVal field show' x]+showRecordField _ x spaces (getterName, Right (GAData _ (GASum simpleEnum))) prefix =+  [spaces ++ prefix ++ showMName getterName ++ " = " ++ eToString simpleEnum x]+showRecordField show' x spaces (getterName, Right (GAData _ (GAConstructor cons trees))) prefix =+  (spaces ++ prefixNameEq ++ cons) : showAccTrees show' x trees newSpaces+  where+    prefixNameEq = prefix ++ showMName getterName ++ " = "+    newSpaces = spaces ++ (replicate (length prefixNameEq) ' ')++-- version of (init . unlines) which doesn't throw an error on empty input+initUnlines :: [String] -> [Char]+initUnlines [] = ""+initUnlines xs = init (unlines xs)++-- | Show a tree of values+showTree :: AccessorTree a -> (Double -> String) -> a -> String+showTree (Right (GAData _ (GASum simpleEnum))) _ x = eToString simpleEnum x+showTree (Right (GAData _ (GAConstructor cons trees))) show' x =+  initUnlines $ cons : showAccTrees show' x trees ""+showTree (Left field) show' x = showFieldVal field show' x++-- | Show a list of values+-- .+-- True --> align the colums, False --> total mayhem+showFlat :: forall a . AccessorTree a -> Bool -> (Double -> String) -> a -> String+showFlat at align show' x = initUnlines $ map f fl+  where+    n = maximum (map (length . fst) fl)++    f (name, lens) = name ++ spaces ++ " = " ++ showTipVal lens show' x+      where+        spaces+          | align = replicate (n - length name) ' '+          | otherwise = ""++    fl :: [(String, GATip a)]+    fl = flatten at

@@ -0,0 +1,221 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}++module Accessors.Dynamic+       ( DTree, DData(..), DConstructor(..), DSimpleEnum(..), DField(..)+       , toDData, updateLookupable, describeDField, sameDFieldType+         -- * some utility functions for working with DSimpleEnums+       , denumToString, denumToStringOrMsg, denumSetString, denumSetIndex+       ) where++import GHC.Generics++import Data.Binary ( Binary )+import Data.Serialize ( Serialize )+import Data.Data ( Data )+import Data.List ( intercalate )+import Data.Typeable ( Typeable )+import Control.Lens+import Text.Printf ( printf )++import Accessors++type DTree = Either DField DData++data DData = DData String DConstructor+           deriving (Generic, Show, Eq, Ord, Data, Typeable)+instance Serialize DData+instance Binary DData++data DConstructor =+  DConstructor String [(Maybe String, DTree)]+  | DSum DSimpleEnum+  deriving (Generic, Show, Eq, Ord, Data, Typeable)+instance Serialize DConstructor+instance Binary DConstructor++data DSimpleEnum = DSimpleEnum [String] Int+                 deriving (Generic, Show, Eq, Ord, Data, Typeable)+instance Serialize DSimpleEnum+instance Binary DSimpleEnum++-- | a dynamic field+data DField =+  DDouble Double+  | DFloat Float+  | DInt Int+  | DString String+  | DSorry+  deriving (Generic, Show, Eq, Ord, Data, Typeable)+instance Serialize DField+instance Binary DField++-- | Get the constructor string or an error message.+denumToString :: DSimpleEnum -> Either String String+denumToString (DSimpleEnum _ k)+  | k < 0 = Left $ printf "denumToString: index %d is negative" k+denumToString (DSimpleEnum constructors k) = safeIndex constructors k+  where+    safeIndex (x:_) 0 = Right x+    safeIndex (_:xs) j = safeIndex xs (j-1)+    safeIndex [] _ =+      Left $+      printf "denumToString: index %d is too large (%d constructors)" k (length constructors)++-- | Get the constructor string or an error message without telling which is which.+denumToStringOrMsg :: DSimpleEnum -> String+denumToStringOrMsg d = case denumToString d of+  Left msg -> msg+  Right r -> r++-- | Try to update an enum with its constructor. Fail if not a valid constructor.+denumSetString :: DSimpleEnum -> String -> Either String DSimpleEnum+denumSetString (DSimpleEnum options _) txt = safeLookup options 0+  where+    safeLookup (opt:opts) k+      | opt == txt = Right (DSimpleEnum options k)+      | otherwise = safeLookup opts (k + 1)+    safeLookup [] _ = Left $ printf "denumSetString: %s is not a valid constructor" txt++-- | Try to update an enum with its index. Fail if out of bounds.+denumSetIndex :: DSimpleEnum -> Int -> Either String DSimpleEnum+denumSetIndex (DSimpleEnum constructors _) k+  | k < 0 = Left $ printf "denumSetIndex: index %d is negative" k+  | k >= length constructors =+      Left $+      printf "denumSetIndex: index %d is too large (%d constructors)" k (length constructors)+  | otherwise = Right $ DSimpleEnum constructors k++-- | Returns True if the __type__ of fields is the same.+sameDFieldType :: DField -> DField -> Bool+sameDFieldType (DDouble _) (DDouble _) = True+sameDFieldType (DFloat _) (DFloat _) = True+sameDFieldType (DInt _) (DInt _) = True+sameDFieldType (DString _) (DString _) = True+sameDFieldType DSorry DSorry = True+sameDFieldType (DDouble _) _ = False+sameDFieldType (DFloat _) _ = False+sameDFieldType (DInt _) _ = False+sameDFieldType (DString _) _ = False+sameDFieldType DSorry _ = False++describeDField :: DField -> String+describeDField (DInt _) = "Int"+describeDField (DDouble _) = "Double"+describeDField (DFloat _) = "Float"+describeDField (DString _) = "String"+describeDField DSorry = "Sorry"++-- | convert to a dynamic value+toDData :: forall a . Lookup a => a -> DTree+toDData x = toDData' accessors+  where+    toDData' :: Either (GAField a) (GAData a) -> DTree+    toDData' (Right (GAData dname constructor)) =+      Right $ DData dname (toDConstructor constructor)+    toDData' (Left field) = Left (toDField field)++    toDConstructor :: GAConstructor a -> DConstructor+    toDConstructor (GASum e) =+      DSum (DSimpleEnum (eConstructors e) (eToIndex e x))+      +    toDConstructor (GAConstructor cname fields) =+      DConstructor cname $ map (\(n, f) -> (n, toDData' f)) fields++    toDField :: GAField a -> DField+    toDField (FieldInt f) = DInt (x ^. f)+    toDField (FieldDouble f) = DDouble (x ^. f)+    toDField (FieldFloat f) = DFloat (x ^. f)+    toDField (FieldString f) = DString (x ^. f)+    toDField FieldSorry = DSorry+++-- | Update something using a dynamic representation+updateLookupable :: Lookup a => a -> DTree -> Either String a+updateLookupable x0 dtree = updateData x0 accessors dtree++updateData :: forall a+                     . a+                     -> Either (GAField a) (GAData a)+                     -> DTree+                     -> Either String a+updateData x0 (Left afield) (Left dfield) = updateField x0 afield dfield+updateData x0 (Right (GAData adataName acon)) (Right (DData ddataName dcon))+  | adataName /= ddataName =+      Left $+      "dynamic datatype name " ++ show ddataName +++      " don't match accessor datatype names " ++ show adataName+  | otherwise = updateConstructor x0 acon dcon+updateData _ (Left field) (Right (DData n _)) =+  Left $ "got GAField (" ++ describeGAField field ++ ") for accessor tree but DData (" ++ show n ++ ") for dynamic tree"+updateData _ (Right (GAData n _)) (Left field) =+  Left $ "got GAData for accessor tree (" ++ show n ++ ") but DField (" ++ describeDField field++ ") for dynamic tree"++showList' :: [String] -> String+showList' xs = "[" ++ intercalate ", " xs ++ "]"++updateConstructor :: forall a+                     . a+                     -> GAConstructor a+                     -> DConstructor+                     -> Either String a+updateConstructor x (GASum aenum) (DSum (DSimpleEnum dnames k))+  | anames /= dnames =+      Left $+      "accessor sum options " ++ showList' anames +++      " doesn't match dynamic sum options " ++ showList' dnames+  | otherwise = eFromIndex aenum x k+  where+    anames = eConstructors aenum+updateConstructor x0 (GAConstructor aconName afields) (DConstructor dconName dfields)+  | aconName /= dconName =+      Left $+      "dynamic constructor name " ++ show dconName +++      " don't match accessor constructor names " ++ show aconName+  | length afields /= length dfields = lengthMismatch+  | otherwise = f x0 afields dfields+    where+      lengthMismatch =+        Left $+        "dynamic fields have different length than accessor fields\n" +++        "dynamic fields: " ++ show (map fst dfields) ++ "\n" +++        "accessor fields: " ++ show (map fst afields)+        +      f :: a+           -> [(Maybe String, Either (GAField a) (GAData a))]+           -> [(Maybe String, DTree)]+           -> Either String a+      f x ((aname, afield):as) ((dname, dfield):ds)+        | aname /= dname =+            Left $+            "accessor selector name " ++ show aname +++            " doesn't match dynamic selector name " ++ show dname+        | otherwise = case updateData x afield dfield of+            Left msg -> Left $ "error updating selector " ++ show aname ++ ": " ++ msg+            Right r -> f r as ds+      f x [] [] = Right x+      -- this should never happen:+      f _ _ _ = lengthMismatch+updateConstructor _ (GAConstructor aconName _) (DSum (DSimpleEnum dnames _)) =+  Left $ "got GAConstructor (" ++ aconName ++ ") but DSum ([" ++ showList' dnames ++ "])"+updateConstructor _ (GASum aenum) (DConstructor dconName _) =+  Left $ "got GASum ([" ++ showList' (eConstructors aenum) ++ "]) but DConstructor (" ++ dconName ++ ")"+++updateField :: a -> GAField a -> DField -> Either String a+updateField x0 (FieldDouble f) (DDouble x) = Right $ (f .~ x) x0+updateField x0 (FieldFloat f) (DFloat x) = Right $ (f .~ x) x0+updateField x0 (FieldInt f) (DInt x) = Right $ (f .~ x) x0+updateField x0 (FieldString f) (DString x) = Right $ (f .~ x) x0+updateField x0 FieldSorry _ = Right x0+updateField _ f@(FieldDouble _) d = Left (fieldMismatch f d)+updateField _ f@(FieldFloat _) d = Left (fieldMismatch f d)+updateField _ f@(FieldInt _) d = Left (fieldMismatch f d)+updateField _ f@(FieldString _) d = Left (fieldMismatch f d)++fieldMismatch :: GAField a -> DField -> String+fieldMismatch f d =+  "accessor GAField " ++ describeGAField f +++  " got incompatible dynamic DField " ++ describeDField d

@@ -0,0 +1,219 @@+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances #-}++module Accessors.Instances () where++import Control.Lens ( Lens' )+import qualified Linear+import GHC.Word+import Data.Int+import Foreign.C.Types+import SpatialMath ( Euler )+import SpatialMathT ( V3T(..), Rot(..) )++import Accessors.Accessors ( Lookup(..), GAData(..), GAConstructor(..), GAField(..) )++-- tuple instances+instance (Lookup a, Lookup b) => Lookup (a, b) where+  toAccessorTree lens0 =+    Right $+    GAData "(,)" $+    GAConstructor "(,)"+    [ (Just "(x,_)", toAccessorTree (lens0 . lens1))+    , (Just "(_,x)", toAccessorTree (lens0 . lens2))+    ]+    where+      lens1 ::  Lens' (a, b) a+      lens1 f (x, y) = fmap (\x' -> (x', y)) (f x)++      lens2 :: Lens' (a, b) b+      lens2 f (x, y) = fmap (\y' -> (x, y')) (f y)++instance (Lookup a, Lookup b, Lookup c) => Lookup (a, b, c) where+  toAccessorTree lens0 =+    Right $+    GAData "(,,)" $+    GAConstructor "(,,)"+    [ (Just "(x,_,_)", toAccessorTree (lens0 . lens1))+    , (Just "(_,x,_)", toAccessorTree (lens0 . lens2))+    , (Just "(_,_,x)", toAccessorTree (lens0 . lens3))+    ]+    where+      lens1 ::  Lens' (a, b, c) a+      lens1 f (x, y, z) = fmap (\x' -> (x', y, z)) (f x)+      lens2 :: Lens' (a, b, c) b+      lens2 f (x, y, z) = fmap (\y' -> (x, y', z)) (f y)+      lens3 :: Lens' (a, b, c) c+      lens3 f (x, y, z) = fmap (\z' -> (x, y, z')) (f z)++instance (Lookup a, Lookup b, Lookup c, Lookup d) => Lookup (a, b, c, d) where+  toAccessorTree lens0 =+    Right $+    GAData "(,,,)" $+    GAConstructor "(,,,)"+    [ (Just "(x,_,_,_)", toAccessorTree (lens0 . lens1))+    , (Just "(_,x,_,_)", toAccessorTree (lens0 . lens2))+    , (Just "(_,_,x,_)", toAccessorTree (lens0 . lens3))+    , (Just "(_,_,_,x)", toAccessorTree (lens0 . lens4))+    ]+    where+      lens1 ::  Lens' (a, b, c, d) a+      lens1 f (x, y, z, w) = fmap (\x' -> (x', y, z, w)) (f x)+      lens2 :: Lens' (a, b, c, d) b+      lens2 f (x, y, z, w) = fmap (\y' -> (x, y', z, w)) (f y)+      lens3 :: Lens' (a, b, c, d) c+      lens3 f (x, y, z, w) = fmap (\z' -> (x, y, z', w)) (f z)+      lens4 :: Lens' (a, b, c, d) d+      lens4 f (x, y, z, w) = fmap (\w' -> (x, y, z, w')) (f w)+++-- some instance from linear+instance Lookup a => Lookup (Linear.V0 a) where+  toAccessorTree _ =+    Right $ GAData "V0" $ GAConstructor "V0" []+instance Lookup a => Lookup (Linear.V1 a) where+  toAccessorTree lens0 =+    Right $ GAData "V1" $ GAConstructor "V1"+    [(Just "x", toAccessorTree (lens0 . Linear._x))]++instance Lookup a => Lookup (Linear.V2 a) where+  toAccessorTree lens0 =+    Right $ GAData "V2" $ GAConstructor "V2"+    [ (Just "x", toAccessorTree (lens0 . Linear._x))+    , (Just "y", toAccessorTree (lens0 . Linear._y))+    ]++instance Lookup a => Lookup (Linear.V3 a) where+  toAccessorTree lens0 =+    Right $ GAData "V3" $ GAConstructor "V3"+    [ (Just "x", toAccessorTree (lens0 . Linear._x))+    , (Just "y", toAccessorTree (lens0 . Linear._y))+    , (Just "z", toAccessorTree (lens0 . Linear._z))+    ]+instance Lookup a => Lookup (Linear.V4 a) where+  toAccessorTree lens0 =+    Right $ GAData "V4" $ GAConstructor "V4"+    [ (Just "x", toAccessorTree (lens0 . Linear._x))+    , (Just "y", toAccessorTree (lens0 . Linear._y))+    , (Just "z", toAccessorTree (lens0 . Linear._z))+    , (Just "w", toAccessorTree (lens0 . Linear._w))+    ]+instance Lookup a => Lookup (Linear.Quaternion a) where+  toAccessorTree lens0 =+    Right $ GAData "Quaternion" $ GAConstructor "Quaternion"+    [ (Just "q0", toAccessorTree (lens0 . Linear._e))+    , (Just "q1", toAccessorTree (lens0 . Linear._i))+    , (Just "q2", toAccessorTree (lens0 . Linear._j))+    , (Just "q3", toAccessorTree (lens0 . Linear._k))+    ]++-- basic types+instance Lookup () where -- hack to get dummy tree+  toAccessorTree _ = Left FieldSorry+instance Lookup Int where+  toAccessorTree lens = Left (FieldInt lens)+instance Lookup Float where+  toAccessorTree lens = Left (FieldFloat lens)+instance Lookup Double where+  toAccessorTree lens = Left (FieldDouble lens)+instance Lookup Bool+instance Lookup String where+  toAccessorTree lens = Left (FieldString lens)++-- Word types+instance Lookup Word where+  toAccessorTree lens0 = Left (FieldInt (lens0 . integralLens))+instance Lookup Word8 where+  toAccessorTree lens0 = Left (FieldInt (lens0 . integralLens))+instance Lookup Word16 where+  toAccessorTree lens0 = Left (FieldInt (lens0 . integralLens))+instance Lookup Word32 where+  toAccessorTree lens0 = Left (FieldInt (lens0 . integralLens))+instance Lookup Word64 where+  toAccessorTree lens0 = Left (FieldInt (lens0 . integralLens))++-- Int types+instance Lookup Int8 where+  toAccessorTree lens0 = Left (FieldInt (lens0 . integralLens))+instance Lookup Int16 where+  toAccessorTree lens0 = Left (FieldInt (lens0 . integralLens))+instance Lookup Int32 where+  toAccessorTree lens0 = Left (FieldInt (lens0 . integralLens))+instance Lookup Int64 where+  toAccessorTree lens0 = Left (FieldInt (lens0 . integralLens))++-- C types+-- todo(greg): some of these have inappropriate fields+instance Lookup CChar where+  toAccessorTree lens0 = Left (FieldInt (lens0 . integralLens))+instance Lookup CSChar where+  toAccessorTree lens0 = Left (FieldInt (lens0 . integralLens))+instance Lookup CUChar where+  toAccessorTree lens0 = Left (FieldInt (lens0 . integralLens))+instance Lookup CShort where+  toAccessorTree lens0 = Left (FieldInt (lens0 . integralLens))+instance Lookup CUShort where+  toAccessorTree lens0 = Left (FieldInt (lens0 . integralLens))+instance Lookup CInt where+  toAccessorTree lens0 = Left (FieldInt (lens0 . integralLens))+instance Lookup CUInt where+  toAccessorTree lens0 = Left (FieldInt (lens0 . integralLens))+instance Lookup CLong where+  toAccessorTree lens0 = Left (FieldInt (lens0 . integralLens))+instance Lookup CULong where+  toAccessorTree lens0 = Left (FieldInt (lens0 . integralLens))+instance Lookup CPtrdiff where+  toAccessorTree lens0 = Left (FieldInt (lens0 . integralLens))+instance Lookup CSize where+  toAccessorTree lens0 = Left (FieldInt (lens0 . integralLens))+instance Lookup CWchar where+  toAccessorTree lens0 = Left (FieldInt (lens0 . integralLens))+instance Lookup CSigAtomic where+  toAccessorTree lens0 = Left (FieldInt (lens0 . integralLens))+instance Lookup CLLong where+  toAccessorTree lens0 = Left (FieldInt (lens0 . integralLens))+instance Lookup CULLong where+  toAccessorTree lens0 = Left (FieldInt (lens0 . integralLens))+instance Lookup CIntPtr where+  toAccessorTree lens0 = Left (FieldInt (lens0 . integralLens))+instance Lookup CUIntPtr where+  toAccessorTree lens0 = Left (FieldInt (lens0 . integralLens))+instance Lookup CIntMax where+  toAccessorTree lens0 = Left (FieldInt (lens0 . integralLens))+instance Lookup CUIntMax where+  toAccessorTree lens0 = Left (FieldInt (lens0 . integralLens))+instance Lookup CClock where+  toAccessorTree lens0 = Left (FieldInt (lens0 . clockLens))+    where+      clockLens f (CClock x) = fmap (CClock . fromIntegral) (f (fromIntegral x))+instance Lookup CTime where+  toAccessorTree lens0 = Left (FieldInt (lens0 . timeLens))+    where+      timeLens f (CTime x) = fmap (CTime . fromIntegral) (f (fromIntegral x))+instance Lookup CUSeconds where+  toAccessorTree lens0 = Left (FieldInt (lens0 . usecondsLens))+    where+      usecondsLens f (CUSeconds x) = fmap (CUSeconds . fromIntegral) (f (fromIntegral x))+instance Lookup CSUSeconds where+  toAccessorTree lens0 = Left (FieldInt (lens0 . susecondsLens))+    where+      susecondsLens f (CSUSeconds x) = fmap (CSUSeconds . fromIntegral) (f (fromIntegral x))+instance Lookup CFloat where+  toAccessorTree lens0 = Left (FieldDouble (lens0 . realFracLens))+instance Lookup CDouble where+  toAccessorTree lens0 = Left (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 lens0 = toAccessorTree (lens0 . (\f x -> fmap Rot (f (unR x))))+instance Lookup a => Lookup (V3T f a) where+  toAccessorTree lens0 = toAccessorTree (lens0 . (\f x -> fmap V3T (f (unV x))))+instance Lookup a => Lookup (Euler a)

@@ -13,11 +13,13 @@ import Test.Framework.Providers.HUnit ( testCase )  import Accessors+import Accessors.Dynamic  main :: IO () main = do   defaultMainWithOpts     [ accessorTests+    , dynamicTests     ]     opts @@ -34,27 +36,29 @@ data Xyz a = Xyz { xx :: Int                  , yy :: Double                  , zz :: Float+                 , bb :: (Bool, Bool, Bool)                  , ww :: a-                 } deriving (Generic)-data One = MkOne { one :: Double } deriving (Generic)+                 } deriving (Generic, Show)+data One = MkOne { one :: Double+                 } deriving (Generic, Show) data Foo = MkFoo { aaa :: Int                  , bbb :: Xyz Int                  , lol :: Bool                  , notlol :: Bool                  , yoyo :: Xyz (Xyz Double)                  , ccc :: One-                 } deriving (Generic)+                 } deriving (Generic, Show) instance Lookup One instance Lookup a => Lookup (Xyz a) instance Lookup Foo  yo :: Xyz (Xyz Double)-yo = Xyz 42 45 2000 (Xyz 2 3 4 5)+yo = Xyz 42 45 2000 (True, True, False) (Xyz 2 3 4 (False, True, False) 5)  foo :: Foo-foo = MkFoo 2 (Xyz 6 7 8 9) True False yo (MkOne 17)+foo = MkFoo 2 (Xyz 6 7 8 (True, False, False) 9) True False yo (MkOne 17) -yup :: AccessorTree Foo+yup :: Either (GAField Foo) (GAData Foo) yup = accessors  @@ -66,6 +70,14 @@   , testCase "showFlat (aligned)" flatTestAligned   ] +dynamicTests :: Test+dynamicTests =+  testGroup "dynamic"+  [ testCase "toDValue" toDValueTest+  , testCase "updateDValueTest" updateDValueTest+  , testCase "badupdateDValueTest" badUpdateDValueTest+  ]+ assertEqualString :: String -> String -> HUnit.Assertion assertEqualString x y = HUnit.assertBool msg (x == y)   where@@ -75,6 +87,92 @@           y ++           "\n-----------------------------------------------" +assertEqualString' :: Either String String -> Either String String -> HUnit.Assertion+assertEqualString' ex ey = HUnit.assertBool msg (ex == ey)+  where+    x = case ex of+      Left r -> r+      Right r -> r+    y = case ey of+      Left r -> r+      Right r -> r+    msg = "------------------ expected: ------------------\n" +++          x +++          "\n------------------ but got: -------------------\n" +++          y +++          "\n-----------------------------------------------"++toDValueTest :: HUnit.Assertion+toDValueTest = assertEqualString x y+  where+    x = "Right (DData \"Xyz\" (DConstructor \"Xyz\" [(Just \"xx\",Left (DInt 1)),(Just \"yy\",Left (DDouble 2.0)),(Just \"zz\",Left (DFloat 3.0)),(Just \"bb\",Right (DData \"(,,)\" (DConstructor \"(,,)\" [(Just \"(x,_,_)\",Right (DData \"Bool\" (DSum (DSimpleEnum [\"False\",\"True\"] 1)))),(Just \"(_,x,_)\",Right (DData \"Bool\" (DSum (DSimpleEnum [\"False\",\"True\"] 0)))),(Just \"(_,_,x)\",Right (DData \"Bool\" (DSum (DSimpleEnum [\"False\",\"True\"] 1))))]))),(Just \"ww\",Right (DData \"One\" (DConstructor \"MkOne\" [(Just \"one\",Left (DDouble 4.0))])))]))"++    y = show (toDData (Xyz 1 2 3 (True, False, True) (MkOne 4)))++updateDValueTest :: HUnit.Assertion+updateDValueTest = assertEqualString' (fmap show x) (fmap show y)+  where+    x0 :: Xyz One+    x0 = Xyz 1 2 3 (True, False, True) (MkOne 4)++    dvalue =+      DData "Xyz" $+      DConstructor "Xyz" $+      [ (Just "xx", Left (DInt 10))+      , (Just "yy", Left (DDouble 20.0))+      , (Just "zz", Left (DFloat 30.0))+      , ( Just "bb"+        , Right (DData "(,,)"+                 (DConstructor "(,,)"+                  [ (Just "(x,_,_)", Right (DData "Bool" (DSum (DSimpleEnum ["False", "True"] 0))))+                  , (Just "(_,x,_)", Right (DData "Bool" (DSum (DSimpleEnum ["False", "True"] 1))))+                  , (Just "(_,_,x)", Right (DData "Bool" (DSum (DSimpleEnum ["False", "True"] 1))))+                  ]))+        )+      , (Just "ww", Right (DData "One"+                           (DConstructor "MkOne"+                            [ (Just "one", Left (DDouble 40.0))+                            ])))+      ]++    x :: Either String (Xyz One)+    x = Right $ Xyz 10 20 30 (False, True, True) (MkOne 40)++    y :: Either String (Xyz One)+    y = updateLookupable x0 (Right dvalue)++badUpdateDValueTest :: HUnit.Assertion+badUpdateDValueTest = assertEqualString' (fmap show x) (fmap show y)+  where+    x0 :: Xyz One+    x0 = Xyz 1 2 3 (True, False, True) (MkOne 4)++    dvalue =+      DData "Xyz" $+      DConstructor "Xyz" $+      [ (Just "xx", Left (DInt 10))+      , (Just "yy", Left (DDouble 20.0))+      , (Just "zz", Left (DFloat 30.0))+      , ( Just "b"+        , Right (DData "(,,)"+                 (DConstructor "(,,)"+                  [ (Just "(x,_,_)", Right (DData "Bool" (DSum (DSimpleEnum ["False", "True"] 0))))+                  , (Just "(_,x,_)", Right (DData "Bool" (DSum (DSimpleEnum ["False", "True"] 1))))+                  , (Just "(_,_,x)", Right (DData "Bool" (DSum (DSimpleEnum ["False", "True"] 1))))+                  ]))+        )+      , (Just "ww", Right (DData "One"+                           (DConstructor "MkOne"+                            [ (Just "one", Left (DDouble 40.0))+                            ])))+      ]++    x :: Either String (Xyz One)+    x = Left "accessor selector name Just \"bb\" doesn't match dynamic selector name Just \"b\""++    y :: Either String (Xyz One)+    y = updateLookupable x0 (Right dvalue)+ treeTest :: HUnit.Assertion treeTest = assertEqualString x y   where@@ -85,6 +183,11 @@         , "        { xx = 6"         , "        , yy = 7.00e0"         , "        , zz = 8.00e0"+        , "        , bb = (,,)"+        , "               { (x,_,_) = True"+        , "               , (_,x,_) = False"+        , "               , (_,_,x) = False"+        , "               }"         , "        , ww = 9"         , "        }"         , ", lol = True"@@ -93,10 +196,20 @@         , "         { xx = 42"         , "         , yy = 4.50e1"         , "         , zz = 2.00e3"+        , "         , bb = (,,)"+        , "                { (x,_,_) = True"+        , "                , (_,x,_) = True"+        , "                , (_,_,x) = False"+        , "                }"         , "         , ww = Xyz"         , "                { xx = 2"         , "                , yy = 3.00e0"         , "                , zz = 4.00e0"+        , "                , bb = (,,)"+        , "                       { (x,_,_) = False"+        , "                       , (_,x,_) = True"+        , "                       , (_,_,x) = False"+        , "                       }"         , "                , ww = 5.00e0"         , "                }"         , "         }"@@ -115,15 +228,24 @@         , "bbb.xx = 6"         , "bbb.yy = 7.00e0"         , "bbb.zz = 8.00e0"+        , "bbb.bb.(x,_,_) = True"+        , "bbb.bb.(_,x,_) = False"+        , "bbb.bb.(_,_,x) = False"         , "bbb.ww = 9"         , "lol = True"         , "notlol = False"         , "yoyo.xx = 42"         , "yoyo.yy = 4.50e1"         , "yoyo.zz = 2.00e3"+        , "yoyo.bb.(x,_,_) = True"+        , "yoyo.bb.(_,x,_) = True"+        , "yoyo.bb.(_,_,x) = False"         , "yoyo.ww.xx = 2"         , "yoyo.ww.yy = 3.00e0"         , "yoyo.ww.zz = 4.00e0"+        , "yoyo.ww.bb.(x,_,_) = False"+        , "yoyo.ww.bb.(_,x,_) = True"+        , "yoyo.ww.bb.(_,_,x) = False"         , "yoyo.ww.ww = 5.00e0"         , "ccc.one = 1.70e1"         ]@@ -133,20 +255,29 @@ flatTestAligned = assertEqualString x y   where     x = init $ unlines-        [ "aaa        = 2"-        , "bbb.xx     = 6"-        , "bbb.yy     = 7.00e0"-        , "bbb.zz     = 8.00e0"-        , "bbb.ww     = 9"-        , "lol        = True"-        , "notlol     = False"-        , "yoyo.xx    = 42"-        , "yoyo.yy    = 4.50e1"-        , "yoyo.zz    = 2.00e3"-        , "yoyo.ww.xx = 2"-        , "yoyo.ww.yy = 3.00e0"-        , "yoyo.ww.zz = 4.00e0"-        , "yoyo.ww.ww = 5.00e0"-        , "ccc.one    = 1.70e1"+        [ "aaa                = 2"+        , "bbb.xx             = 6"+        , "bbb.yy             = 7.00e0"+        , "bbb.zz             = 8.00e0"+        , "bbb.bb.(x,_,_)     = True"+        , "bbb.bb.(_,x,_)     = False"+        , "bbb.bb.(_,_,x)     = False"+        , "bbb.ww             = 9"+        , "lol                = True"+        , "notlol             = False"+        , "yoyo.xx            = 42"+        , "yoyo.yy            = 4.50e1"+        , "yoyo.zz            = 2.00e3"+        , "yoyo.bb.(x,_,_)    = True"+        , "yoyo.bb.(_,x,_)    = True"+        , "yoyo.bb.(_,_,x)    = False"+        , "yoyo.ww.xx         = 2"+        , "yoyo.ww.yy         = 3.00e0"+        , "yoyo.ww.zz         = 4.00e0"+        , "yoyo.ww.bb.(x,_,_) = False"+        , "yoyo.ww.bb.(_,x,_) = True"+        , "yoyo.ww.bb.(_,_,x) = False"+        , "yoyo.ww.ww         = 5.00e0"+        , "ccc.one            = 1.70e1"         ]     y = showFlat yup True (printf "%.2e") foo