{-# LANGUAGE CPP                 #-}
{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE DefaultSignatures   #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators       #-}
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708
{-# LANGUAGE EmptyCase           #-}
#endif
-- | A 'ToExpr' class.
module Data.TreeDiff.Class (
    ediff,
    ediff',
    ToExpr (..),
    defaultExprViaShow,
    -- * Generics
    genericToExpr,
    GToExpr,
    ) where

import Data.Foldable    (toList)
import Data.List.Compat (uncons)
import Data.Proxy       (Proxy (..))
import GHC.Generics
       ((:*:) (..), (:+:) (..), Constructor (..), Generic (..), K1 (..),
       M1 (..), Selector (..), U1 (..), V1)

import qualified Data.Map as Map
import qualified Data.TreeDiff.OMap as OMap

import Data.TreeDiff.Expr

-- 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)

#ifdef MIN_VERSION_generic_deriving
import Generics.Deriving.Instances ()
#endif

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

-- strict
import qualified Data.Strict as Strict

-- these
import Data.These (These (..))

-- primitive
-- import qualified Data.Primitive as Prim

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

-------------------------------------------------------------------------------
-- Code
-------------------------------------------------------------------------------

-- | 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 {fooInt = Right -2 +3, fooBool = [Just True], fooString = "fo"}
--
-- >>> prettyEditExpr $ ediff (Foo (Right 42) [Just True, Just False] "old") (Foo (Right 42) [Nothing, Just False, Just True] "new")
-- Foo {
--   fooInt = Right 42,
--   fooBool = [-Just True, +Nothing, Just False, +Just True],
--   fooString = -"old" +"new"}
--
ediff :: ToExpr a => a -> a -> Edit EditExpr
ediff :: a -> a -> Edit EditExpr
ediff a
x a
y = Expr -> Expr -> Edit EditExpr
exprDiff (a -> Expr
forall a. ToExpr a => a -> Expr
toExpr a
x) (a -> Expr
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' :: a -> b -> Edit EditExpr
ediff' a
x b
y = Expr -> Expr -> Edit EditExpr
exprDiff (a -> Expr
forall a. ToExpr a => a -> Expr
toExpr a
x) (b -> Expr
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, GToExpr (Rep a))
        => a -> Expr
    toExpr = a -> Expr
forall a. (Generic a, GToExpr (Rep a)) => a -> Expr
genericToExpr

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

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

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

-------------------------------------------------------------------------------
-- Generics
-------------------------------------------------------------------------------

class GToExpr f where
    gtoExpr :: f x -> Expr

instance GSumToExpr f => GToExpr (M1 i c f) where
    gtoExpr :: M1 i c f x -> Expr
gtoExpr (M1 f x
x) = f x -> Expr
forall (f :: * -> *) x. GSumToExpr f => f x -> Expr
gsumToExpr f x
x

class GSumToExpr f where
    gsumToExpr :: f x -> Expr

instance (GSumToExpr f, GSumToExpr g) => GSumToExpr (f :+: g) where
    gsumToExpr :: (:+:) f g x -> Expr
gsumToExpr (L1 f x
x) = f x -> Expr
forall (f :: * -> *) x. GSumToExpr f => f x -> Expr
gsumToExpr f x
x
    gsumToExpr (R1 g x
x) = g x -> Expr
forall (f :: * -> *) x. GSumToExpr f => f x -> Expr
gsumToExpr g x
x

instance GSumToExpr V1 where
#if __GLASGOW_HASKELL__ >= 708
    gsumToExpr :: V1 x -> Expr
gsumToExpr V1 x
x = case V1 x
x of {}
#else
    gsumToExpr x = x `seq` error "panic: V1 value"
#endif

instance (Constructor c, GProductToExpr f) => GSumToExpr (M1 i c f) where
    gsumToExpr :: M1 i c f x -> Expr
gsumToExpr z :: M1 i c f x
z@(M1 f x
x) = case f x -> AppOrRec
forall (f :: * -> *) x. GProductToExpr f => f x -> AppOrRec
gproductToExpr f x
x of
        App' [Expr]
exprs   -> ConstructorName -> [Expr] -> Expr
App ConstructorName
cn [Expr]
exprs
        Rec' []      -> ConstructorName -> [Expr] -> Expr
App ConstructorName
cn []
        Rec' [(ConstructorName
_,Expr
e)] -> ConstructorName -> [Expr] -> Expr
App ConstructorName
cn [Expr
e]
        Rec' [(ConstructorName, Expr)]
pairs   -> ConstructorName -> OMap ConstructorName Expr -> Expr
Rec ConstructorName
cn ([(ConstructorName, Expr)] -> OMap ConstructorName Expr
forall k v. Ord k => [(k, v)] -> OMap k v
OMap.fromList [(ConstructorName, Expr)]
pairs)
      where
        cn :: ConstructorName
cn = M1 i c f x -> ConstructorName
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> ConstructorName
conName M1 i c f x
z

class GProductToExpr f where
    gproductToExpr :: f x -> AppOrRec

instance (GProductToExpr f, GProductToExpr g) => GProductToExpr (f :*: g) where
    gproductToExpr :: (:*:) f g x -> AppOrRec
gproductToExpr (f x
f :*: g x
g) = f x -> AppOrRec
forall (f :: * -> *) x. GProductToExpr f => f x -> AppOrRec
gproductToExpr f x
f AppOrRec -> AppOrRec -> AppOrRec
`combine` g x -> AppOrRec
forall (f :: * -> *) x. GProductToExpr f => f x -> AppOrRec
gproductToExpr g x
g

instance GProductToExpr U1 where
    gproductToExpr :: U1 x -> AppOrRec
gproductToExpr U1 x
_ = [(ConstructorName, Expr)] -> AppOrRec
Rec' []

instance (Selector s, GLeafToExpr f) => GProductToExpr (M1 i s f) where
    gproductToExpr :: M1 i s f x -> AppOrRec
gproductToExpr z :: M1 i s f x
z@(M1 f x
x) = case M1 i s f x -> ConstructorName
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> ConstructorName
selName M1 i s f x
z of
        [] -> [Expr] -> AppOrRec
App' [f x -> Expr
forall (f :: * -> *) x. GLeafToExpr f => f x -> Expr
gleafToExpr f x
x]
        ConstructorName
sn -> [(ConstructorName, Expr)] -> AppOrRec
Rec' [(ConstructorName
sn, f x -> Expr
forall (f :: * -> *) x. GLeafToExpr f => f x -> Expr
gleafToExpr f x
x)]

class GLeafToExpr f where
    gleafToExpr :: f x -> Expr

instance ToExpr x => GLeafToExpr (K1 i x) where
    gleafToExpr :: K1 i x x -> Expr
gleafToExpr (K1 x
x) = x -> Expr
forall a. ToExpr a => a -> Expr
toExpr x
x

data AppOrRec = App' [Expr] | Rec' [(FieldName, Expr)]
  deriving Int -> AppOrRec -> ShowS
[AppOrRec] -> ShowS
AppOrRec -> ConstructorName
(Int -> AppOrRec -> ShowS)
-> (AppOrRec -> ConstructorName)
-> ([AppOrRec] -> ShowS)
-> Show AppOrRec
forall a.
(Int -> a -> ShowS)
-> (a -> ConstructorName) -> ([a] -> ShowS) -> Show a
showList :: [AppOrRec] -> ShowS
$cshowList :: [AppOrRec] -> ShowS
show :: AppOrRec -> ConstructorName
$cshow :: AppOrRec -> ConstructorName
showsPrec :: Int -> AppOrRec -> ShowS
$cshowsPrec :: Int -> AppOrRec -> ShowS
Show

combine :: AppOrRec -> AppOrRec -> AppOrRec
combine :: AppOrRec -> AppOrRec -> AppOrRec
combine (Rec' [(ConstructorName, Expr)]
xs) (Rec' [(ConstructorName, Expr)]
ys) = [(ConstructorName, Expr)] -> AppOrRec
Rec' ([(ConstructorName, Expr)]
xs [(ConstructorName, Expr)]
-> [(ConstructorName, Expr)] -> [(ConstructorName, Expr)]
forall a. [a] -> [a] -> [a]
++ [(ConstructorName, Expr)]
ys)
combine AppOrRec
xs        AppOrRec
ys        = [Expr] -> AppOrRec
App' (AppOrRec -> [Expr]
exprs AppOrRec
xs [Expr] -> [Expr] -> [Expr]
forall a. [a] -> [a] -> [a]
++ AppOrRec -> [Expr]
exprs AppOrRec
ys)
  where
    exprs :: AppOrRec -> [Expr]
exprs (App' [Expr]
zs) = [Expr]
zs
    exprs (Rec' [(ConstructorName, Expr)]
zs) = ((ConstructorName, Expr) -> Expr)
-> [(ConstructorName, Expr)] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (ConstructorName, Expr) -> Expr
forall a b. (a, b) -> b
snd [(ConstructorName, Expr)]
zs

-- | Generic 'toExpr'.
--
-- >>> data Foo = Foo Int Char deriving Generic
-- >>> genericToExpr (Foo 42 'x')
-- App "Foo" [App "42" [],App "'x'" []]
--
genericToExpr :: (Generic a, GToExpr (Rep a)) => a -> Expr
genericToExpr :: a -> Expr
genericToExpr = Rep a Any -> Expr
forall (f :: * -> *) x. GToExpr f => f x -> Expr
gtoExpr (Rep a Any -> Expr) -> (a -> Rep a Any) -> a -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from

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

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

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

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

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

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

instance ToExpr (Proxy a) where toExpr :: Proxy a -> Expr
toExpr = Proxy a -> Expr
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 = Char -> Expr
forall a. Show a => a -> Expr
defaultExprViaShow
    listToExpr :: ConstructorName -> Expr
listToExpr = ConstructorName -> [ConstructorName] -> Expr
forall a. Show a => ConstructorName -> [a] -> Expr
stringToExpr ConstructorName
"concat" ([ConstructorName] -> Expr)
-> (ConstructorName -> [ConstructorName])
-> ConstructorName
-> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConstructorName -> Maybe (Char, ConstructorName))
-> ConstructorName -> [ConstructorName]
forall a. (a -> Maybe (Char, a)) -> a -> [ConstructorName]
unconcat ConstructorName -> Maybe (Char, ConstructorName)
forall a. [a] -> Maybe (a, [a])
uncons

stringToExpr
    :: Show a
    => String -- ^ name of concat
    -> [a]
    -> Expr
stringToExpr :: ConstructorName -> [a] -> Expr
stringToExpr ConstructorName
_  []  = ConstructorName -> [Expr] -> Expr
App ConstructorName
"\"\"" []
stringToExpr ConstructorName
_  [a
l] = a -> Expr
forall a. Show a => a -> Expr
defaultExprViaShow a
l
stringToExpr ConstructorName
cn [a]
ls  = ConstructorName -> [Expr] -> Expr
App ConstructorName
cn [[Expr] -> Expr
Lst ((a -> Expr) -> [a] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map a -> Expr
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 :: (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)
            | ConstructorName -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ConstructorName
ys   -> []
            | Bool
otherwise -> ConstructorName
ys ConstructorName -> [ConstructorName] -> [ConstructorName]
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 Char -> Char -> Bool
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 Char -> ShowS
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" [a -> Expr
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"  [a -> Expr
forall a. ToExpr a => a -> Expr
toExpr a
x]
    toExpr (Right b
y) = ConstructorName -> [Expr] -> Expr
App ConstructorName
"Right" [b -> Expr
forall a. ToExpr a => a -> Expr
toExpr b
y]

instance ToExpr a => ToExpr [a] where
    toExpr :: [a] -> Expr
toExpr = [a] -> Expr
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
"_×_" [a -> Expr
forall a. ToExpr a => a -> Expr
toExpr a
a, b -> Expr
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
"_×_×_" [a -> Expr
forall a. ToExpr a => a -> Expr
toExpr a
a, b -> Expr
forall a. ToExpr a => a -> Expr
toExpr b
b, c -> Expr
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
"_×_×_×_" [a -> Expr
forall a. ToExpr a => a -> Expr
toExpr a
a, b -> Expr
forall a. ToExpr a => a -> Expr
toExpr b
b, c -> Expr
forall a. ToExpr a => a -> Expr
toExpr c
c, d -> Expr
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
"_×_×_×_×_" [a -> Expr
forall a. ToExpr a => a -> Expr
toExpr a
a, b -> Expr
forall a. ToExpr a => a -> Expr
toExpr b
b, c -> Expr
forall a. ToExpr a => a -> Expr
toExpr c
c, d -> Expr
forall a. ToExpr a => a -> Expr
toExpr d
d, e -> Expr
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
"_%_" [ a -> Expr
forall a. ToExpr a => a -> Expr
toExpr (a -> Expr) -> a -> Expr
forall a b. (a -> b) -> a -> b
$ Ratio a -> a
forall a. Ratio a -> a
Ratio.numerator Ratio a
r, a -> Expr
forall a. ToExpr a => a -> Expr
toExpr (a -> Expr) -> a -> Expr
forall a b. (a -> b) -> a -> b
$ Ratio a -> a
forall a. Ratio a -> a
Ratio.denominator Ratio a
r ]
instance HasResolution a => ToExpr (Fixed a) where toExpr :: Fixed a -> Expr
toExpr = Fixed a -> Expr
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" [a -> Expr
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" [[a] -> Expr
forall a. ToExpr a => a -> Expr
toExpr (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs)]

instance ToExpr Void where
    toExpr :: Void -> Expr
toExpr Void
_ = ConstructorName -> [Expr] -> Expr
App ConstructorName
"error" [ConstructorName -> Expr
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
    toExpr :: Option a -> Expr
toExpr (Semi.Option Maybe a
x) = ConstructorName -> [Expr] -> Expr
App ConstructorName
"Option" [Maybe a -> Expr
forall a. ToExpr a => a -> Expr
toExpr Maybe a
x]
instance ToExpr a => ToExpr (Semi.Min a) where
    toExpr :: Min a -> Expr
toExpr (Semi.Min a
x) = ConstructorName -> [Expr] -> Expr
App ConstructorName
"Min" [a -> Expr
forall a. ToExpr a => a -> Expr
toExpr a
x]
instance ToExpr a => ToExpr (Semi.Max a) where
    toExpr :: Max a -> Expr
toExpr (Semi.Max a
x) = ConstructorName -> [Expr] -> Expr
App ConstructorName
"Max" [a -> Expr
forall a. ToExpr a => a -> Expr
toExpr a
x]
instance ToExpr a => ToExpr (Semi.First a) where
    toExpr :: First a -> Expr
toExpr (Semi.First a
x) = ConstructorName -> [Expr] -> Expr
App ConstructorName
"First" [a -> Expr
forall a. ToExpr a => a -> Expr
toExpr a
x]
instance ToExpr a => ToExpr (Semi.Last a) where
    toExpr :: Last a -> Expr
toExpr (Semi.Last a
x) = ConstructorName -> [Expr] -> Expr
App ConstructorName
"Last" [a -> Expr
forall a. ToExpr a => a -> Expr
toExpr a
x]

-------------------------------------------------------------------------------
-- 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" [a -> Expr
forall a. ToExpr a => a -> Expr
toExpr a
x, [Tree a] -> Expr
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" [ [(k, v)] -> Expr
forall a. ToExpr a => a -> Expr
toExpr ([(k, v)] -> Expr) -> [(k, v)] -> Expr
forall a b. (a -> b) -> a -> b
$ Map k v -> [(k, v)]
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" [ [k] -> Expr
forall a. ToExpr a => a -> Expr
toExpr ([k] -> Expr) -> [k] -> Expr
forall a b. (a -> b) -> a -> b
$ Set k -> [k]
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" [ [(Int, v)] -> Expr
forall a. ToExpr a => a -> Expr
toExpr ([(Int, v)] -> Expr) -> [(Int, v)] -> Expr
forall a b. (a -> b) -> a -> b
$ IntMap v -> [(Int, v)]
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" [ [Int] -> Expr
forall a. ToExpr a => a -> Expr
toExpr ([Int] -> Expr) -> [Int] -> Expr
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" [ [v] -> Expr
forall a. ToExpr a => a -> Expr
toExpr ([v] -> Expr) -> [v] -> Expr
forall a b. (a -> b) -> a -> b
$ Seq v -> [v]
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 = ConstructorName -> [ConstructorName] -> Expr
forall a. Show a => ConstructorName -> [a] -> Expr
stringToExpr ConstructorName
"LT.concat" ([ConstructorName] -> Expr)
-> (Text -> [ConstructorName]) -> Text -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Maybe (Char, Text)) -> Text -> [ConstructorName]
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 = ConstructorName -> [ConstructorName] -> Expr
forall a. Show a => ConstructorName -> [a] -> Expr
stringToExpr ConstructorName
"T.concat" ([ConstructorName] -> Expr)
-> (Text -> [ConstructorName]) -> Text -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Maybe (Char, Text)) -> Text -> [ConstructorName]
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" [ ConstructorName -> Expr
forall a. ToExpr a => a -> Expr
toExpr (Day -> ConstructorName
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" [ ConstructorName -> Expr
forall a. ToExpr a => a -> Expr
toExpr (UTCTime -> ConstructorName
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 = ConstructorName -> [ByteString] -> Expr
forall a. Show a => ConstructorName -> [a] -> Expr
stringToExpr ConstructorName
"LBS.concat" ([ByteString] -> Expr)
-> (ByteString -> [ByteString]) -> ByteString -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Bool)
-> (Word8 -> ByteString -> Maybe Int64)
-> (Int64 -> ByteString -> (ByteString, ByteString))
-> ByteString
-> [ByteString]
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 = ConstructorName -> [ByteString] -> Expr
forall a. Show a => ConstructorName -> [a] -> Expr
stringToExpr ConstructorName
"BS.concat" ([ByteString] -> Expr)
-> (ByteString -> [ByteString]) -> ByteString -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Bool)
-> (Word8 -> ByteString -> Maybe Int)
-> (Int -> ByteString -> (ByteString, ByteString))
-> ByteString
-> [ByteString]
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 :: ShortByteString -> Expr
toExpr = ConstructorName -> [ByteString] -> Expr
forall a. Show a => ConstructorName -> [a] -> Expr
stringToExpr ConstructorName
"mconcat" ([ByteString] -> Expr)
-> (ShortByteString -> [ByteString]) -> ShortByteString -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Bool)
-> (Word8 -> ByteString -> Maybe Int)
-> (Int -> ByteString -> (ByteString, ByteString))
-> ByteString
-> [ByteString]
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 (ByteString -> [ByteString])
-> (ShortByteString -> ByteString)
-> ShortByteString
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> ByteString
SBS.fromShort

bsUnconcat
    :: forall bs int. Num int
    => (bs -> Bool)
    -> (Word8 -> bs -> Maybe int)
    -> (int -> bs -> (bs, bs))
    -> bs
    -> [bs]
bsUnconcat :: (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 int -> int -> int
forall a. Num a => a -> a -> a
+ int
1) bs
bs of
                (bs
bs0, bs
bs1) -> bs
bs0 bs -> [bs] -> [bs]
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 :: Scientific -> Expr
toExpr Scientific
s = ConstructorName -> [Expr] -> Expr
App ConstructorName
"scientific" [ Integer -> Expr
forall a. ToExpr a => a -> Expr
toExpr (Integer -> Expr) -> Integer -> Expr
forall a b. (a -> b) -> a -> b
$ Scientific -> Integer
Sci.coefficient Scientific
s, Int -> Expr
forall a. ToExpr a => a -> Expr
toExpr (Int -> Expr) -> Int -> Expr
forall a b. (a -> b) -> a -> b
$ Scientific -> Int
Sci.base10Exponent Scientific
s ]

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

-- | >>> prettyExpr $ toExpr UUID.nil
-- UUID "00000000-0000-0000-0000-000000000000"
instance ToExpr UUID.UUID where
    toExpr :: UUID -> Expr
toExpr UUID
u = ConstructorName -> [Expr] -> Expr
App ConstructorName
"UUID" [ ConstructorName -> Expr
forall a. ToExpr a => a -> Expr
toExpr (ConstructorName -> Expr) -> ConstructorName -> Expr
forall a b. (a -> b) -> a -> b
$ UUID -> ConstructorName
UUID.toString UUID
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" [ [a] -> Expr
forall a. ToExpr a => a -> Expr
toExpr ([a] -> Expr) -> [a] -> Expr
forall a b. (a -> b) -> a -> b
$ Vector a -> [a]
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" [ [a] -> Expr
forall a. ToExpr a => a -> Expr
toExpr ([a] -> Expr) -> [a] -> Expr
forall a b. (a -> b) -> a -> b
$ Vector a -> [a]
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" [ [a] -> Expr
forall a. ToExpr a => a -> Expr
toExpr ([a] -> Expr) -> [a] -> Expr
forall a b. (a -> b) -> a -> b
$ Vector a -> [a]
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" [ [a] -> Expr
forall a. ToExpr a => a -> Expr
toExpr ([a] -> Expr) -> [a] -> Expr
forall a b. (a -> b) -> a -> b
$ Vector a -> [a]
forall a. Prim a => Vector a -> [a]
VP.toList Vector a
x ]

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

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

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

instance ToExpr a => ToExpr (Hashed a) where
    toExpr :: Hashed a -> Expr
toExpr Hashed a
x = ConstructorName -> [Expr] -> Expr
App ConstructorName
"hashed" [ a -> Expr
forall a. ToExpr a => a -> Expr
toExpr (a -> Expr) -> a -> Expr
forall a b. (a -> b) -> a -> b
$ Hashed a -> a
forall a. Hashed a -> a
unhashed Hashed a
x ]

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

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

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

instance ToExpr Aeson.Value

-------------------------------------------------------------------------------
-- strict
-------------------------------------------------------------------------------

instance ToExpr a => ToExpr (Strict.Maybe a) where
    toExpr :: Maybe a -> Expr
toExpr = Maybe a -> Expr
forall a. ToExpr a => a -> Expr
toExpr (Maybe a -> Expr) -> (Maybe a -> Maybe a) -> Maybe a -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> Maybe a
forall lazy strict. Strict lazy strict => strict -> lazy
Strict.toLazy

instance (ToExpr a, ToExpr b) => ToExpr (Strict.Either a b) where
    toExpr :: Either a b -> Expr
toExpr = Either a b -> Expr
forall a. ToExpr a => a -> Expr
toExpr (Either a b -> Expr)
-> (Either a b -> Either a b) -> Either a b -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either a b -> Either a b
forall lazy strict. Strict lazy strict => strict -> lazy
Strict.toLazy

instance (ToExpr a, ToExpr b) => ToExpr (Strict.These a b) where
    toExpr :: These a b -> Expr
toExpr = These a b -> Expr
forall a. ToExpr a => a -> Expr
toExpr (These a b -> Expr)
-> (These a b -> These a b) -> These a b -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. These a b -> These a b
forall lazy strict. Strict lazy strict => strict -> lazy
Strict.toLazy

instance (ToExpr a, ToExpr b) => ToExpr (Strict.Pair a b) where
    toExpr :: Pair a b -> Expr
toExpr = (a, b) -> Expr
forall a. ToExpr a => a -> Expr
toExpr ((a, b) -> Expr) -> (Pair a b -> (a, b)) -> Pair a b -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pair a b -> (a, b)
forall lazy strict. Strict lazy strict => strict -> lazy
Strict.toLazy

-------------------------------------------------------------------------------
-- these
-------------------------------------------------------------------------------

instance (ToExpr a, ToExpr b) => ToExpr (These a b) where
    toExpr :: These a b -> Expr
toExpr (This a
x)    = ConstructorName -> [Expr] -> Expr
App ConstructorName
"This" [a -> Expr
forall a. ToExpr a => a -> Expr
toExpr a
x]
    toExpr (That b
y)    = ConstructorName -> [Expr] -> Expr
App ConstructorName
"That" [b -> Expr
forall a. ToExpr a => a -> Expr
toExpr b
y]
    toExpr (These a
x b
y) = ConstructorName -> [Expr] -> Expr
App ConstructorName
"These " [a -> Expr
forall a. ToExpr a => a -> Expr
toExpr a
x, b -> Expr
forall a. ToExpr a => a -> Expr
toExpr b
y]

-------------------------------------------------------------------------------
-- primitive
-------------------------------------------------------------------------------

-- TODO: add instances