{-# options_haddock prune #-}
module Exon.Class.ToSegment where
import GHC.TypeLits (ErrorMessage)
import Generics.SOP (I (I), NP (Nil, (:*)), SOP (SOP), unZ)
import Generics.SOP.GGP (GCode, GFrom, gfrom)
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 (forall a. (GFrom a, Generic a) => a -> SOP I (GCode a)
gfrom -> SOP (forall {k} (f :: k -> *) (x :: k). NS f '[x] -> f x
unZ -> I x
b :* NP I xs
Nil)) =
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 =
forall a. a -> a
id
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 =
forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToString a => a -> String
toString
instance {-# overlappable #-} (
IsString a
) => ToSegment Text a where
toSegment :: Text -> a
toSegment =
forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToString a => a -> String
toString
instance {-# overlappable #-} (
IsString a
) => ToSegment LText a where
toSegment :: LText -> a
toSegment =
forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToString a => a -> String
toString
instance {-# overlappable #-} (
IsString a
) => ToSegment ByteString a where
toSegment :: ByteString -> a
toSegment =
forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertUtf8 a b => b -> a
decodeUtf8
instance {-# overlappable #-} (
IsString a
) => ToSegment LByteString a where
toSegment :: LByteString -> a
toSegment =
forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertUtf8 a b => b -> a
decodeUtf8