{-# 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.List.Compat
                   (uncons)
import           Data.Proxy
                   (Proxy(..))
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           Test.StateMachine.TreeDiff.Expr

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 (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' :: forall a b. (ToExpr a, ToExpr b) => 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, All2 ToExpr (GCode a), GFrom a, GDatatypeInfo a)
        => a -> Expr
    toExpr a
x = DatatypeInfo (GCode a) -> SOP I (GCode a) -> Expr
forall (xss :: [[*]]).
All2 ToExpr xss =>
DatatypeInfo xss -> SOP I xss -> Expr
sopToExpr (Proxy a -> DatatypeInfo (GCode a)
forall (proxy :: * -> *) a.
GDatatypeInfo a =>
proxy a -> DatatypeInfo (GCode a)
gdatatypeInfo (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)) (a -> SOP I (GCode a)
forall a. (GFrom a, Generic a) => a -> SOP I (GCode a)
gfrom a
x)

    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 :: forall a. Show a => a -> Expr
defaultExprViaShow a
x = ConstructorName -> [Expr] -> Expr
App (a -> ConstructorName
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) = NS (K Expr) xss -> CollapseTo NS Expr
forall (xs :: [[*]]) a.
SListIN NS xs =>
NS (K a) xs -> CollapseTo NS a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NS (K Expr) xss -> CollapseTo NS Expr)
-> NS (K Expr) xss -> CollapseTo NS Expr
forall a b. (a -> b) -> a -> b
$ Proxy (All ToExpr)
-> (forall (a :: [*]).
    All ToExpr a =>
    ConstructorInfo a -> NP I a -> K Expr a)
-> Prod NS ConstructorInfo xss
-> NS (NP I) xss
-> NS (K Expr) xss
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
    (Proxy (All ToExpr)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (All ToExpr))
    (\ConstructorInfo a
ci NP I a
xs -> Expr -> K Expr a
forall k a (b :: k). a -> K a b
K (Bool -> ConstructorInfo a -> NP I a -> Expr
forall (xs :: [*]).
All ToExpr xs =>
Bool -> ConstructorInfo xs -> NP I xs -> Expr
sopNPToExpr Bool
isNewtype ConstructorInfo a
ci NP I a
xs))
    (DatatypeInfo xss -> NP ConstructorInfo xss
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
_ Fixity
_) NP I xs
xs = ConstructorName -> [Expr] -> Expr
App (ConstructorName
"_" ConstructorName -> ConstructorName -> ConstructorName
forall a. [a] -> [a] -> [a]
++ ConstructorName
cn ConstructorName -> ConstructorName -> ConstructorName
forall a. [a] -> [a] -> [a]
++ ConstructorName
"_") ([Expr] -> Expr) -> [Expr] -> Expr
forall a b. (a -> b) -> a -> b
$ NP (K Expr) xs -> CollapseTo NP Expr
forall (xs :: [*]) a.
SListIN NP xs =>
NP (K a) xs -> CollapseTo NP a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NP (K Expr) xs -> CollapseTo NP Expr)
-> NP (K Expr) xs -> CollapseTo NP Expr
forall a b. (a -> b) -> a -> b
$
    Proxy ToExpr
-> (forall a. ToExpr a => I a -> K Expr a)
-> NP I xs
-> NP (K Expr) xs
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 (Proxy ToExpr
forall {k} (t :: k). Proxy t
Proxy :: Proxy ToExpr) ((a -> Expr) -> I a -> K Expr a
forall {k} a b (c :: k). (a -> b) -> I a -> K b c
mapIK a -> Expr
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 ([Expr] -> Expr) -> [Expr] -> Expr
forall a b. (a -> b) -> a -> b
$ NP (K Expr) xs -> CollapseTo NP Expr
forall (xs :: [*]) a.
SListIN NP xs =>
NP (K a) xs -> CollapseTo NP a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NP (K Expr) xs -> CollapseTo NP Expr)
-> NP (K Expr) xs -> CollapseTo NP Expr
forall a b. (a -> b) -> a -> b
$
    Proxy ToExpr
-> (forall a. ToExpr a => I a -> K Expr a)
-> NP I xs
-> NP (K Expr) xs
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 (Proxy ToExpr
forall {k} (t :: k). Proxy t
Proxy :: Proxy ToExpr) ((a -> Expr) -> I a -> K Expr a
forall {k} a b (c :: k). (a -> b) -> I a -> K b c
mapIK a -> Expr
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 ([Expr] -> Expr) -> [Expr] -> Expr
forall a b. (a -> b) -> a -> b
$ NP (K Expr) xs -> CollapseTo NP Expr
forall (xs :: [*]) a.
SListIN NP xs =>
NP (K a) xs -> CollapseTo NP a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NP (K Expr) xs -> CollapseTo NP Expr)
-> NP (K Expr) xs -> CollapseTo NP Expr
forall a b. (a -> b) -> a -> b
$
    Proxy ToExpr
-> (forall a. ToExpr a => I a -> K Expr a)
-> NP I xs
-> NP (K Expr) xs
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 (Proxy ToExpr
forall {k} (t :: k). Proxy t
Proxy :: Proxy ToExpr) ((a -> Expr) -> I a -> K Expr a
forall {k} a b (c :: k). (a -> b) -> I a -> K b c
mapIK a -> Expr
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 (Map ConstructorName Expr -> Expr)
-> Map ConstructorName Expr -> Expr
forall a b. (a -> b) -> a -> b
$ [(ConstructorName, Expr)] -> Map ConstructorName Expr
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ConstructorName, Expr)] -> Map ConstructorName Expr)
-> [(ConstructorName, Expr)] -> Map ConstructorName Expr
forall a b. (a -> b) -> a -> b
$ NP (K (ConstructorName, Expr)) xs
-> CollapseTo NP (ConstructorName, Expr)
forall (xs :: [*]) a.
SListIN NP xs =>
NP (K a) xs -> CollapseTo NP a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NP (K (ConstructorName, Expr)) xs
 -> CollapseTo NP (ConstructorName, Expr))
-> NP (K (ConstructorName, Expr)) xs
-> CollapseTo NP (ConstructorName, Expr)
forall a b. (a -> b) -> a -> b
$
    Proxy ToExpr
-> (forall a.
    ToExpr a =>
    FieldInfo a -> I a -> K (ConstructorName, Expr) a)
-> Prod NP FieldInfo xs
-> NP I xs
-> NP (K (ConstructorName, Expr)) xs
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 (Proxy ToExpr
forall {k} (t :: k). Proxy t
Proxy :: Proxy ToExpr) FieldInfo a -> I a -> K (ConstructorName, Expr) a
forall a.
ToExpr a =>
FieldInfo a -> I a -> K (ConstructorName, Expr) a
mk Prod NP FieldInfo xs
NP FieldInfo xs
fi NP I xs
xs
  where
    mk :: ToExpr x => FieldInfo x -> I x -> K (FieldName, Expr) x
    mk :: forall a.
ToExpr a =>
FieldInfo a -> I a -> K (ConstructorName, Expr) a
mk (FieldInfo ConstructorName
fn) (I x
x) = (ConstructorName, Expr) -> K (ConstructorName, Expr) x
forall k a (b :: k). a -> K a b
K (ConstructorName
fn, x -> Expr
forall a. ToExpr a => a -> Expr
toExpr x
x)

-------------------------------------------------------------------------------
-- 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 :: Fixity -> Expr
toExpr = Fixity -> 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 :: forall a. Show a => 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 :: 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)
            | ConstructorName -> Bool
forall a. [a] -> 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 -> ConstructorName -> ConstructorName
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
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" [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" [ [(Fixity, v)] -> Expr
forall a. ToExpr a => a -> Expr
toExpr ([(Fixity, v)] -> Expr) -> [(Fixity, v)] -> Expr
forall a b. (a -> b) -> a -> b
$ IntMap v -> [(Fixity, v)]
forall a. IntMap a -> [(Fixity, a)]
IntMap.toList IntMap v
x ]
instance ToExpr IntSet.IntSet where
    toExpr :: IntSet -> Expr
toExpr IntSet
x = ConstructorName -> [Expr] -> Expr
App ConstructorName
"IntSet.fromList" [ [Fixity] -> Expr
forall a. ToExpr a => a -> Expr
toExpr ([Fixity] -> Expr) -> [Fixity] -> Expr
forall a b. (a -> b) -> a -> b
$ IntSet -> [Fixity]
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 a. Seq a -> [a]
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 Fixity)
-> (Fixity -> 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 Fixity
BS.elemIndex Fixity -> 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 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 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" [ [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 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