-- | Generic computation of a skeleton.
module Generics.SOP.Skeleton (
  -- $skeleton
  Skeleton(..)
  ) where

import Control.Exception
import Data.Text (Text)

import Generics.SOP

-- $skeleton
--
-- A skeleton for a record type has a defined "spine" but is undefined
-- everywhere else. For instance, a skeleton for pairs would be
--
-- > (undefined, undefined)

-- | Generic computation of a skeleton.
--
-- A skeleton for a record type has a defined "spine" but is undefined
-- everywhere else. For instance, a skeleton for pairs would be
--
-- > (undefined, undefined)
--
-- We introduce a type class for this purpose because the skeleton for nested
-- records would look like
--
-- > (undefined, (undefined, undefined))
--
-- The default instance of 'skeleton' applies to record types; for everything
-- else, use undefined (or error):
--
-- > instance Skeleton SomeRecordType -- no where clause
--
-- or
--
-- > instance Skeleton SomeNonRecordType where skeleton = undefined
--
-- This is an example of how SOP-style generic functions can
-- be used with @DefaultSignatures@.
--
-- Furthermore, metadata is used in order to produce better
-- error messages. For the undefined components of a record,
-- an error is triggered that mentions the name of the field.
--
class Skeleton a where
  default skeleton :: (Generic a, HasDatatypeInfo a, Code a ~ '[xs], All Skeleton xs) => a

  -- | Returns a skeleton.
  skeleton :: a
  skeleton = forall a (xs :: [*]).
(Generic a, HasDatatypeInfo a, Code a ~ '[xs], All Skeleton xs) =>
a
gskeleton

instance Skeleton [a]       where skeleton :: [a]
skeleton = forall a. HasCallStack => a
undefined
instance Skeleton (Maybe a) where skeleton :: Maybe a
skeleton = forall a. HasCallStack => a
undefined

instance Skeleton Int       where skeleton :: Int
skeleton = forall a. HasCallStack => a
undefined
instance Skeleton Double    where skeleton :: Double
skeleton = forall a. HasCallStack => a
undefined
instance Skeleton Rational  where skeleton :: Rational
skeleton = forall a. HasCallStack => a
undefined
instance Skeleton Bool      where skeleton :: Bool
skeleton = forall a. HasCallStack => a
undefined
instance Skeleton Text      where skeleton :: Text
skeleton = forall a. HasCallStack => a
undefined

{-------------------------------------------------------------------------------
  Generic instance
-------------------------------------------------------------------------------}

-- | Compute a "spine" for a single constructor datatype. That is, a valid value of
-- that type with a defined spine but undefined everywhere else. For record
-- types we give "error" values that mention the names of the fields.
gskeleton :: forall a xs. (Generic a, HasDatatypeInfo a, Code a ~ '[xs], All Skeleton xs) => a
gskeleton :: forall a (xs :: [*]).
(Generic a, HasDatatypeInfo a, Code a ~ '[xs], All Skeleton xs) =>
a
gskeleton = forall a. Generic a => Rep a -> a
to forall a b. (a -> b) -> a -> b
$ forall (xs :: [*]).
All Skeleton xs =>
DatatypeInfo '[xs] -> SOP I '[xs]
gskeleton' (forall a (proxy :: * -> *).
HasDatatypeInfo a =>
proxy a -> DatatypeInfo (Code a)
datatypeInfo (forall {k} (t :: k). Proxy t
Proxy :: Proxy a))

gskeleton' :: All Skeleton xs => DatatypeInfo '[xs] -> SOP I '[xs]
gskeleton' :: forall (xs :: [*]).
All Skeleton xs =>
DatatypeInfo '[xs] -> SOP I '[xs]
gskeleton' DatatypeInfo '[xs]
d = forall (xs :: [*]).
All Skeleton xs =>
ConstructorInfo xs -> SOP I '[xs]
gskeletonFor (forall {k} (f :: k -> *) (x :: k) (xs :: [k]). NP f (x : xs) -> f x
hd (forall (xss :: [[*]]). DatatypeInfo xss -> NP ConstructorInfo xss
constructorInfo DatatypeInfo '[xs]
d))

gskeletonFor :: All Skeleton xs => ConstructorInfo xs -> SOP I '[xs]
gskeletonFor :: forall (xs :: [*]).
All Skeleton xs =>
ConstructorInfo xs -> SOP I '[xs]
gskeletonFor (Constructor ConstructorName
_)     = forall k (f :: k -> *) (xss :: [[k]]). NS (NP f) xss -> SOP f xss
SOP forall a b. (a -> b) -> a -> b
$ forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z forall a b. (a -> b) -> a -> b
$ forall (xs :: [*]).
(All Skeleton xs, SListI xs) =>
NP (K ConstructorName) xs -> NP I xs
spineWithNames (forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *).
(HPure h, SListIN h xs) =>
(forall (a :: k). f a) -> h f xs
hpure (forall k a (b :: k). a -> K a b
K ConstructorName
""))
gskeletonFor (Infix       ConstructorName
_ Associativity
_ Int
_) = forall k (f :: k -> *) (xss :: [[k]]). NS (NP f) xss -> SOP f xss
SOP forall a b. (a -> b) -> a -> b
$ forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z forall a b. (a -> b) -> a -> b
$ forall (xs :: [*]).
(All Skeleton xs, SListI xs) =>
NP (K ConstructorName) xs -> NP I xs
spineWithNames (forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *).
(HPure h, SListIN h xs) =>
(forall (a :: k). f a) -> h f xs
hpure (forall k a (b :: k). a -> K a b
K ConstructorName
""))
gskeletonFor (Record      ConstructorName
_ NP FieldInfo xs
fs)  = forall k (f :: k -> *) (xss :: [[k]]). NS (NP f) xss -> SOP f xss
SOP forall a b. (a -> b) -> a -> b
$ forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z forall a b. (a -> b) -> a -> b
$ forall (xs :: [*]).
(All Skeleton xs, SListI xs) =>
NP (K ConstructorName) xs -> NP I xs
spineWithNames (forall {k} {l} (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hliftA forall a. FieldInfo a -> K ConstructorName a
sfieldName NP FieldInfo xs
fs)
  where
    sfieldName :: FieldInfo a -> K String a
    sfieldName :: forall a. FieldInfo a -> K ConstructorName a
sfieldName (FieldInfo ConstructorName
n) = forall k a (b :: k). a -> K a b
K ConstructorName
n

spineWithNames :: (All Skeleton xs, SListI xs) => NP (K String) xs -> NP I xs
spineWithNames :: forall (xs :: [*]).
(All Skeleton xs, SListI xs) =>
NP (K ConstructorName) xs -> NP I xs
spineWithNames = 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
hcliftA Proxy Skeleton
ps forall a. Skeleton a => K ConstructorName a -> I a
aux
  where
    aux :: Skeleton a => K String a -> I a
    aux :: forall a. Skeleton a => K ConstructorName a -> I a
aux (K ConstructorName
"") = forall a. a -> I a
I forall a b. (a -> b) -> a -> b
$ forall a. Skeleton a => a
skeleton
    aux (K ConstructorName
n)  = forall a. a -> I a
I forall a b. (a -> b) -> a -> b
$ forall e1 e2 a.
(Exception e1, Exception e2) =>
(e1 -> e2) -> a -> a
mapException (ConstructorName -> ErrorCall -> ErrorCall
addFieldName ConstructorName
n) forall a. Skeleton a => a
skeleton

addFieldName :: FieldName -> ErrorCall -> ErrorCall
#if MIN_VERSION_base(4,9,0)
addFieldName :: ConstructorName -> ErrorCall -> ErrorCall
addFieldName ConstructorName
n (ErrorCallWithLocation ConstructorName
str ConstructorName
loc) =
  ConstructorName -> ConstructorName -> ErrorCall
ErrorCallWithLocation (ConstructorName
n forall a. [a] -> [a] -> [a]
++ ConstructorName
": " forall a. [a] -> [a] -> [a]
++ ConstructorName
str) ConstructorName
loc
#else
addFieldName n (ErrorCall str) = ErrorCall (n ++ ": " ++ str)
#endif

ps :: Proxy Skeleton
ps :: Proxy Skeleton
ps = forall {k} (t :: k). Proxy t
Proxy