{-# options_haddock prune #-}

-- |Description: Internal
module Exon.Class.ToSegment where

import GHC.TypeLits (ErrorMessage)
import Generics.SOP (SOP (SOP), unZ, I (I), NP ((:*), Nil))
import Generics.SOP.GGP (GCode, GFrom, gfrom)
import Type.Errors.Pretty (type (%), type (<>))

import Exon.Generic (IsNewtype)

class NewtypeSegment (wrapped :: Maybe Type) a b where
  newtypeSegment :: a -> b

instance (
    Generic a,
    GFrom a,
    GCode a ~ '[ '[b]],
    ToSegment b c
  ) => NewtypeSegment ('Just b) a c where
    newtypeSegment :: a -> c
newtypeSegment (a -> SOP I (GCode a)
forall a. (GFrom a, Generic a) => a -> SOP I (GCode a)
gfrom -> SOP (NS (NP I) (GCode a) -> NP I '[b]
forall {k} (f :: k -> *) (x :: k). NS f '[x] -> f x
unZ -> I x
b :* NP I xs
Nil)) =
      x -> c
forall a b. ToSegment a b => a -> b
toSegment x
b

type family Q (a :: k) :: ErrorMessage where
  Q a = "‘" <> a <> "’"

type family NoGenericMessage (a :: Type) (b :: Type) :: Constraint where
  NoGenericMessage a a = a ~ a
  NoGenericMessage a b =
    TypeError (
      "Found an expression of type " <> Q a <> " in a quote of type " <> Q b <> "." %
      "If " <> Q a <> " is a newtype of " <> Q b <> " that should be converted automatically," %
      "you need to add " <> Q "deriving (Generic)" <> " to its declaration." %
      "You can also implement " <> Q ("instance ToSegment " <> a <> " " <> b) <> " for custom interpolation."
    )

instance (
    NoGenericMessage a b,
    a ~ b
  ) => NewtypeSegment 'Nothing a b where
  newtypeSegment :: a -> b
newtypeSegment =
    a -> b
forall a. a -> a
id

-- |This class determines how an expression is converted to an interpolation quote's result type.
--
-- For a quote like @[exon|a #{exp :: T} c|] :: R@, the instance @ToSegment T R@ is used to turn @T@ into @R@.
-- Aside from specialized instances for stringly types, the default implementation uses 'Generic' to unwrap newtypes
-- that either match the result type exactly, or uses 'fromString' for result types that implement 'IsString'.
--
-- So given:
--
-- >>> newtype T = T Text deriving newtype (Generic)
-- >>> newtype R = R Text deriving newtype (IsString, Semigroup, Monoid)
--
-- the quote from earlier would generically unwrap @T@ and use 'fromString' to construct an @R@.
class ToSegment a b where
  toSegment :: a -> b

instance {-# incoherent #-} (
    IsNewtype a wrapped,
    NewtypeSegment wrapped a b
  ) => ToSegment a b where
  toSegment :: a -> b
toSegment =
    forall (wrapped :: Maybe (*)) a b.
NewtypeSegment wrapped a b =>
a -> b
newtypeSegment @wrapped

instance {-# overlappable #-} (
    IsString a
  ) => ToSegment String a where
  toSegment :: String -> a
toSegment =
    String -> a
forall a. IsString a => String -> a
fromString (String -> a) -> (String -> String) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. ToString a => a -> String
toString

instance {-# overlappable #-} (
    IsString a
  ) => ToSegment Text a where
  toSegment :: Text -> a
toSegment =
    String -> a
forall a. IsString a => String -> a
fromString (String -> a) -> (Text -> String) -> Text -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString

instance {-# overlappable #-} (
    IsString a
  ) => ToSegment LText a where
  toSegment :: LText -> a
toSegment =
    String -> a
forall a. IsString a => String -> a
fromString (String -> a) -> (LText -> String) -> LText -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LText -> String
forall a. ToString a => a -> String
toString

instance {-# overlappable #-} (
    IsString a
  ) => ToSegment ByteString a where
  toSegment :: ByteString -> a
toSegment =
    String -> a
forall a. IsString a => String -> a
fromString (String -> a) -> (ByteString -> String) -> ByteString -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8

instance {-# overlappable #-} (
    IsString a
  ) => ToSegment LByteString a where
  toSegment :: LByteString -> a
toSegment =
    String -> a
forall a. IsString a => String -> a
fromString (String -> a) -> (LByteString -> String) -> LByteString -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8