{-# LANGUAGE CPP                 #-}
{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE DefaultSignatures   #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | A 'ToExpr' class.
module Test.StateMachine.TreeDiff.Class (
    ediff,
    ediff',
    ToExpr (..),
    defaultExprViaShow,
    -- * SOP
    sopToExpr,
    ) where

import Data.Foldable      (toList)
import Data.Proxy         (Proxy (..))
import Test.StateMachine.TreeDiff.Expr
import Data.List.Compat      (uncons)
import Generics.SOP
       (All, All2, ConstructorInfo (..), DatatypeInfo (..), FieldInfo (..),
       I (..), K (..), NP (..), SOP (..), constructorInfo, hcliftA2, hcmap,
       hcollapse, mapIK)
import Generics.SOP.GGP   (GCode, GDatatypeInfo, GFrom, gdatatypeInfo, gfrom)
import GHC.Generics       (Generic)

import qualified Data.Map as Map

-- Instances
import Control.Applicative   (Const (..), ZipList (..))
import Data.Fixed            (Fixed, HasResolution)
import Data.Functor.Identity (Identity (..))
import Data.Int
import Data.List.NonEmpty    (NonEmpty (..))
import Data.Void             (Void)
import Data.Word
import Numeric.Natural       (Natural)

import qualified Data.Monoid    as Mon
import qualified Data.Ratio     as Ratio
import qualified Data.Semigroup as Semi

-- containers
import qualified Data.IntMap   as IntMap
import qualified Data.IntSet   as IntSet
import qualified Data.Sequence as Seq
import qualified Data.Set      as Set
import qualified Data.Tree     as Tree

-- text
import qualified Data.Text      as T
import qualified Data.Text.Lazy as LT

-- time
import qualified Data.Time as Time

-- bytestring
import qualified Data.ByteString       as BS
import qualified Data.ByteString.Lazy  as LBS
-- import qualified Data.ByteString.Short as SBS

-- scientific
-- import qualified Data.Scientific as Sci

-- uuid-types
-- import qualified Data.UUID.Types as UUID

-- vector
import qualified Data.Vector           as V
import qualified Data.Vector.Primitive as VP
import qualified Data.Vector.Storable  as VS
import qualified Data.Vector.Unboxed   as VU

-- tagged
-- import Data.Tagged (Tagged (..))

-- hashable
-- import Data.Hashable (Hashed, unhashed)

-- unordered-containers
-- import qualified Data.HashMap.Strict as HM
-- import qualified Data.HashSet        as HS

-- aeson
-- import qualified Data.Aeson as Aeson

-- | Difference between two 'ToExpr' values.
--
-- >>> let x = (1, Just 2) :: (Int, Maybe Int)
-- >>> let y = (1, Nothing)
-- >>> prettyEditExpr (ediff x y)
-- _×_ 1 -(Just 2) +Nothing
--
-- >>> data Foo = Foo { fooInt :: Either Char Int, fooBool :: [Maybe Bool], fooString :: String } deriving (Eq, Generic)
-- >>> instance ToExpr Foo
--
-- >>> prettyEditExpr $ ediff (Foo (Right 2) [Just True] "fo") (Foo (Right 3) [Just True] "fo")
-- Foo {fooBool = [Just True], fooInt = Right -2 +3, fooString = "fo"}
--
-- >>> prettyEditExpr $ ediff (Foo (Right 42) [Just True, Just False] "old") (Foo (Right 42) [Nothing, Just False, Just True] "new")
-- Foo
--   {fooBool = [-Just True, +Nothing, Just False, +Just True],
--    fooInt = Right 42,
--    fooString = -"old" +"new"}
--
ediff :: ToExpr a => a -> a -> Edit EditExpr
ediff :: forall a. ToExpr a => a -> a -> Edit EditExpr
ediff a
x a
y = Expr -> Expr -> Edit EditExpr
exprDiff (forall a. ToExpr a => a -> Expr
toExpr a
x) (forall a. ToExpr a => a -> Expr
toExpr a
y)

-- | Compare different types.
--
-- /Note:/ Use with care as you can end up comparing apples with oranges.
--
-- >>> prettyEditExpr $ ediff' ["foo", "bar"] [Just "foo", Nothing]
-- [-"foo", +Just "foo", -"bar", +Nothing]
--
ediff' :: (ToExpr a, ToExpr b) => a -> b -> Edit EditExpr
ediff' :: forall a b. (ToExpr a, ToExpr b) => a -> b -> Edit EditExpr
ediff' a
x b
y = Expr -> Expr -> Edit EditExpr
exprDiff (forall a. ToExpr a => a -> Expr
toExpr a
x) (forall a. ToExpr a => a -> Expr
toExpr b
y)

-- | 'toExpr' converts a Haskell value into
-- untyped Haskell-like syntax tree, 'Expr'.
--
-- >>> toExpr ((1, Just 2) :: (Int, Maybe Int))
-- App "_\215_" [App "1" [],App "Just" [App "2" []]]
--
class ToExpr a where
    toExpr :: a -> Expr
    default toExpr
        :: (Generic a, All2 ToExpr (GCode a), GFrom a, GDatatypeInfo a)
        => a -> Expr
    toExpr a
x = forall (xss :: [[*]]).
All2 ToExpr xss =>
DatatypeInfo xss -> SOP I xss -> Expr
sopToExpr (forall (proxy :: * -> *) a.
GDatatypeInfo a =>
proxy a -> DatatypeInfo (GCode a)
gdatatypeInfo (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)) (forall a. (GFrom a, Generic a) => a -> SOP I (GCode a)
gfrom a
x)

    listToExpr :: [a] -> Expr
    listToExpr = [Expr] -> Expr
Lst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. ToExpr a => a -> Expr
toExpr

instance ToExpr Expr where
    toExpr :: Expr -> Expr
toExpr = forall a. a -> a
id

-- | An alternative implementation for literal types. We use 'show'
-- representation of them.
defaultExprViaShow :: Show a => a -> Expr
defaultExprViaShow :: forall a. Show a => a -> Expr
defaultExprViaShow a
x = ConstructorName -> [Expr] -> Expr
App (forall a. Show a => a -> ConstructorName
show a
x) []

-- | >>> prettyExpr $ sopToExpr (gdatatypeInfo (Proxy :: Proxy String)) (gfrom "foo")
-- _:_ 'f' "oo"
sopToExpr :: (All2 ToExpr xss) => DatatypeInfo xss -> SOP I xss -> Expr
sopToExpr :: forall (xss :: [[*]]).
All2 ToExpr xss =>
DatatypeInfo xss -> SOP I xss -> Expr
sopToExpr DatatypeInfo xss
di (SOP NS (NP I) xss
xss) = forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse forall a b. (a -> b) -> a -> b
$ forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *) (f'' :: k -> *).
(AllN (Prod h) c xs, HAp h, HAp (Prod h)) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a -> f'' a)
-> Prod h f xs
-> h f' xs
-> h f'' xs
hcliftA2
    (forall {k} (t :: k). Proxy t
Proxy :: Proxy (All ToExpr))
    (\ConstructorInfo a
ci NP I a
xs -> forall k a (b :: k). a -> K a b
K (forall (xs :: [*]).
All ToExpr xs =>
Bool -> ConstructorInfo xs -> NP I xs -> Expr
sopNPToExpr Bool
isNewtype ConstructorInfo a
ci NP I a
xs))
    (forall (xss :: [[*]]). DatatypeInfo xss -> NP ConstructorInfo xss
constructorInfo DatatypeInfo xss
di)
    NS (NP I) xss
xss
  where
    isNewtype :: Bool
isNewtype = case DatatypeInfo xss
di of
        Newtype {} -> Bool
True
        ADT {}     -> Bool
False

sopNPToExpr :: All ToExpr xs => Bool -> ConstructorInfo xs -> NP I xs -> Expr
sopNPToExpr :: forall (xs :: [*]).
All ToExpr xs =>
Bool -> ConstructorInfo xs -> NP I xs -> Expr
sopNPToExpr Bool
_ (Infix ConstructorName
cn Associativity
_ Int
_) NP I xs
xs = ConstructorName -> [Expr] -> Expr
App (ConstructorName
"_" forall a. [a] -> [a] -> [a]
++ ConstructorName
cn forall a. [a] -> [a] -> [a]
++ ConstructorName
"_") forall a b. (a -> b) -> a -> b
$ forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse forall a b. (a -> b) -> a -> b
$
    forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcmap (forall {k} (t :: k). Proxy t
Proxy :: Proxy ToExpr) (forall {k} a b (c :: k). (a -> b) -> I a -> K b c
mapIK forall a. ToExpr a => a -> Expr
toExpr) NP I xs
xs
sopNPToExpr Bool
_ (Constructor ConstructorName
cn) NP I xs
xs = ConstructorName -> [Expr] -> Expr
App ConstructorName
cn forall a b. (a -> b) -> a -> b
$ forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse forall a b. (a -> b) -> a -> b
$
    forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcmap (forall {k} (t :: k). Proxy t
Proxy :: Proxy ToExpr) (forall {k} a b (c :: k). (a -> b) -> I a -> K b c
mapIK forall a. ToExpr a => a -> Expr
toExpr) NP I xs
xs
sopNPToExpr Bool
True (Record ConstructorName
cn NP FieldInfo xs
_) NP I xs
xs = ConstructorName -> [Expr] -> Expr
App ConstructorName
cn forall a b. (a -> b) -> a -> b
$ forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse forall a b. (a -> b) -> a -> b
$
    forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcmap (forall {k} (t :: k). Proxy t
Proxy :: Proxy ToExpr) (forall {k} a b (c :: k). (a -> b) -> I a -> K b c
mapIK forall a. ToExpr a => a -> Expr
toExpr) NP I xs
xs
sopNPToExpr Bool
False (Record ConstructorName
cn NP FieldInfo xs
fi) NP I xs
xs = ConstructorName -> Map ConstructorName Expr -> Expr
Rec ConstructorName
cn forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse forall a b. (a -> b) -> a -> b
$
    forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *) (f'' :: k -> *).
(AllN (Prod h) c xs, HAp h, HAp (Prod h)) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a -> f'' a)
-> Prod h f xs
-> h f' xs
-> h f'' xs
hcliftA2 (forall {k} (t :: k). Proxy t
Proxy :: Proxy ToExpr) forall x.
ToExpr x =>
FieldInfo x -> I x -> K (ConstructorName, Expr) x
mk NP FieldInfo xs
fi NP I xs
xs
  where
    mk :: ToExpr x => FieldInfo x -> I x -> K (FieldName, Expr) x
    mk :: forall x.
ToExpr x =>
FieldInfo x -> I x -> K (ConstructorName, Expr) x
mk (FieldInfo ConstructorName
fn) (I x
x) = forall k a (b :: k). a -> K a b
K (ConstructorName
fn, forall a. ToExpr a => a -> Expr
toExpr x
x)

-------------------------------------------------------------------------------
-- Instances
-------------------------------------------------------------------------------

instance ToExpr () where toExpr :: () -> Expr
toExpr = forall a. Show a => a -> Expr
defaultExprViaShow
instance ToExpr Bool where toExpr :: Bool -> Expr
toExpr = forall a. Show a => a -> Expr
defaultExprViaShow
instance ToExpr Ordering where toExpr :: Ordering -> Expr
toExpr = forall a. Show a => a -> Expr
defaultExprViaShow

instance ToExpr Integer where toExpr :: Integer -> Expr
toExpr = forall a. Show a => a -> Expr
defaultExprViaShow
instance ToExpr Natural where toExpr :: Natural -> Expr
toExpr = forall a. Show a => a -> Expr
defaultExprViaShow

instance ToExpr Float where toExpr :: Float -> Expr
toExpr = forall a. Show a => a -> Expr
defaultExprViaShow
instance ToExpr Double where toExpr :: Double -> Expr
toExpr = forall a. Show a => a -> Expr
defaultExprViaShow

instance ToExpr Int where toExpr :: Int -> Expr
toExpr = forall a. Show a => a -> Expr
defaultExprViaShow
instance ToExpr Int8 where toExpr :: Int8 -> Expr
toExpr = forall a. Show a => a -> Expr
defaultExprViaShow
instance ToExpr Int16 where toExpr :: Int16 -> Expr
toExpr = forall a. Show a => a -> Expr
defaultExprViaShow
instance ToExpr Int32 where toExpr :: Int32 -> Expr
toExpr = forall a. Show a => a -> Expr
defaultExprViaShow
instance ToExpr Int64 where toExpr :: Int64 -> Expr
toExpr = forall a. Show a => a -> Expr
defaultExprViaShow

instance ToExpr Word where toExpr :: Word -> Expr
toExpr = forall a. Show a => a -> Expr
defaultExprViaShow
instance ToExpr Word8 where toExpr :: Word8 -> Expr
toExpr = forall a. Show a => a -> Expr
defaultExprViaShow
instance ToExpr Word16 where toExpr :: Word16 -> Expr
toExpr = forall a. Show a => a -> Expr
defaultExprViaShow
instance ToExpr Word32 where toExpr :: Word32 -> Expr
toExpr = forall a. Show a => a -> Expr
defaultExprViaShow
instance ToExpr Word64 where toExpr :: Word64 -> Expr
toExpr = forall a. Show a => a -> Expr
defaultExprViaShow

instance ToExpr (Proxy a) where toExpr :: Proxy a -> Expr
toExpr = forall a. Show a => a -> Expr
defaultExprViaShow

-- | >>> prettyExpr $ toExpr 'a'
-- 'a'
--
-- >>> prettyExpr $ toExpr "Hello world"
-- "Hello world"
--
-- >>> prettyExpr $ toExpr "Hello\nworld"
-- concat ["Hello\n", "world"]
--
-- >>> traverse_ (print . prettyExpr . toExpr) ["", "\n", "foo", "foo\n", "foo\nbar", "foo\nbar\n"]
-- ""
-- "\n"
-- "foo"
-- "foo\n"
-- concat ["foo\n", "bar"]
-- concat ["foo\n", "bar\n"]
--
instance ToExpr Char where
    toExpr :: Char -> Expr
toExpr = forall a. Show a => a -> Expr
defaultExprViaShow
    listToExpr :: ConstructorName -> Expr
listToExpr = forall a. Show a => ConstructorName -> [a] -> Expr
stringToExpr ConstructorName
"concat" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Maybe (Char, a)) -> a -> [ConstructorName]
unconcat forall a. [a] -> Maybe (a, [a])
uncons

stringToExpr
    :: Show a
    => String -- ^ name of concat
    -> [a]
    -> Expr
stringToExpr :: forall a. Show a => ConstructorName -> [a] -> Expr
stringToExpr ConstructorName
_  []  = ConstructorName -> [Expr] -> Expr
App ConstructorName
"\"\"" []
stringToExpr ConstructorName
_  [a
l] = forall a. Show a => a -> Expr
defaultExprViaShow a
l
stringToExpr ConstructorName
cn [a]
ls  = ConstructorName -> [Expr] -> Expr
App ConstructorName
cn [[Expr] -> Expr
Lst (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> Expr
defaultExprViaShow [a]
ls)]

-- | Split on '\n'.
--
-- prop> \xs -> xs == concat (unconcat uncons xs)
unconcat :: forall a. (a -> Maybe (Char, a)) -> a -> [String]
unconcat :: forall a. (a -> Maybe (Char, a)) -> a -> [ConstructorName]
unconcat a -> Maybe (Char, a)
uncons_ = a -> [ConstructorName]
go where
    go :: a -> [String]
    go :: a -> [ConstructorName]
go a
xs = case a -> (ConstructorName, a)
span_ a
xs of
        ~(ConstructorName
ys, a
zs)
            | forall (t :: * -> *) a. Foldable t => t a -> Bool
null ConstructorName
ys   -> []
            | Bool
otherwise -> ConstructorName
ys forall a. a -> [a] -> [a]
: a -> [ConstructorName]
go a
zs

    span_ :: a -> (String, a)
    span_ :: a -> (ConstructorName, a)
span_ a
xs = case a -> Maybe (Char, a)
uncons_ a
xs of
        Maybe (Char, a)
Nothing         -> (ConstructorName
"", a
xs)
        Just ~(Char
x, a
xs')
            | Char
x forall a. Eq a => a -> a -> Bool
== Char
'\n' -> (ConstructorName
"\n", a
xs')
            | Bool
otherwise -> case a -> (ConstructorName, a)
span_ a
xs' of
            ~(ConstructorName
ys, a
zs) -> (Char
x forall a. a -> [a] -> [a]
: ConstructorName
ys, a
zs)

instance ToExpr a => ToExpr (Maybe a) where
    toExpr :: Maybe a -> Expr
toExpr Maybe a
Nothing  = ConstructorName -> [Expr] -> Expr
App ConstructorName
"Nothing" []
    toExpr (Just a
x) = ConstructorName -> [Expr] -> Expr
App ConstructorName
"Just" [forall a. ToExpr a => a -> Expr
toExpr a
x]

instance (ToExpr a, ToExpr b) => ToExpr (Either a b) where
    toExpr :: Either a b -> Expr
toExpr (Left a
x)  = ConstructorName -> [Expr] -> Expr
App ConstructorName
"Left"  [forall a. ToExpr a => a -> Expr
toExpr a
x]
    toExpr (Right b
y) = ConstructorName -> [Expr] -> Expr
App ConstructorName
"Right" [forall a. ToExpr a => a -> Expr
toExpr b
y]

instance ToExpr a => ToExpr [a] where
    toExpr :: [a] -> Expr
toExpr = forall a. ToExpr a => [a] -> Expr
listToExpr

instance (ToExpr a, ToExpr b) => ToExpr (a, b) where
    toExpr :: (a, b) -> Expr
toExpr (a
a, b
b) = ConstructorName -> [Expr] -> Expr
App ConstructorName
"_×_" [forall a. ToExpr a => a -> Expr
toExpr a
a, forall a. ToExpr a => a -> Expr
toExpr b
b]
instance (ToExpr a, ToExpr b, ToExpr c) => ToExpr (a, b, c) where
    toExpr :: (a, b, c) -> Expr
toExpr (a
a, b
b, c
c) = ConstructorName -> [Expr] -> Expr
App ConstructorName
"_×_×_" [forall a. ToExpr a => a -> Expr
toExpr a
a, forall a. ToExpr a => a -> Expr
toExpr b
b, forall a. ToExpr a => a -> Expr
toExpr c
c]
instance (ToExpr a, ToExpr b, ToExpr c, ToExpr d) => ToExpr (a, b, c, d) where
    toExpr :: (a, b, c, d) -> Expr
toExpr (a
a, b
b, c
c, d
d) = ConstructorName -> [Expr] -> Expr
App ConstructorName
"_×_×_×_" [forall a. ToExpr a => a -> Expr
toExpr a
a, forall a. ToExpr a => a -> Expr
toExpr b
b, forall a. ToExpr a => a -> Expr
toExpr c
c, forall a. ToExpr a => a -> Expr
toExpr d
d]
instance (ToExpr a, ToExpr b, ToExpr c, ToExpr d, ToExpr e) => ToExpr (a, b, c, d, e) where
    toExpr :: (a, b, c, d, e) -> Expr
toExpr (a
a, b
b, c
c, d
d, e
e) = ConstructorName -> [Expr] -> Expr
App ConstructorName
"_×_×_×_×_" [forall a. ToExpr a => a -> Expr
toExpr a
a, forall a. ToExpr a => a -> Expr
toExpr b
b, forall a. ToExpr a => a -> Expr
toExpr c
c, forall a. ToExpr a => a -> Expr
toExpr d
d, forall a. ToExpr a => a -> Expr
toExpr e
e]

-- | >>> prettyExpr $ toExpr (3 % 12 :: Rational)
-- _%_ 1 4
instance (ToExpr a, Integral a) => ToExpr (Ratio.Ratio a) where
    toExpr :: Ratio a -> Expr
toExpr Ratio a
r = ConstructorName -> [Expr] -> Expr
App ConstructorName
"_%_" [ forall a. ToExpr a => a -> Expr
toExpr forall a b. (a -> b) -> a -> b
$ forall a. Ratio a -> a
Ratio.numerator Ratio a
r, forall a. ToExpr a => a -> Expr
toExpr forall a b. (a -> b) -> a -> b
$ forall a. Ratio a -> a
Ratio.denominator Ratio a
r ]
instance HasResolution a => ToExpr (Fixed a) where toExpr :: Fixed a -> Expr
toExpr = forall a. Show a => a -> Expr
defaultExprViaShow

-- | >>> prettyExpr $ toExpr $ Identity 'a'
-- Identity 'a'
instance ToExpr a => ToExpr (Identity a) where
    toExpr :: Identity a -> Expr
toExpr (Identity a
x) = ConstructorName -> [Expr] -> Expr
App ConstructorName
"Identity" [forall a. ToExpr a => a -> Expr
toExpr a
x]

instance ToExpr a => ToExpr (Const a b)
instance ToExpr a => ToExpr (ZipList a)

instance ToExpr a => ToExpr (NonEmpty a) where
    toExpr :: NonEmpty a -> Expr
toExpr (a
x :| [a]
xs) = ConstructorName -> [Expr] -> Expr
App ConstructorName
"NE.fromList" [forall a. ToExpr a => a -> Expr
toExpr (a
x forall a. a -> [a] -> [a]
: [a]
xs)]

instance ToExpr Void where
    toExpr :: Void -> Expr
toExpr Void
_ = ConstructorName -> [Expr] -> Expr
App ConstructorName
"error" [forall a. ToExpr a => a -> Expr
toExpr ConstructorName
"Void"]

-------------------------------------------------------------------------------
-- Monoid/semigroups
-------------------------------------------------------------------------------

instance ToExpr a => ToExpr (Mon.Dual a) where
instance ToExpr a => ToExpr (Mon.Sum a) where
instance ToExpr a => ToExpr (Mon.Product a) where
instance ToExpr a => ToExpr (Mon.First a) where
instance ToExpr a => ToExpr (Mon.Last a) where

-- instance ToExpr a => ToExpr (Semi.Option a) where
instance ToExpr a => ToExpr (Semi.Min a) where
instance ToExpr a => ToExpr (Semi.Max a) where
instance ToExpr a => ToExpr (Semi.First a) where
instance ToExpr a => ToExpr (Semi.Last a) where

-------------------------------------------------------------------------------
-- containers
-------------------------------------------------------------------------------

instance ToExpr a => ToExpr (Tree.Tree a) where
    toExpr :: Tree a -> Expr
toExpr (Tree.Node a
x [Tree a]
xs) = ConstructorName -> [Expr] -> Expr
App ConstructorName
"Node" [forall a. ToExpr a => a -> Expr
toExpr a
x, forall a. ToExpr a => a -> Expr
toExpr [Tree a]
xs]

instance (ToExpr k, ToExpr v) => ToExpr (Map.Map k v) where
    toExpr :: Map k v -> Expr
toExpr Map k v
x = ConstructorName -> [Expr] -> Expr
App ConstructorName
"Map.fromList" [ forall a. ToExpr a => a -> Expr
toExpr forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map k v
x ]
instance (ToExpr k) => ToExpr (Set.Set k) where
    toExpr :: Set k -> Expr
toExpr Set k
x = ConstructorName -> [Expr] -> Expr
App ConstructorName
"Set.fromList" [ forall a. ToExpr a => a -> Expr
toExpr forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set k
x ]
instance (ToExpr v) => ToExpr (IntMap.IntMap v) where
    toExpr :: IntMap v -> Expr
toExpr IntMap v
x = ConstructorName -> [Expr] -> Expr
App ConstructorName
"IntMap.fromList" [ forall a. ToExpr a => a -> Expr
toExpr forall a b. (a -> b) -> a -> b
$ forall a. IntMap a -> [(Int, a)]
IntMap.toList IntMap v
x ]
instance ToExpr IntSet.IntSet where
    toExpr :: IntSet -> Expr
toExpr IntSet
x = ConstructorName -> [Expr] -> Expr
App ConstructorName
"IntSet.fromList" [ forall a. ToExpr a => a -> Expr
toExpr forall a b. (a -> b) -> a -> b
$ IntSet -> [Int]
IntSet.toList IntSet
x ]
instance (ToExpr v) => ToExpr (Seq.Seq v) where
    toExpr :: Seq v -> Expr
toExpr Seq v
x = ConstructorName -> [Expr] -> Expr
App ConstructorName
"Seq.fromList" [ forall a. ToExpr a => a -> Expr
toExpr forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq v
x ]

-------------------------------------------------------------------------------
-- text
-------------------------------------------------------------------------------

-- | >>> traverse_ (print . prettyExpr . toExpr . LT.pack) ["", "\n", "foo", "foo\n", "foo\nbar", "foo\nbar\n"]
-- ""
-- "\n"
-- "foo"
-- "foo\n"
-- LT.concat ["foo\n", "bar"]
-- LT.concat ["foo\n", "bar\n"]
instance ToExpr LT.Text where
    toExpr :: Text -> Expr
toExpr = forall a. Show a => ConstructorName -> [a] -> Expr
stringToExpr ConstructorName
"LT.concat" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Maybe (Char, a)) -> a -> [ConstructorName]
unconcat Text -> Maybe (Char, Text)
LT.uncons

-- | >>> traverse_ (print . prettyExpr . toExpr . T.pack) ["", "\n", "foo", "foo\n", "foo\nbar", "foo\nbar\n"]
-- ""
-- "\n"
-- "foo"
-- "foo\n"
-- T.concat ["foo\n", "bar"]
-- T.concat ["foo\n", "bar\n"]
instance ToExpr T.Text where
    toExpr :: Text -> Expr
toExpr = forall a. Show a => ConstructorName -> [a] -> Expr
stringToExpr ConstructorName
"T.concat" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Maybe (Char, a)) -> a -> [ConstructorName]
unconcat Text -> Maybe (Char, Text)
T.uncons

-------------------------------------------------------------------------------
-- time
-------------------------------------------------------------------------------

-- | >>> prettyExpr $ toExpr $ ModifiedJulianDay 58014
-- Day "2017-09-18"
instance ToExpr Time.Day where
    toExpr :: Day -> Expr
toExpr Day
d = ConstructorName -> [Expr] -> Expr
App ConstructorName
"Day" [ forall a. ToExpr a => a -> Expr
toExpr (forall a. Show a => a -> ConstructorName
show Day
d) ]

instance ToExpr Time.UTCTime where
    toExpr :: UTCTime -> Expr
toExpr UTCTime
t = ConstructorName -> [Expr] -> Expr
App ConstructorName
"UTCTime" [ forall a. ToExpr a => a -> Expr
toExpr (forall a. Show a => a -> ConstructorName
show UTCTime
t) ]

-------------------------------------------------------------------------------
-- bytestring
-------------------------------------------------------------------------------

-- | >>> traverse_ (print . prettyExpr . toExpr . LBS8.pack) ["", "\n", "foo", "foo\n", "foo\nbar", "foo\nbar\n"]
-- ""
-- "\n"
-- "foo"
-- "foo\n"
-- LBS.concat ["foo\n", "bar"]
-- LBS.concat ["foo\n", "bar\n"]
instance ToExpr LBS.ByteString where
    toExpr :: ByteString -> Expr
toExpr = forall a. Show a => ConstructorName -> [a] -> Expr
stringToExpr ConstructorName
"LBS.concat" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall bs int.
Num int =>
(bs -> Bool)
-> (Word8 -> bs -> Maybe int)
-> (int -> bs -> (bs, bs))
-> bs
-> [bs]
bsUnconcat ByteString -> Bool
LBS.null Word8 -> ByteString -> Maybe Int64
LBS.elemIndex Int64 -> ByteString -> (ByteString, ByteString)
LBS.splitAt

-- | >>> traverse_ (print . prettyExpr . toExpr . BS8.pack) ["", "\n", "foo", "foo\n", "foo\nbar", "foo\nbar\n"]
-- ""
-- "\n"
-- "foo"
-- "foo\n"
-- BS.concat ["foo\n", "bar"]
-- BS.concat ["foo\n", "bar\n"]
instance ToExpr BS.ByteString where
    toExpr :: ByteString -> Expr
toExpr = forall a. Show a => ConstructorName -> [a] -> Expr
stringToExpr ConstructorName
"BS.concat" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall bs int.
Num int =>
(bs -> Bool)
-> (Word8 -> bs -> Maybe int)
-> (int -> bs -> (bs, bs))
-> bs
-> [bs]
bsUnconcat ByteString -> Bool
BS.null Word8 -> ByteString -> Maybe Int
BS.elemIndex Int -> ByteString -> (ByteString, ByteString)
BS.splitAt

-- | >>> traverse_ (print . prettyExpr . toExpr . SBS.toShort . BS8.pack) ["", "\n", "foo", "foo\n", "foo\nbar", "foo\nbar\n"]
-- ""
-- "\n"
-- "foo"
-- "foo\n"
-- mconcat ["foo\n", "bar"]
-- mconcat ["foo\n", "bar\n"]
-- instance ToExpr SBS.ShortByteString where
--     toExpr = stringToExpr "mconcat" . bsUnconcat BS.null BS.elemIndex BS.splitAt . SBS.fromShort

bsUnconcat
    :: forall bs int. Num int
    => (bs -> Bool)
    -> (Word8 -> bs -> Maybe int)
    -> (int -> bs -> (bs, bs))
    -> bs
    -> [bs]
bsUnconcat :: forall bs int.
Num int =>
(bs -> Bool)
-> (Word8 -> bs -> Maybe int)
-> (int -> bs -> (bs, bs))
-> bs
-> [bs]
bsUnconcat bs -> Bool
null_ Word8 -> bs -> Maybe int
elemIndex_ int -> bs -> (bs, bs)
splitAt_ = bs -> [bs]
go where
    go :: bs -> [bs]
    go :: bs -> [bs]
go bs
bs
        | bs -> Bool
null_ bs
bs  = []
        | Bool
otherwise = case Word8 -> bs -> Maybe int
elemIndex_ Word8
10 bs
bs of
            Maybe int
Nothing -> [bs
bs]
            Just int
i  -> case int -> bs -> (bs, bs)
splitAt_ (int
i forall a. Num a => a -> a -> a
+ int
1) bs
bs of
                (bs
bs0, bs
bs1) -> bs
bs0 forall a. a -> [a] -> [a]
: bs -> [bs]
go bs
bs1

-------------------------------------------------------------------------------
-- scientific
-------------------------------------------------------------------------------

-- | >>> prettyExpr $ toExpr (123.456 :: Scientific)
-- scientific 123456 `-3`
-- instance ToExpr Sci.Scientific where
--     toExpr s = App "scientific" [ toExpr $ Sci.coefficient s, toExpr $ Sci.base10Exponent s ]

-------------------------------------------------------------------------------
-- uuid-types
-------------------------------------------------------------------------------

-- | >>> prettyExpr $ toExpr UUID.nil
-- UUID "00000000-0000-0000-0000-000000000000"
-- instance ToExpr UUID.UUID where
--     toExpr u = App "UUID" [ toExpr $ UUID.toString u ]

-------------------------------------------------------------------------------
-- vector
-------------------------------------------------------------------------------

instance ToExpr a => ToExpr (V.Vector a) where
    toExpr :: Vector a -> Expr
toExpr Vector a
x = ConstructorName -> [Expr] -> Expr
App ConstructorName
"V.fromList" [ forall a. ToExpr a => a -> Expr
toExpr forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> [a]
V.toList Vector a
x ]
instance (ToExpr a, VU.Unbox a) => ToExpr (VU.Vector a) where
    toExpr :: Vector a -> Expr
toExpr Vector a
x = ConstructorName -> [Expr] -> Expr
App ConstructorName
"VU.fromList" [ forall a. ToExpr a => a -> Expr
toExpr forall a b. (a -> b) -> a -> b
$ forall a. Unbox a => Vector a -> [a]
VU.toList Vector a
x ]
instance (ToExpr a, VS.Storable a) => ToExpr (VS.Vector a) where
    toExpr :: Vector a -> Expr
toExpr Vector a
x = ConstructorName -> [Expr] -> Expr
App ConstructorName
"VS.fromList" [ forall a. ToExpr a => a -> Expr
toExpr forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Vector a -> [a]
VS.toList Vector a
x ]
instance (ToExpr a, VP.Prim a) => ToExpr (VP.Vector a) where
    toExpr :: Vector a -> Expr
toExpr Vector a
x = ConstructorName -> [Expr] -> Expr
App ConstructorName
"VP.fromList" [ forall a. ToExpr a => a -> Expr
toExpr forall a b. (a -> b) -> a -> b
$ forall a. Prim a => Vector a -> [a]
VP.toList Vector a
x ]

-------------------------------------------------------------------------------
-- tagged
-------------------------------------------------------------------------------

-- instance ToExpr a => ToExpr (Tagged t a) where
--     toExpr (Tagged x) = App "Tagged" [ toExpr x ]

-------------------------------------------------------------------------------
-- hashable
-------------------------------------------------------------------------------

-- instance ToExpr a => ToExpr (Hashed a) where
--     toExpr x = App "hashed" [ toExpr $ unhashed x ]

-------------------------------------------------------------------------------
-- unordered-containers
-------------------------------------------------------------------------------

-- instance (ToExpr k, ToExpr v) => ToExpr (HM.HashMap k v) where
--     toExpr x = App "HM.fromList" [ toExpr $ HM.toList x ]
-- instance (ToExpr k) => ToExpr (HS.HashSet k) where
--     toExpr x = App "HS.fromList" [ toExpr $ HS.toList x ]

-------------------------------------------------------------------------------
-- aeson
-------------------------------------------------------------------------------

-- instance ToExpr Aeson.Value

-------------------------------------------------------------------------------
-- Doctest
-------------------------------------------------------------------------------

-- $setup
-- >>> :set -XDeriveGeneric
-- >>> :set -XDeriveGeneric
-- >>> import Data.Foldable (traverse_)
-- >>> import Data.Ratio ((%))
-- >>> import Data.Time (Day (..))
-- >>> import Data.Scientific (Scientific)
-- >>> import Data.TreeDiff.Pretty
-- >>> import qualified Data.ByteString.Char8 as BS8
-- >>> import qualified Data.ByteString.Lazy.Char8 as LBS8