{-# 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
       , GLookup(..)
       ) where

import GHC.Generics

import Data.Int ( Int8, Int16, Int32, Int64 )
import Data.Word ( Word8, Word16, Word32, Word64 )
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
  { GASimpleEnum a -> [String]
eConstructors :: [String]
  , GASimpleEnum a -> a -> String
eToString :: a -> String
  , GASimpleEnum a -> a -> Int
eToIndex :: a -> Int
  , GASimpleEnum a -> a -> String -> Either String a
eFromString :: a -> String -> Either String a
  , GASimpleEnum a -> a -> Int -> Either String a
eFromIndex :: a -> Int -> Either String a
  }

data GAField a =
  FieldDouble (Lens' a Double)
  | FieldFloat (Lens' a Float)
  | FieldInt8 (Lens' a Int8)
  | FieldInt16 (Lens' a Int16)
  | FieldInt32 (Lens' a Int32)
  | FieldInt64 (Lens' a Int64)
  | FieldWord8 (Lens' a Word8)
  | FieldWord16 (Lens' a Word16)
  | FieldWord32 (Lens' a Word32)
  | FieldWord64 (Lens' a Word64)
  | FieldString (Lens' a String)
  | FieldUnit
  | FieldSorry -- ^ a field which is not yet supported

data GATip a =
  GATipSimpleEnum (GASimpleEnum a)
  | GATipField (GAField a)

showGAData :: String -> GAData a -> [String]
showGAData :: String -> GAData a -> [String]
showGAData String
spaces (GAData String
name GAConstructor a
constructors) =
  (String
spaces String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Data " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
name) String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
  String -> GAConstructor a -> [String]
forall a. String -> GAConstructor a -> [String]
showGAConstructor (String
spaces String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"    ") GAConstructor a
constructors

showGAConstructor :: String -> GAConstructor a -> [String]
showGAConstructor :: String -> GAConstructor a -> [String]
showGAConstructor String
spaces (GASum GASimpleEnum a
e) = [String
spaces String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (GASimpleEnum a -> [String]
forall a. GASimpleEnum a -> [String]
eConstructors GASimpleEnum a
e) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"]
showGAConstructor String
spaces (GAConstructor String
name [(Maybe String, AccessorTree a)]
fields) =
  (String
spaces String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ((Maybe String, AccessorTree a) -> [String])
-> [(Maybe String, AccessorTree a)] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String -> (Maybe String, AccessorTree a) -> [String]
forall a. String -> (Maybe String, AccessorTree a) -> [String]
showGAField (String
spaces String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"    ")) [(Maybe String, AccessorTree a)]
fields

showGAField :: String -> (Maybe String, AccessorTree a) -> [String]
showGAField :: String -> (Maybe String, AccessorTree a) -> [String]
showGAField String
spaces (Maybe String
name, Left GAField a
f) = [String
spaces String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe String -> String
showMName Maybe String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ GAField a -> String
forall a. GAField a -> String
describeGAField GAField a
f]
showGAField String
spaces (Maybe String
name, Right GAData a
field) =
  Maybe String -> String
showMName Maybe String
name String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
  String -> GAData a -> [String]
forall a. String -> GAData a -> [String]
showGAData (String
spaces String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"    ") GAData a
field

showMName :: Maybe String -> String
showMName :: Maybe String -> String
showMName (Just String
n) = String
n
showMName Maybe String
Nothing = String
"()"

instance Show (GAData a) where
  show :: GAData a -> String
show = [String] -> String
unlines ([String] -> String)
-> (GAData a -> [String]) -> GAData a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GAData a -> [String]
forall a. String -> GAData a -> [String]
showGAData String
""

-- | Return the type of field, such as "Bool", "Double", "String", etc.
describeGAField :: GAField a -> String
describeGAField :: GAField a -> String
describeGAField (FieldDouble Lens' a Double
_) = String
"Double"
describeGAField (FieldFloat Lens' a Float
_)  = String
"Float"
describeGAField (FieldInt8 Lens' a Int8
_)   = String
"Int8"
describeGAField (FieldInt16 Lens' a Int16
_)  = String
"Int16"
describeGAField (FieldInt32 Lens' a Int32
_)  = String
"Int32"
describeGAField (FieldInt64 Lens' a Int64
_)  = String
"Int64"
describeGAField (FieldWord8 Lens' a Word8
_)  = String
"Word8"
describeGAField (FieldWord16 Lens' a Word16
_) = String
"Word16"
describeGAField (FieldWord32 Lens' a Word32
_) = String
"Word32"
describeGAField (FieldWord64 Lens' a Word64
_) = String
"Word64"
describeGAField (FieldString Lens' a String
_) = String
"String"
describeGAField GAField a
FieldUnit = String
"()"
describeGAField GAField a
FieldSorry      = String
"Sorry"

-- | Returns True if the __type__ of fields is the same.
sameFieldType :: GAField a -> GAField b -> Bool
sameFieldType :: GAField a -> GAField b -> Bool
sameFieldType (FieldDouble Lens' a Double
_) (FieldDouble Lens' b Double
_) = Bool
True
sameFieldType (FieldFloat Lens' a Float
_) (FieldFloat Lens' b Float
_)   = Bool
True
sameFieldType (FieldInt8 Lens' a Int8
_) (FieldInt8 Lens' b Int8
_)     = Bool
True
sameFieldType (FieldInt16 Lens' a Int16
_) (FieldInt16 Lens' b Int16
_)   = Bool
True
sameFieldType (FieldInt32 Lens' a Int32
_) (FieldInt32 Lens' b Int32
_)   = Bool
True
sameFieldType (FieldInt64 Lens' a Int64
_) (FieldInt64 Lens' b Int64
_)   = Bool
True
sameFieldType (FieldWord8 Lens' a Word8
_) (FieldWord8 Lens' b Word8
_)   = Bool
True
sameFieldType (FieldWord16 Lens' a Word16
_) (FieldWord16 Lens' b Word16
_) = Bool
True
sameFieldType (FieldWord32 Lens' a Word32
_) (FieldWord32 Lens' b Word32
_) = Bool
True
sameFieldType (FieldWord64 Lens' a Word64
_) (FieldWord64 Lens' b Word64
_) = Bool
True
sameFieldType (FieldString Lens' a String
_) (FieldString Lens' b String
_) = Bool
True
sameFieldType GAField a
FieldUnit GAField b
FieldUnit              = Bool
True
sameFieldType GAField a
FieldSorry GAField b
FieldSorry           = Bool
True
sameFieldType (FieldDouble Lens' a Double
_)  GAField b
_              = Bool
False
sameFieldType (FieldFloat Lens' a Float
_)   GAField b
_              = Bool
False
sameFieldType (FieldInt8 Lens' a Int8
_)    GAField b
_              = Bool
False
sameFieldType (FieldInt16 Lens' a Int16
_)   GAField b
_              = Bool
False
sameFieldType (FieldInt32 Lens' a Int32
_)   GAField b
_              = Bool
False
sameFieldType (FieldInt64 Lens' a Int64
_)   GAField b
_              = Bool
False
sameFieldType (FieldWord8 Lens' a Word8
_)   GAField b
_              = Bool
False
sameFieldType (FieldWord16 Lens' a Word16
_)  GAField b
_              = Bool
False
sameFieldType (FieldWord32 Lens' a Word32
_)  GAField b
_              = Bool
False
sameFieldType (FieldWord64 Lens' a Word64
_)  GAField b
_              = Bool
False
sameFieldType (FieldString Lens' a String
_)  GAField b
_              = Bool
False
sameFieldType GAField a
FieldUnit        GAField b
_              = Bool
False
sameFieldType GAField a
FieldSorry       GAField b
_              = Bool
False

accessors :: Lookup a => AccessorTree a
accessors :: AccessorTree a
accessors = Lens' a a -> AccessorTree a
forall a b. Lookup a => Lens' b a -> AccessorTree b
toAccessorTree forall a. a -> a
Lens' a a
id

showMsgs :: [Maybe String] -> String
showMsgs :: [Maybe String] -> String
showMsgs = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." ([String] -> String)
-> ([Maybe String] -> [String]) -> [Maybe String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe String -> String) -> [Maybe String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Maybe String -> String
showMName

flatten :: AccessorTree a -> [(String, GATip a)]
flatten :: AccessorTree a -> [(String, GATip a)]
flatten = (([Maybe String], GATip a) -> (String, GATip a))
-> [([Maybe String], GATip a)] -> [(String, GATip a)]
forall a b. (a -> b) -> [a] -> [b]
map ([Maybe String], GATip a) -> (String, GATip a)
forall b. ([Maybe String], b) -> (String, b)
f ([([Maybe String], GATip a)] -> [(String, GATip a)])
-> (AccessorTree a -> [([Maybe String], GATip a)])
-> AccessorTree a
-> [(String, GATip a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AccessorTree a -> [([Maybe String], GATip a)]
forall a. AccessorTree a -> [([Maybe String], GATip a)]
flatten'
  where
    f :: ([Maybe String], b) -> (String, b)
f ([Maybe String]
x,b
y) = ([Maybe String] -> String
showMsgs [Maybe String]
x, b
y)

flatten' :: AccessorTree a -> [([Maybe String], GATip a)]
flatten' :: AccessorTree a -> [([Maybe String], GATip a)]
flatten' = [Maybe String] -> AccessorTree a -> [([Maybe String], GATip a)]
forall a.
[Maybe String] -> AccessorTree a -> [([Maybe String], GATip a)]
flattenChain []
  where
    flattenChain :: [Maybe String] -> AccessorTree a -> [([Maybe String], GATip a)]
    flattenChain :: [Maybe String] -> AccessorTree a -> [([Maybe String], GATip a)]
flattenChain [Maybe String]
msgs (Left GAField a
f) = [([Maybe String] -> [Maybe String]
forall a. [a] -> [a]
reverse [Maybe String]
msgs, GAField a -> GATip a
forall a. GAField a -> GATip a
GATipField GAField a
f)]
    flattenChain [Maybe String]
msgs (Right (GAData String
_ (GASum GASimpleEnum a
simpleEnum))) = [([Maybe String] -> [Maybe String]
forall a. [a] -> [a]
reverse [Maybe String]
msgs, GASimpleEnum a -> GATip a
forall a. GASimpleEnum a -> GATip a
GATipSimpleEnum GASimpleEnum a
simpleEnum)]
    flattenChain [Maybe String]
msgs (Right (GAData String
_ (GAConstructor String
_ [(Maybe String, AccessorTree a)]
trees))) = ((Maybe String, AccessorTree a) -> [([Maybe String], GATip a)])
-> [(Maybe String, AccessorTree a)] -> [([Maybe String], GATip a)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Maybe String, AccessorTree a) -> [([Maybe String], GATip a)]
forall a.
(Maybe String, AccessorTree a) -> [([Maybe String], GATip a)]
f [(Maybe String, AccessorTree a)]
trees
      where
        f :: (Maybe String, AccessorTree a) -> [([Maybe String], GATip a)]
        f :: (Maybe String, AccessorTree a) -> [([Maybe String], GATip a)]
f (Maybe String
name, AccessorTree a
tree) = [Maybe String] -> AccessorTree a -> [([Maybe String], GATip a)]
forall a.
[Maybe String] -> AccessorTree a -> [([Maybe String], GATip a)]
flattenChain (Maybe String
nameMaybe String -> [Maybe String] -> [Maybe String]
forall a. a -> [a] -> [a]
:[Maybe String]
msgs) AccessorTree a
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 Lens' b a
lens0 = Lens' b (Rep a Any) -> AccessorTree b
forall (f :: * -> *) b a.
GLookup f =>
Lens' b (f a) -> AccessorTree b
gtoAccessorTree ((a -> f a) -> b -> f b
Lens' b a
lens0 ((a -> f a) -> b -> f b)
-> ((Rep a Any -> f (Rep a Any)) -> a -> f a)
-> (Rep a Any -> f (Rep a Any))
-> b
-> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rep a Any -> f (Rep a Any)) -> a -> f a
forall p. Lens' a (Rep a p)
repLens)
    where
      repLens :: Lens' a (Rep a p)
      repLens :: (Rep a p -> f (Rep a p)) -> a -> f a
repLens Rep a p -> f (Rep a p)
f a
y = (Rep a p -> a) -> f (Rep a p) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rep a p -> a
forall a x. Generic a => Rep a x -> a
to (Rep a p -> f (Rep a p)
f (a -> Rep a p
forall a x. Generic a => a -> Rep a x
from a
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 :: Lens' b (Rec0 f p) -> AccessorTree b
gtoAccessorTree Lens' b (Rec0 f p)
lens0 = Lens' b f -> AccessorTree b
forall a b. Lookup a => Lens' b a -> AccessorTree b
toAccessorTree ((Rec0 f p -> f (Rec0 f p)) -> b -> f b
Lens' b (Rec0 f p)
lens0 ((Rec0 f p -> f (Rec0 f p)) -> b -> f b)
-> ((f -> f f) -> Rec0 f p -> f (Rec0 f p))
-> (f -> f f)
-> b
-> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f -> f f) -> Rec0 f p -> f (Rec0 f p)
forall a. Lens' (Rec0 f a) f
rec0Lens)
    where
      rec0Lens :: Lens' (Rec0 f a) f
      rec0Lens :: (f -> f f) -> Rec0 f a -> f (Rec0 f a)
rec0Lens f -> f f
f Rec0 f a
y = (f -> Rec0 f a) -> f f -> f (Rec0 f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f -> Rec0 f a
forall k i c (p :: k). c -> K1 i c p
K1 (f -> f f
f (Rec0 f a -> f
forall i c k (p :: k). K1 i c p -> c
unK1 Rec0 f a
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 :: Prism' b (C1 c U1 p) -> [(String, b, b -> Bool)]
gtoSimpleEnum Prism' b (C1 c U1 p)
pr = [(String
cname, b
thisOne, b -> Bool
isThisOne)]
    where
      thisOne :: b
      thisOne :: b
thisOne = APrism b b (C1 c U1 p) (C1 c U1 p)
-> ((C1 c U1 p -> b) -> (b -> Either b (C1 c U1 p)) -> b) -> b
forall s t a b r.
APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
withPrism APrism b b (C1 c U1 p) (C1 c U1 p)
Prism' b (C1 c U1 p)
pr (((C1 c U1 p -> b) -> (b -> Either b (C1 c U1 p)) -> b) -> b)
-> ((C1 c U1 p -> b) -> (b -> Either b (C1 c U1 p)) -> b) -> b
forall a b. (a -> b) -> a -> b
$ \C1 c U1 p -> b
f b -> Either b (C1 c U1 p)
_ -> C1 c U1 p -> b
f (U1 p -> C1 c U1 p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 U1 p
forall k (p :: k). U1 p
U1 :: C1 c U1 p)

      isThisOne :: b -> Bool
      isThisOne :: b -> Bool
isThisOne b
b = case Getting (First (C1 c U1 p)) b (C1 c U1 p) -> b -> Maybe (C1 c U1 p)
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting (First (C1 c U1 p)) b (C1 c U1 p)
Prism' b (C1 c U1 p)
pr b
b :: Maybe (C1 c U1 p) of
        Maybe (C1 c U1 p)
Nothing -> Bool
False
        Just C1 c U1 p
_ -> Bool
True

      cname :: String
cname = M1 C c Any p -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName M1 C c Any p
forall (a :: * -> *). C1 c a p
conError

      conError :: C1 c a p
      conError :: C1 c a p
conError = String -> C1 c a p
forall a. HasCallStack => String -> a
error (String -> C1 c a p) -> String -> C1 c a p
forall a b. (a -> b) -> a -> b
$ String
"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 :: Prism' b ((:+:) c1 c2 p) -> [(String, b, b -> Bool)]
gtoSimpleEnum Prism' b ((:+:) c1 c2 p)
pr0 = [(String, b, b -> Bool)]
c1s [(String, b, b -> Bool)]
-> [(String, b, b -> Bool)] -> [(String, b, b -> Bool)]
forall a. [a] -> [a] -> [a]
++ [(String, b, b -> Bool)]
c2s
    where
      c1s :: [(String, b, b -> Bool)]
c1s = Prism' b (c1 p) -> [(String, b, b -> Bool)]
forall (a :: * -> *) b p.
GEnum a =>
Prism' b (a p) -> [(String, b, b -> Bool)]
gtoSimpleEnum ((p ((:+:) c1 c2 p) (f ((:+:) c1 c2 p)) -> p b (f b)
Prism' b ((:+:) c1 c2 p)
pr0 (p ((:+:) c1 c2 p) (f ((:+:) c1 c2 p)) -> p b (f b))
-> (p (c1 p) (f (c1 p)) -> p ((:+:) c1 c2 p) (f ((:+:) c1 c2 p)))
-> p (c1 p) (f (c1 p))
-> p b (f b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p (c1 p) (f (c1 p)) -> p ((:+:) c1 c2 p) (f ((:+:) c1 c2 p))
Prism' ((:+:) c1 c2 p) (c1 p)
leftPrism) :: Prism' b (c1 p))
      c2s :: [(String, b, b -> Bool)]
c2s = Prism' b (c2 p) -> [(String, b, b -> Bool)]
forall (a :: * -> *) b p.
GEnum a =>
Prism' b (a p) -> [(String, b, b -> Bool)]
gtoSimpleEnum ((p ((:+:) c1 c2 p) (f ((:+:) c1 c2 p)) -> p b (f b)
Prism' b ((:+:) c1 c2 p)
pr0 (p ((:+:) c1 c2 p) (f ((:+:) c1 c2 p)) -> p b (f b))
-> (p (c2 p) (f (c2 p)) -> p ((:+:) c1 c2 p) (f ((:+:) c1 c2 p)))
-> p (c2 p) (f (c2 p))
-> p b (f b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p (c2 p) (f (c2 p)) -> p ((:+:) c1 c2 p) (f ((:+:) c1 c2 p))
Prism' ((:+:) c1 c2 p) (c2 p)
rightPrism) :: Prism' b (c2 p))

      leftPrism :: Prism' ((c1 :+: c2) p) (c1 p)
      leftPrism :: p (c1 p) (f (c1 p)) -> p ((:+:) c1 c2 p) (f ((:+:) c1 c2 p))
leftPrism = (c1 p -> (:+:) c1 c2 p)
-> ((:+:) c1 c2 p -> Either ((:+:) c1 c2 p) (c1 p))
-> Prism' ((:+:) c1 c2 p) (c1 p)
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism c1 p -> (:+:) c1 c2 p
forall (f :: * -> *) p (g :: * -> *). f p -> (:+:) f g p
remitter (:+:) c1 c2 p -> Either ((:+:) c1 c2 p) (c1 p)
forall (f :: * -> *) (g :: * -> *) p.
(:+:) f g p -> Either ((:+:) f g p) (f p)
reviewer
        where
          remitter :: f p -> (:+:) f g p
remitter = f p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1
          reviewer :: (:+:) f g p -> Either ((:+:) f g p) (f p)
reviewer (L1 f p
l) = f p -> Either ((:+:) f g p) (f p)
forall a b. b -> Either a b
Right f p
l
          reviewer (:+:) f g p
x = (:+:) f g p -> Either ((:+:) f g p) (f p)
forall a b. a -> Either a b
Left (:+:) f g p
x

      rightPrism :: Prism' ((c1 :+: c2) p) (c2 p)
      rightPrism :: p (c2 p) (f (c2 p)) -> p ((:+:) c1 c2 p) (f ((:+:) c1 c2 p))
rightPrism = (c2 p -> (:+:) c1 c2 p)
-> ((:+:) c1 c2 p -> Either ((:+:) c1 c2 p) (c2 p))
-> Prism' ((:+:) c1 c2 p) (c2 p)
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism c2 p -> (:+:) c1 c2 p
forall (g :: * -> *) p (f :: * -> *). g p -> (:+:) f g p
remitter (:+:) c1 c2 p -> Either ((:+:) c1 c2 p) (c2 p)
forall (f :: * -> *) (g :: * -> *) p.
(:+:) f g p -> Either ((:+:) f g p) (g p)
reviewer
        where
          remitter :: g p -> (:+:) f g p
remitter = g p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1
          reviewer :: (:+:) f g p -> Either ((:+:) f g p) (g p)
reviewer (R1 g p
l) = g p -> Either ((:+:) f g p) (g p)
forall a b. b -> Either a b
Right g p
l
          reviewer (:+:) f g p
x = (:+:) f g p -> Either ((:+:) f g p) (g p)
forall a b. a -> Either a b
Left (:+:) f g p
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 :: Lens' b (D1 d (c1 :+: c2) p) -> AccessorTree b
gtoAccessorTree Lens' b (D1 d (c1 :+: c2) p)
lens0 = GAData b -> AccessorTree b
forall a b. b -> Either a b
Right (GAData b -> AccessorTree b) -> GAData b -> AccessorTree b
forall a b. (a -> b) -> a -> b
$ String -> GAConstructor b -> GAData b
forall a. String -> GAConstructor a -> GAData a
GAData (D1 d (c1 :+: c2) p -> String
forall k (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> String
datatypeName D1 d (c1 :+: c2) p
datatypeError) GAConstructor b
constructor
    where
      datatypeError :: D1 d (c1 :+: c2) p
      datatypeError :: D1 d (c1 :+: c2) p
datatypeError = String -> D1 d (c1 :+: c2) p
forall a. HasCallStack => String -> a
error (String -> D1 d (c1 :+: c2) p) -> String -> D1 d (c1 :+: c2) p
forall a b. (a -> b) -> a -> b
$ String
"generic-accessors: datatypeName should never access data"

      constructor :: GAConstructor b
      constructor :: GAConstructor b
constructor =
        GASimpleEnum b -> GAConstructor b
forall a. GASimpleEnum a -> GAConstructor a
GASum
        GASimpleEnum :: forall a.
[String]
-> (a -> String)
-> (a -> Int)
-> (a -> String -> Either String a)
-> (a -> Int -> Either String a)
-> GASimpleEnum a
GASimpleEnum
        { eConstructors :: [String]
eConstructors = [String]
options
        , eToString :: b -> String
eToString = b -> String
toString
        , eToIndex :: b -> Int
eToIndex = b -> Int
toIndex
        , eFromIndex :: b -> Int -> Either String b
eFromIndex = b -> Int -> Either String b
fromIndex
        , eFromString :: b -> String -> Either String b
eFromString = b -> String -> Either String b
fromString
        }
        where
          options :: [String]
options = ((String, (:+:) c1 c2 p, (:+:) c1 c2 p -> Bool) -> String)
-> [(String, (:+:) c1 c2 p, (:+:) c1 c2 p -> Bool)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, (:+:) c1 c2 p, (:+:) c1 c2 p -> Bool) -> String
forall a b c. (a, b, c) -> a
fst3 [(String, (:+:) c1 c2 p, (:+:) c1 c2 p -> Bool)]
simpleEnums
            where
              fst3 :: (a, b, c) -> a
fst3 (a
x,b
_,c
_) = a
x

          fromIndex :: b -> Int -> Either String b
fromIndex b
x Int
k
            | Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 =
                String -> Either String b
forall a b. a -> Either a b
Left (String -> Either String b) -> String -> Either String b
forall a b. (a -> b) -> a -> b
$
                String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"generic-accessors: Error converting Int to Enum: requested negative index (%d)" Int
k
            | Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
options =
                String -> Either String b
forall a b. a -> Either a b
Left (String -> Either String b) -> String -> Either String b
forall a b. (a -> b) -> a -> b
$
                String
"generic-accessors: Error converting Int to Enum.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                String -> Int -> Int -> String
forall r. PrintfType r => String -> r
printf String
"Requested index %d but there are only %d options." Int
k ([(String, (:+:) c1 c2 p, (:+:) c1 c2 p -> Bool)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, (:+:) c1 c2 p, (:+:) c1 c2 p -> Bool)]
simpleEnums)
            | Bool
otherwise = b -> Either String b
forall a b. b -> Either a b
Right (b -> Either String b) -> b -> Either String b
forall a b. (a -> b) -> a -> b
$ ((D1 d (c1 :+: c2) p -> Identity (D1 d (c1 :+: c2) p))
-> b -> Identity b
Lens' b (D1 d (c1 :+: c2) p)
lens0 ((D1 d (c1 :+: c2) p -> Identity (D1 d (c1 :+: c2) p))
 -> b -> Identity b)
-> ((Int -> Identity Int)
    -> D1 d (c1 :+: c2) p -> Identity (D1 d (c1 :+: c2) p))
-> (Int -> Identity Int)
-> b
-> Identity b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((:+:) c1 c2 p -> Identity ((:+:) c1 c2 p))
-> D1 d (c1 :+: c2) p -> Identity (D1 d (c1 :+: c2) p)
forall i (c :: Meta) (f :: * -> *) p. Lens' (M1 i c f p) (f p)
m1Lens (((:+:) c1 c2 p -> Identity ((:+:) c1 c2 p))
 -> D1 d (c1 :+: c2) p -> Identity (D1 d (c1 :+: c2) p))
-> ((Int -> Identity Int)
    -> (:+:) c1 c2 p -> Identity ((:+:) c1 c2 p))
-> (Int -> Identity Int)
-> D1 d (c1 :+: c2) p
-> Identity (D1 d (c1 :+: c2) p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Identity Int) -> (:+:) c1 c2 p -> Identity ((:+:) c1 c2 p)
Lens' ((:+:) c1 c2 p) Int
intLens ((Int -> Identity Int) -> b -> Identity b) -> Int -> b -> b
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Int
k) b
x

          fromString :: b -> String -> Either String b
fromString b
x String
name = Int -> [String] -> Either String b
fromString' Int
0 [String]
options
            where
              fromString' :: Int -> [String] -> Either String b
fromString' Int
k (String
opt:[String]
opts)
                | String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
opt = b -> Int -> Either String b
fromIndex b
x Int
k
                | Bool
otherwise = Int -> [String] -> Either String b
fromString' (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [String]
opts
              fromString' Int
_ [] =
                String -> Either String b
forall a b. a -> Either a b
Left (String -> Either String b) -> String -> Either String b
forall a b. (a -> b) -> a -> b
$
                String
"generic-accessors: Error converting from String to Enum: "
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"is not one of the constructors."

          toIndex :: b -> Int
toIndex b
x = b
x b -> Getting Int b Int -> Int
forall s a. s -> Getting a s a -> a
^. ((D1 d (c1 :+: c2) p -> Const Int (D1 d (c1 :+: c2) p))
-> b -> Const Int b
Lens' b (D1 d (c1 :+: c2) p)
lens0 ((D1 d (c1 :+: c2) p -> Const Int (D1 d (c1 :+: c2) p))
 -> b -> Const Int b)
-> ((Int -> Const Int Int)
    -> D1 d (c1 :+: c2) p -> Const Int (D1 d (c1 :+: c2) p))
-> Getting Int b Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((:+:) c1 c2 p -> Const Int ((:+:) c1 c2 p))
-> D1 d (c1 :+: c2) p -> Const Int (D1 d (c1 :+: c2) p)
forall i (c :: Meta) (f :: * -> *) p. Lens' (M1 i c f p) (f p)
m1Lens (((:+:) c1 c2 p -> Const Int ((:+:) c1 c2 p))
 -> D1 d (c1 :+: c2) p -> Const Int (D1 d (c1 :+: c2) p))
-> ((Int -> Const Int Int)
    -> (:+:) c1 c2 p -> Const Int ((:+:) c1 c2 p))
-> (Int -> Const Int Int)
-> D1 d (c1 :+: c2) p
-> Const Int (D1 d (c1 :+: c2) p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const Int Int)
-> (:+:) c1 c2 p -> Const Int ((:+:) c1 c2 p)
Lens' ((:+:) c1 c2 p) Int
intLens)
          toString :: b -> String
toString b
x = case [String] -> Int -> Maybe String
forall a. [a] -> Int -> Maybe a
safeIndex [String]
options Int
index of
            Just String
r -> String
r
            Maybe String
Nothing -> String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
                       [ String
"generic-accessors: eToString: the \"impossible\" happened"
                       , String -> Int -> Int -> String
forall r. PrintfType r => String -> r
printf String
"Enum is out of bounds (index %d, length %d)." Int
index ([String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
options)
                       ]
            where
              index :: Int
index = b -> Int
toIndex b
x

      simpleEnums :: [(String, (c1 :+: c2) p, (c1 :+: c2) p -> Bool)]
      simpleEnums :: [(String, (:+:) c1 c2 p, (:+:) c1 c2 p -> Bool)]
simpleEnums = Prism' ((:+:) c1 c2 p) ((:+:) c1 c2 p)
-> [(String, (:+:) c1 c2 p, (:+:) c1 c2 p -> Bool)]
forall (a :: * -> *) b p.
GEnum a =>
Prism' b (a p) -> [(String, b, b -> Bool)]
gtoSimpleEnum forall a. a -> a
Prism' ((:+:) c1 c2 p) ((:+:) c1 c2 p)
id

      intLens :: Lens' ((c1 :+: c2) p) Int
      intLens :: (Int -> f Int) -> (:+:) c1 c2 p -> f ((:+:) c1 c2 p)
intLens Int -> f Int
f (:+:) c1 c2 p
y = (Int -> (:+:) c1 c2 p) -> f Int -> f ((:+:) c1 c2 p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> (:+:) c1 c2 p
fromInt' (Int -> f Int
f ((:+:) c1 c2 p -> Int
toInt (:+:) c1 c2 p
y))

      fromInt' :: Int -> (c1 :+: c2) p
      fromInt' :: Int -> (:+:) c1 c2 p
fromInt' Int
k = case Int -> Either String ((:+:) c1 c2 p)
fromInt Int
k of
        Right (:+:) c1 c2 p
r -> (:+:) c1 c2 p
r
        Left String
e -> String -> (:+:) c1 c2 p
forall a. HasCallStack => String -> a
error String
e

      fromInt :: Int -> Either String ((c1 :+: c2) p)
      fromInt :: Int -> Either String ((:+:) c1 c2 p)
fromInt Int
k = case [(String, (:+:) c1 c2 p, (:+:) c1 c2 p -> Bool)]
-> Int -> Maybe (String, (:+:) c1 c2 p, (:+:) c1 c2 p -> Bool)
forall a. [a] -> Int -> Maybe a
safeIndex [(String, (:+:) c1 c2 p, (:+:) c1 c2 p -> Bool)]
simpleEnums Int
k of
        Maybe (String, (:+:) c1 c2 p, (:+:) c1 c2 p -> Bool)
Nothing -> String -> Either String ((:+:) c1 c2 p)
forall a b. a -> Either a b
Left (String -> Either String ((:+:) c1 c2 p))
-> String -> Either String ((:+:) c1 c2 p)
forall a b. (a -> b) -> a -> b
$
                   String
"generic-accessors:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                   String
"Error converting Int to Enum.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                   String -> Int -> Int -> String
forall r. PrintfType r => String -> r
printf String
"Requested index %d but there are only %d options." Int
k ([(String, (:+:) c1 c2 p, (:+:) c1 c2 p -> Bool)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, (:+:) c1 c2 p, (:+:) c1 c2 p -> Bool)]
simpleEnums)
        Just (String
_, (:+:) c1 c2 p
x, (:+:) c1 c2 p -> Bool
_) -> (:+:) c1 c2 p -> Either String ((:+:) c1 c2 p)
forall a b. b -> Either a b
Right (:+:) c1 c2 p
x

      toInt :: (c1 :+: c2) p -> Int
      toInt :: (:+:) c1 c2 p -> Int
toInt (:+:) c1 c2 p
x = Int -> [(String, (:+:) c1 c2 p, (:+:) c1 c2 p -> Bool)] -> Int
forall t a b. Num t => t -> [(a, b, (:+:) c1 c2 p -> Bool)] -> t
toInt' Int
0 [(String, (:+:) c1 c2 p, (:+:) c1 c2 p -> Bool)]
simpleEnums
        where
          toInt' :: t -> [(a, b, (:+:) c1 c2 p -> Bool)] -> t
toInt' t
k ((a
_, b
_, (:+:) c1 c2 p -> Bool
isVal):[(a, b, (:+:) c1 c2 p -> Bool)]
others)
            | (:+:) c1 c2 p -> Bool
isVal (:+:) c1 c2 p
x = t
k
            | Bool
otherwise = t -> [(a, b, (:+:) c1 c2 p -> Bool)] -> t
toInt' (t
kt -> t -> t
forall a. Num a => a -> a -> a
+t
1) [(a, b, (:+:) c1 c2 p -> Bool)]
others
          toInt' t
_ [] =
            String -> t
forall a. HasCallStack => String -> a
error (String -> t) -> String -> t
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
            [ String
"generic-accessors:"
            , String
"The \"impossible\" happened converting Enum to Int."
            , String
"No enum matched the provided one."
            ]

      safeIndex :: [a] -> Int -> Maybe a
      safeIndex :: [a] -> Int -> Maybe a
safeIndex (a
x:[a]
_) Int
0 = a -> Maybe a
forall a. a -> Maybe a
Just a
x
      safeIndex (a
_:[a]
xs) Int
k = [a] -> Int -> Maybe a
forall a. [a] -> Int -> Maybe a
safeIndex [a]
xs (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
      safeIndex [] Int
_ = Maybe a
forall a. Maybe a
Nothing

m1Lens :: Lens' (M1 i c f p) (f p)
m1Lens :: (f p -> f (f p)) -> M1 i c f p -> f (M1 i c f p)
m1Lens f p -> f (f p)
f M1 i c f p
y = (f p -> M1 i c f p) -> f (f p) -> f (M1 i c f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f p -> M1 i c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> f (f p)
f (M1 i c f p -> f p
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 M1 i c f p
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 :: Lens' b (D1 d (C1 c a) p) -> AccessorTree b
gtoAccessorTree Lens' b (D1 d (C1 c a) p)
lens0 = GAData b -> AccessorTree b
forall a b. b -> Either a b
Right (GAData b -> AccessorTree b) -> GAData b -> AccessorTree b
forall a b. (a -> b) -> a -> b
$ String -> GAConstructor b -> GAData b
forall a. String -> GAConstructor a -> GAData a
GAData (D1 d (C1 c a) p -> String
forall k (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> String
datatypeName D1 d (C1 c a) p
datatypeError) GAConstructor b
constructor
    where
      datatypeError :: D1 d (C1 c a) p
      datatypeError :: D1 d (C1 c a) p
datatypeError = String -> D1 d (C1 c a) p
forall a. HasCallStack => String -> a
error (String -> D1 d (C1 c a) p) -> String -> D1 d (C1 c a) p
forall a b. (a -> b) -> a -> b
$ String
"generic-accessors: datatypeName should never access data"

      constructor :: GAConstructor b
      constructor :: GAConstructor b
constructor = Lens' b (C1 c a p) -> GAConstructor b
forall (c :: Meta) b (a :: * -> *) p.
(Constructor c, GLookupS a) =>
Lens' b (C1 c a p) -> GAConstructor b
gtoAccessorTreeC ((D1 d (C1 c a) p -> f (D1 d (C1 c a) p)) -> b -> f b
Lens' b (D1 d (C1 c a) p)
lens0 ((D1 d (C1 c a) p -> f (D1 d (C1 c a) p)) -> b -> f b)
-> ((C1 c a p -> f (C1 c a p))
    -> D1 d (C1 c a) p -> f (D1 d (C1 c a) p))
-> (C1 c a p -> f (C1 c a p))
-> b
-> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (C1 c a p -> f (C1 c a p))
-> D1 d (C1 c a) p -> f (D1 d (C1 c a) p)
forall i (c :: Meta) (f :: * -> *) p. Lens' (M1 i c f p) (f p)
m1Lens)

gtoAccessorTreeC :: forall c b a p . (Constructor c, GLookupS a) => Lens' b (C1 c a p) -> GAConstructor b
gtoAccessorTreeC :: Lens' b (C1 c a p) -> GAConstructor b
gtoAccessorTreeC Lens' b (C1 c a p)
lens0 = String -> [(Maybe String, AccessorTree b)] -> GAConstructor b
forall a.
String -> [(Maybe String, AccessorTree a)] -> GAConstructor a
GAConstructor (C1 c a p -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName C1 c a p
conError) (Lens' b (a p) -> [(Maybe String, AccessorTree b)]
forall (f :: * -> *) b a.
GLookupS f =>
Lens' b (f a) -> [(Maybe String, AccessorTree b)]
gtoAccessorTreeS ((C1 c a p -> f (C1 c a p)) -> b -> f b
Lens' b (C1 c a p)
lens0 ((C1 c a p -> f (C1 c a p)) -> b -> f b)
-> ((a p -> f (a p)) -> C1 c a p -> f (C1 c a p))
-> (a p -> f (a p))
-> b
-> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a p -> f (a p)) -> C1 c a p -> f (C1 c a p)
forall i (c :: Meta) (f :: * -> *) p. Lens' (M1 i c f p) (f p)
m1Lens))
  where
    conError :: C1 c a p
    conError :: C1 c a p
conError = String -> C1 c a p
forall a. HasCallStack => String -> a
error (String -> C1 c a p) -> String -> C1 c a p
forall a b. (a -> b) -> a -> b
$ String
"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 :: Lens' b (S1 s a p) -> [(Maybe String, AccessorTree b)]
gtoAccessorTreeS Lens' b (S1 s a p)
lens0 = [(Maybe String
selname, Lens' b (a p) -> AccessorTree b
forall (f :: * -> *) b a.
GLookup f =>
Lens' b (f a) -> AccessorTree b
gtoAccessorTree ((S1 s a p -> f (S1 s a p)) -> b -> f b
Lens' b (S1 s a p)
lens0 ((S1 s a p -> f (S1 s a p)) -> b -> f b)
-> ((a p -> f (a p)) -> S1 s a p -> f (S1 s a p))
-> (a p -> f (a p))
-> b
-> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a p -> f (a p)) -> S1 s a p -> f (S1 s a p)
forall i (c :: Meta) (f :: * -> *) p. Lens' (M1 i c f p) (f p)
m1Lens))]
    where
      selname :: Maybe String
selname = case M1 S s a Any -> String
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName M1 S s a Any
forall p. S1 s a p
selError of
        String
"" -> Maybe String
forall a. Maybe a
Nothing
        String
y -> String -> Maybe String
forall a. a -> Maybe a
Just String
y

      selError :: S1 s a p
      selError :: S1 s a p
selError = String -> S1 s a p
forall a. HasCallStack => String -> a
error (String -> S1 s a p) -> String -> S1 s a p
forall a b. (a -> b) -> a -> b
$ String
"generic-accessors: selName should never access data"

instance GLookupS U1 where
  gtoAccessorTreeS :: Lens' b (U1 p) -> [(Maybe String, AccessorTree b)]
  gtoAccessorTreeS :: Lens' b (U1 p) -> [(Maybe String, AccessorTree b)]
gtoAccessorTreeS Lens' b (U1 p)
_ = []

instance (GLookupS f, GLookupS g) => GLookupS (f :*: g) where
  gtoAccessorTreeS :: Lens' b ((f :*: g) p) -> [(Maybe String, AccessorTree b)]
  gtoAccessorTreeS :: Lens' b ((:*:) f g p) -> [(Maybe String, AccessorTree b)]
gtoAccessorTreeS Lens' b ((:*:) f g p)
lens0 = [(Maybe String, AccessorTree b)]
tf [(Maybe String, AccessorTree b)]
-> [(Maybe String, AccessorTree b)]
-> [(Maybe String, AccessorTree b)]
forall a. [a] -> [a] -> [a]
++ [(Maybe String, AccessorTree b)]
tg
    where
      tf :: [(Maybe String, AccessorTree b)]
tf = Lens' b (f p) -> [(Maybe String, AccessorTree b)]
forall (f :: * -> *) b a.
GLookupS f =>
Lens' b (f a) -> [(Maybe String, AccessorTree b)]
gtoAccessorTreeS (((:*:) f g p -> f ((:*:) f g p)) -> b -> f b
Lens' b ((:*:) f g p)
lens0 (((:*:) f g p -> f ((:*:) f g p)) -> b -> f b)
-> ((f p -> f (f p)) -> (:*:) f g p -> f ((:*:) f g p))
-> (f p -> f (f p))
-> b
-> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f p -> f (f p)) -> (:*:) f g p -> f ((:*:) f g p)
forall a. Lens' ((:*:) f g a) (f a)
leftLens)
      tg :: [(Maybe String, AccessorTree b)]
tg = Lens' b (g p) -> [(Maybe String, AccessorTree b)]
forall (f :: * -> *) b a.
GLookupS f =>
Lens' b (f a) -> [(Maybe String, AccessorTree b)]
gtoAccessorTreeS (((:*:) f g p -> f ((:*:) f g p)) -> b -> f b
Lens' b ((:*:) f g p)
lens0 (((:*:) f g p -> f ((:*:) f g p)) -> b -> f b)
-> ((g p -> f (g p)) -> (:*:) f g p -> f ((:*:) f g p))
-> (g p -> f (g p))
-> b
-> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (g p -> f (g p)) -> (:*:) f g p -> f ((:*:) f g p)
forall a. Lens' ((:*:) f g a) (g a)
rightLens)

      leftLens ::  Lens' ((f :*: g) a) (f a)
      leftLens :: (f a -> f (f a)) -> (:*:) f g a -> f ((:*:) f g a)
leftLens  f a -> f (f a)
f (f a
x :*: g a
y) = (f a -> (:*:) f g a) -> f (f a) -> f ((:*:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\f a
x' -> f a
x' f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g a
y ) (f a -> f (f a)
f f a
x)

      rightLens :: Lens' ((f :*: g) a) (g a)
      rightLens :: (g a -> f (g a)) -> (:*:) f g a -> f ((:*:) f g a)
rightLens g a -> f (g a)
f (f a
x :*: g a
y) = (g a -> (:*:) f g a) -> f (g a) -> f ((:*:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\g a
y' -> f a
x  f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g a
y') (g a -> f (g a)
f g a
y)


showAccTrees :: (Double -> String) -> a
                -> [(Maybe String, AccessorTree a)] -> String
                -> [String]
showAccTrees :: (Double -> String)
-> a -> [(Maybe String, AccessorTree a)] -> String -> [String]
showAccTrees Double -> String
show' a
x [(Maybe String, AccessorTree a)]
trees String
spaces = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String]]
cs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
spaces String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}"]
  where
    cs :: [[String]]
cs = ((Maybe String, AccessorTree a) -> String -> [String])
-> [(Maybe String, AccessorTree a)] -> [String] -> [[String]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((Double -> String)
-> a
-> String
-> (Maybe String, AccessorTree a)
-> String
-> [String]
forall a.
(Double -> String)
-> a
-> String
-> (Maybe String, AccessorTree a)
-> String
-> [String]
showRecordField Double -> String
show' a
x String
spaces) [(Maybe String, AccessorTree a)]
trees (String
"{ " String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
forall a. a -> [a]
repeat String
", ")

showFieldVal :: GAField a -> (Double -> String) -> a -> String
showFieldVal :: GAField a -> (Double -> String) -> a -> String
showFieldVal (FieldInt8 Lens' a Int8
lens) Double -> String
_ a
x = Int8 -> String
forall a. Show a => a -> String
show (a
x a -> Getting Int8 a Int8 -> Int8
forall s a. s -> Getting a s a -> a
^. Getting Int8 a Int8
Lens' a Int8
lens)
showFieldVal (FieldInt16 Lens' a Int16
lens) Double -> String
_ a
x = Int16 -> String
forall a. Show a => a -> String
show (a
x a -> Getting Int16 a Int16 -> Int16
forall s a. s -> Getting a s a -> a
^. Getting Int16 a Int16
Lens' a Int16
lens)
showFieldVal (FieldInt32 Lens' a Int32
lens) Double -> String
_ a
x = Int32 -> String
forall a. Show a => a -> String
show (a
x a -> Getting Int32 a Int32 -> Int32
forall s a. s -> Getting a s a -> a
^. Getting Int32 a Int32
Lens' a Int32
lens)
showFieldVal (FieldInt64 Lens' a Int64
lens) Double -> String
_ a
x = Int64 -> String
forall a. Show a => a -> String
show (a
x a -> Getting Int64 a Int64 -> Int64
forall s a. s -> Getting a s a -> a
^. Getting Int64 a Int64
Lens' a Int64
lens)
showFieldVal (FieldWord8 Lens' a Word8
lens) Double -> String
_ a
x = Word8 -> String
forall a. Show a => a -> String
show (a
x a -> Getting Word8 a Word8 -> Word8
forall s a. s -> Getting a s a -> a
^. Getting Word8 a Word8
Lens' a Word8
lens)
showFieldVal (FieldWord16 Lens' a Word16
lens) Double -> String
_ a
x = Word16 -> String
forall a. Show a => a -> String
show (a
x a -> Getting Word16 a Word16 -> Word16
forall s a. s -> Getting a s a -> a
^. Getting Word16 a Word16
Lens' a Word16
lens)
showFieldVal (FieldWord32 Lens' a Word32
lens) Double -> String
_ a
x = Word32 -> String
forall a. Show a => a -> String
show (a
x a -> Getting Word32 a Word32 -> Word32
forall s a. s -> Getting a s a -> a
^. Getting Word32 a Word32
Lens' a Word32
lens)
showFieldVal (FieldWord64 Lens' a Word64
lens) Double -> String
_ a
x = Word64 -> String
forall a. Show a => a -> String
show (a
x a -> Getting Word64 a Word64 -> Word64
forall s a. s -> Getting a s a -> a
^. Getting Word64 a Word64
Lens' a Word64
lens)
showFieldVal (FieldDouble Lens' a Double
lens) Double -> String
show' a
x = Double -> String
show' (a
x a -> Getting Double a Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double a Double
Lens' a Double
lens)
showFieldVal (FieldFloat Lens' a Float
lens) Double -> String
show' a
x = Double -> String
show' (Float -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (a
x a -> Getting Float a Float -> Float
forall s a. s -> Getting a s a -> a
^. Getting Float a Float
Lens' a Float
lens))
showFieldVal (FieldString Lens' a String
lens) Double -> String
_ a
x = a
x a -> Getting String a String -> String
forall s a. s -> Getting a s a -> a
^. Getting String a String
Lens' a String
lens
showFieldVal GAField a
FieldUnit Double -> String
_ a
_ = String
"()"
showFieldVal GAField a
FieldSorry Double -> String
_ a
_ = String
""

showTipVal :: GATip a -> (Double -> String) -> a -> String
showTipVal :: GATip a -> (Double -> String) -> a -> String
showTipVal (GATipField GAField a
f) Double -> String
sh a
x = GAField a -> (Double -> String) -> a -> String
forall a. GAField a -> (Double -> String) -> a -> String
showFieldVal GAField a
f Double -> String
sh a
x
showTipVal (GATipSimpleEnum GASimpleEnum a
simpleEnum) Double -> String
_ a
x = GASimpleEnum a -> a -> String
forall a. GASimpleEnum a -> a -> String
eToString GASimpleEnum a
simpleEnum a
x

showRecordField :: (Double -> String) -> a -> String -> (Maybe String, AccessorTree a) -> String -> [String]
showRecordField :: (Double -> String)
-> a
-> String
-> (Maybe String, AccessorTree a)
-> String
-> [String]
showRecordField Double -> String
show' a
x String
spaces (Maybe String
getterName, (Left GAField a
field)) String
prefix =
  [String
spaces String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe String -> String
showMName Maybe String
getterName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ GAField a -> (Double -> String) -> a -> String
forall a. GAField a -> (Double -> String) -> a -> String
showFieldVal GAField a
field Double -> String
show' a
x]
showRecordField Double -> String
_ a
x String
spaces (Maybe String
getterName, Right (GAData String
_ (GASum GASimpleEnum a
simpleEnum))) String
prefix =
  [String
spaces String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe String -> String
showMName Maybe String
getterName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ GASimpleEnum a -> a -> String
forall a. GASimpleEnum a -> a -> String
eToString GASimpleEnum a
simpleEnum a
x]
showRecordField Double -> String
show' a
x String
spaces (Maybe String
getterName, Right (GAData String
_ (GAConstructor String
cons [(Maybe String, AccessorTree a)]
trees))) String
prefix =
  (String
spaces String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
prefixNameEq String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cons) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Double -> String)
-> a -> [(Maybe String, AccessorTree a)] -> String -> [String]
forall a.
(Double -> String)
-> a -> [(Maybe String, AccessorTree a)] -> String -> [String]
showAccTrees Double -> String
show' a
x [(Maybe String, AccessorTree a)]
trees String
newSpaces
  where
    prefixNameEq :: String
prefixNameEq = String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe String -> String
showMName Maybe String
getterName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = "
    newSpaces :: String
newSpaces = String
spaces String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
prefixNameEq) Char
' ')

-- version of (init . unlines) which doesn't throw an error on empty input
initUnlines :: [String] -> [Char]
initUnlines :: [String] -> String
initUnlines [] = String
""
initUnlines [String]
xs = String -> String
forall a. [a] -> [a]
init ([String] -> String
unlines [String]
xs)

-- | Show a tree of values
showTree :: AccessorTree a -> (Double -> String) -> a -> String
showTree :: AccessorTree a -> (Double -> String) -> a -> String
showTree (Right (GAData String
_ (GASum GASimpleEnum a
simpleEnum))) Double -> String
_ a
x = GASimpleEnum a -> a -> String
forall a. GASimpleEnum a -> a -> String
eToString GASimpleEnum a
simpleEnum a
x
showTree (Right (GAData String
_ (GAConstructor String
cons [(Maybe String, AccessorTree a)]
trees))) Double -> String
show' a
x =
  [String] -> String
initUnlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
cons String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Double -> String)
-> a -> [(Maybe String, AccessorTree a)] -> String -> [String]
forall a.
(Double -> String)
-> a -> [(Maybe String, AccessorTree a)] -> String -> [String]
showAccTrees Double -> String
show' a
x [(Maybe String, AccessorTree a)]
trees String
""
showTree (Left GAField a
field) Double -> String
show' a
x = GAField a -> (Double -> String) -> a -> String
forall a. GAField a -> (Double -> String) -> a -> String
showFieldVal GAField a
field Double -> String
show' a
x

-- | Show a list of values
-- .
-- True --> align the colums, False --> total mayhem
showFlat :: forall a . AccessorTree a -> Bool -> (Double -> String) -> a -> String
showFlat :: AccessorTree a -> Bool -> (Double -> String) -> a -> String
showFlat AccessorTree a
at Bool
align Double -> String
show' a
x = [String] -> String
initUnlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((String, GATip a) -> String) -> [(String, GATip a)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, GATip a) -> String
f [(String, GATip a)]
fl
  where
    n :: Int
n = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (((String, GATip a) -> Int) -> [(String, GATip a)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int)
-> ((String, GATip a) -> String) -> (String, GATip a) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, GATip a) -> String
forall a b. (a, b) -> a
fst) [(String, GATip a)]
fl)

    f :: (String, GATip a) -> String
f (String
name, GATip a
lens) = String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
spaces String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ GATip a -> (Double -> String) -> a -> String
forall a. GATip a -> (Double -> String) -> a -> String
showTipVal GATip a
lens Double -> String
show' a
x
      where
        spaces :: String
spaces
          | Bool
align = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
name) Char
' '
          | Bool
otherwise = String
""

    fl :: [(String, GATip a)]
    fl :: [(String, GATip a)]
fl = AccessorTree a -> [(String, GATip a)]
forall a. AccessorTree a -> [(String, GATip a)]
flatten AccessorTree a
at