module Telescope.Fits.Header.Class where

import Data.Text (Text, pack, unpack)
import Data.Text qualified as T
import Data.Time.Clock (UTCTime)
import Data.Time.Format.ISO8601 (iso8601ParseM, iso8601Show)
import Effectful
import GHC.Generics
import Telescope.Data.Axes (AxisOrder (..))
import Telescope.Data.KnownText
import Telescope.Data.Parser
import Telescope.Data.WCS (CType (..), CUnit (..), WCSAxis (..), toWCSAxisKey)
import Telescope.Fits.Header.Header (Header (..), HeaderRecord (..), lookupKeyword)
import Telescope.Fits.Header.Keyword
import Telescope.Fits.Header.Value
import Text.Casing (fromHumps, toSnake)


class ToKeyword a where
  toKeywordValue :: a -> Value


  toKeywordRecord :: Text -> a -> KeywordRecord
  default toKeywordRecord :: Text -> a -> KeywordRecord
  toKeywordRecord Text
key a
a =
    Text -> Value -> Maybe Text -> KeywordRecord
KeywordRecord Text
key (a -> Value
forall a. ToKeyword a => a -> Value
toKeywordValue a
a) Maybe Text
forall a. Maybe a
Nothing


class FromKeyword a where
  parseKeywordValue :: (Parser :> es) => Value -> Eff es a


instance ToKeyword Int where
  toKeywordValue :: Int -> Value
toKeywordValue = Int -> Value
Integer
instance FromKeyword Int where
  parseKeywordValue :: forall (es :: [Effect]). (Parser :> es) => Value -> Eff es Int
parseKeywordValue = \case
    Integer Int
n -> Int -> Eff es Int
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
n
    Value
v -> String -> Value -> Eff es Int
forall value (es :: [Effect]) a.
(Show value, Parser :> es) =>
String -> value -> Eff es a
expected String
"Integer" Value
v


instance ToKeyword Float where
  toKeywordValue :: Float -> Value
toKeywordValue = Double -> Value
Float (Double -> Value) -> (Float -> Double) -> Float -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance FromKeyword Float where
  parseKeywordValue :: forall (es :: [Effect]). (Parser :> es) => Value -> Eff es Float
parseKeywordValue = \case
    Float Double
n -> Float -> Eff es Float
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> Eff es Float) -> Float -> Eff es Float
forall a b. (a -> b) -> a -> b
$ Double -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
n
    Value
v -> String -> Value -> Eff es Float
forall value (es :: [Effect]) a.
(Show value, Parser :> es) =>
String -> value -> Eff es a
expected String
"Float" Value
v


instance ToKeyword Double where
  toKeywordValue :: Double -> Value
toKeywordValue = Double -> Value
Float
instance FromKeyword Double where
  parseKeywordValue :: forall (es :: [Effect]). (Parser :> es) => Value -> Eff es Double
parseKeywordValue = \case
    Float Double
n -> Double -> Eff es Double
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
n
    Value
v -> String -> Value -> Eff es Double
forall value (es :: [Effect]) a.
(Show value, Parser :> es) =>
String -> value -> Eff es a
expected String
"Double" Value
v


instance ToKeyword Text where
  toKeywordValue :: Text -> Value
toKeywordValue = Text -> Value
String
instance FromKeyword Text where
  parseKeywordValue :: forall (es :: [Effect]). (Parser :> es) => Value -> Eff es Text
parseKeywordValue = \case
    String Text
n -> Text -> Eff es Text
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
n
    Value
v -> String -> Value -> Eff es Text
forall value (es :: [Effect]) a.
(Show value, Parser :> es) =>
String -> value -> Eff es a
expected String
"String" Value
v


instance ToKeyword Bool where
  toKeywordValue :: Bool -> Value
toKeywordValue Bool
True = LogicalConstant -> Value
Logic LogicalConstant
T
  toKeywordValue Bool
False = LogicalConstant -> Value
Logic LogicalConstant
F
instance FromKeyword Bool where
  parseKeywordValue :: forall (es :: [Effect]). (Parser :> es) => Value -> Eff es Bool
parseKeywordValue = \case
    Logic LogicalConstant
c -> Bool -> Eff es Bool
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Eff es Bool) -> Bool -> Eff es Bool
forall a b. (a -> b) -> a -> b
$ LogicalConstant
c LogicalConstant -> LogicalConstant -> Bool
forall a. Eq a => a -> a -> Bool
== LogicalConstant
T
    Value
v -> String -> Value -> Eff es Bool
forall value (es :: [Effect]) a.
(Show value, Parser :> es) =>
String -> value -> Eff es a
expected String
"Logic" Value
v


instance ToKeyword UTCTime where
  toKeywordValue :: UTCTime -> Value
toKeywordValue UTCTime
utc = Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ UTCTime -> String
forall t. ISO8601 t => t -> String
iso8601Show UTCTime
utc
instance FromKeyword UTCTime where
  parseKeywordValue :: forall (es :: [Effect]). (Parser :> es) => Value -> Eff es UTCTime
parseKeywordValue = \case
    String Text
t -> do
      case String -> Maybe UTCTime
forall (m :: * -> *) t. (MonadFail m, ISO8601 t) => String -> m t
iso8601ParseM (String -> Maybe UTCTime) -> String -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
t of
        Maybe UTCTime
Nothing -> String -> Text -> Eff es UTCTime
forall value (es :: [Effect]) a.
(Show value, Parser :> es) =>
String -> value -> Eff es a
expected String
"UTCTime" Text
t
        Just UTCTime
utc -> UTCTime -> Eff es UTCTime
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTCTime
utc
    Value
v -> String -> Value -> Eff es UTCTime
forall value (es :: [Effect]) a.
(Show value, Parser :> es) =>
String -> value -> Eff es a
expected String
"UTCTime" Value
v


instance ToKeyword CUnit where
  toKeywordValue :: CUnit -> Value
toKeywordValue (CUnit Text
t) = Text -> Value
forall a. ToKeyword a => a -> Value
toKeywordValue Text
t
instance FromKeyword CUnit where
  parseKeywordValue :: forall (es :: [Effect]). (Parser :> es) => Value -> Eff es CUnit
parseKeywordValue = \case
    String Text
t -> CUnit -> Eff es CUnit
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CUnit -> Eff es CUnit) -> CUnit -> Eff es CUnit
forall a b. (a -> b) -> a -> b
$ Text -> CUnit
CUnit Text
t
    Value
v -> String -> Value -> Eff es CUnit
forall value (es :: [Effect]) a.
(Show value, Parser :> es) =>
String -> value -> Eff es a
expected String
"CUnit" Value
v


instance ToKeyword CType where
  toKeywordValue :: CType -> Value
toKeywordValue (CType Text
t) = Text -> Value
forall a. ToKeyword a => a -> Value
toKeywordValue Text
t
instance FromKeyword CType where
  parseKeywordValue :: forall (es :: [Effect]). (Parser :> es) => Value -> Eff es CType
parseKeywordValue = \case
    String Text
t -> CType -> Eff es CType
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CType -> Eff es CType) -> CType -> Eff es CType
forall a b. (a -> b) -> a -> b
$ Text -> CType
CType Text
t
    Value
v -> String -> Value -> Eff es CType
forall value (es :: [Effect]) a.
(Show value, Parser :> es) =>
String -> value -> Eff es a
expected String
"CType" Value
v


class ToHeader a where
  toHeader :: a -> Header
  default toHeader :: (Generic a, GToHeader (Rep a)) => a -> Header
  toHeader = Rep a Any -> Header
forall p. Rep a p -> Header
forall {k} (f :: k -> *) (p :: k). GToHeader f => f p -> Header
gToHeader (Rep a Any -> Header) -> (a -> Rep a Any) -> a -> Header
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from


instance (ToHeader a) => ToHeader (Maybe a) where
  toHeader :: Maybe a -> Header
toHeader Maybe a
Nothing = Header
forall a. Monoid a => a
mempty
  toHeader (Just a
a) = a -> Header
forall a. ToHeader a => a -> Header
toHeader a
a


instance (ToHeader a) => ToHeader [a] where
  toHeader :: [a] -> Header
toHeader = [Header] -> Header
forall a. Monoid a => [a] -> a
mconcat ([Header] -> Header) -> ([a] -> [Header]) -> [a] -> Header
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Header) -> [a] -> [Header]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Header
forall a. ToHeader a => a -> Header
toHeader


instance ToHeader Header where
  toHeader :: Header -> Header
toHeader = Header -> Header
forall a. a -> a
id


instance ToHeader HeaderRecord where
  toHeader :: HeaderRecord -> Header
toHeader HeaderRecord
hr = [HeaderRecord] -> Header
Header [HeaderRecord
hr]


instance (AxisOrder ax, KnownText alt) => ToHeader (WCSAxis alt ax) where
  toHeader :: WCSAxis alt ax -> Header
toHeader WCSAxis alt ax
axis =
    [Header] -> Header
forall a. Monoid a => [a] -> a
mconcat
      [ String -> CType -> Header
forall a. ToKeyword a => String -> a -> Header
axisKey String
"ctype" WCSAxis alt ax
axis.ctype
      , String -> CUnit -> Header
forall a. ToKeyword a => String -> a -> Header
axisKey String
"cunit" WCSAxis alt ax
axis.cunit
      , String -> Double -> Header
forall a. ToKeyword a => String -> a -> Header
axisKey String
"crpix" WCSAxis alt ax
axis.crpix
      , String -> Double -> Header
forall a. ToKeyword a => String -> a -> Header
axisKey String
"crval" WCSAxis alt ax
axis.crval
      , String -> Double -> Header
forall a. ToKeyword a => String -> a -> Header
axisKey String
"cdelt" WCSAxis alt ax
axis.cdelt
      ]
   where
    axisKey :: (ToKeyword a) => String -> a -> Header
    axisKey :: forall a. ToKeyword a => String -> a -> Header
axisKey String
s a
a =
      [HeaderRecord] -> Header
Header [KeywordRecord -> HeaderRecord
Keyword (KeywordRecord -> HeaderRecord) -> KeywordRecord -> HeaderRecord
forall a b. (a -> b) -> a -> b
$ Text -> a -> KeywordRecord
forall a. ToKeyword a => Text -> a -> KeywordRecord
toKeywordRecord (String -> Text
keyword String
s) a
a]

    keyword :: String -> Text
keyword String
s = forall {k1} {k2} (alt :: k1) (ax :: k2).
(KnownText alt, AxisOrder ax) =>
Text -> Text
forall (alt :: WCSAlt) (ax :: k).
(KnownText alt, AxisOrder ax) =>
Text -> Text
toWCSAxisKey @alt @ax (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
cleanKeyword String
s


class FromHeader a where
  parseHeader :: (Parser :> es) => Header -> Eff es a
  default parseHeader :: (Generic a, GFromHeader (Rep a), Parser :> es) => Header -> Eff es a
  parseHeader Header
h = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (Rep a Any -> a) -> Eff es (Rep a Any) -> Eff es a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Header -> Eff es (Rep a Any)
forall (es :: [Effect]) p.
(Parser :> es) =>
Header -> Eff es (Rep a p)
forall {k} (f :: k -> *) (es :: [Effect]) (p :: k).
(GFromHeader f, Parser :> es) =>
Header -> Eff es (f p)
gParseHeader Header
h


instance FromHeader Header where
  parseHeader :: forall (es :: [Effect]). (Parser :> es) => Header -> Eff es Header
parseHeader = Header -> Eff es Header
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure


instance FromHeader [HeaderRecord] where
  parseHeader :: forall (es :: [Effect]).
(Parser :> es) =>
Header -> Eff es [HeaderRecord]
parseHeader Header
h = [HeaderRecord] -> Eff es [HeaderRecord]
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Header
h.records


instance (AxisOrder ax, KnownText alt) => FromHeader (WCSAxis alt ax) where
  parseHeader :: forall (es :: [Effect]).
(Parser :> es) =>
Header -> Eff es (WCSAxis alt ax)
parseHeader Header
h = do
    CType
ctype <- String -> Header -> Eff es CType
forall a (es :: [Effect]).
(FromKeyword a, Parser :> es) =>
String -> Header -> Eff es a
parseAxisKey String
"ctype" Header
h
    CUnit
cunit <- String -> Header -> Eff es CUnit
forall a (es :: [Effect]).
(FromKeyword a, Parser :> es) =>
String -> Header -> Eff es a
parseAxisKey String
"cunit" Header
h
    Double
crpix <- String -> Header -> Eff es Double
forall a (es :: [Effect]).
(FromKeyword a, Parser :> es) =>
String -> Header -> Eff es a
parseAxisKey String
"crpix" Header
h
    Double
crval <- String -> Header -> Eff es Double
forall a (es :: [Effect]).
(FromKeyword a, Parser :> es) =>
String -> Header -> Eff es a
parseAxisKey String
"crval" Header
h
    Double
cdelt <- String -> Header -> Eff es Double
forall a (es :: [Effect]).
(FromKeyword a, Parser :> es) =>
String -> Header -> Eff es a
parseAxisKey String
"cdelt" Header
h
    WCSAxis alt ax -> Eff es (WCSAxis alt ax)
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WCSAxis alt ax -> Eff es (WCSAxis alt ax))
-> WCSAxis alt ax -> Eff es (WCSAxis alt ax)
forall a b. (a -> b) -> a -> b
$ WCSAxis{CType
ctype :: CType
$sel:ctype:WCSAxis :: CType
ctype, CUnit
cunit :: CUnit
$sel:cunit:WCSAxis :: CUnit
cunit, Double
crpix :: Double
$sel:crpix:WCSAxis :: Double
crpix, Double
crval :: Double
$sel:crval:WCSAxis :: Double
crval, Double
cdelt :: Double
$sel:cdelt:WCSAxis :: Double
cdelt}
   where
    parseAxisKey :: (FromKeyword a, Parser :> es) => String -> Header -> Eff es a
    parseAxisKey :: forall a (es :: [Effect]).
(FromKeyword a, Parser :> es) =>
String -> Header -> Eff es a
parseAxisKey String
k = do
      Text -> Header -> Eff es a
forall a (es :: [Effect]).
(FromKeyword a, Parser :> es) =>
Text -> Header -> Eff es a
parseKeyword (forall {k1} {k2} (alt :: k1) (ax :: k2).
(KnownText alt, AxisOrder ax) =>
Text -> Text
forall (alt :: WCSAlt) (ax :: k).
(KnownText alt, AxisOrder ax) =>
Text -> Text
toWCSAxisKey @alt @ax (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
cleanKeyword String
k)


parseKeyword :: (FromKeyword a, Parser :> es) => Text -> Header -> Eff es a
parseKeyword :: forall a (es :: [Effect]).
(FromKeyword a, Parser :> es) =>
Text -> Header -> Eff es a
parseKeyword Text
k Header
h =
  case Text -> Header -> Maybe Value
lookupKeyword Text
k Header
h of
    Maybe Value
Nothing -> String -> Eff es a
forall (es :: [Effect]) a. (Parser :> es) => String -> Eff es a
parseFail (String -> Eff es a) -> String -> Eff es a
forall a b. (a -> b) -> a -> b
$ String
"Missing key: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
k
    Just Value
v -> Ref -> Eff es a -> Eff es a
forall (es :: [Effect]) a.
(Parser :> es) =>
Ref -> Eff es a -> Eff es a
parseAt (Text -> Ref
Child Text
k) (Eff es a -> Eff es a) -> Eff es a -> Eff es a
forall a b. (a -> b) -> a -> b
$ Value -> Eff es a
forall (es :: [Effect]). (Parser :> es) => Value -> Eff es a
forall a (es :: [Effect]).
(FromKeyword a, Parser :> es) =>
Value -> Eff es a
parseKeywordValue Value
v


class GToHeader f where
  gToHeader :: f p -> Header


instance (GToHeader f) => GToHeader (M1 D c f) where
  gToHeader :: forall (p :: k). M1 D c f p -> Header
gToHeader (M1 f p
f) = f p -> Header
forall (p :: k). f p -> Header
forall {k} (f :: k -> *) (p :: k). GToHeader f => f p -> Header
gToHeader f p
f


instance (GToHeader f) => GToHeader (M1 C c f) where
  gToHeader :: forall (p :: k). M1 C c f p -> Header
gToHeader (M1 f p
f) = f p -> Header
forall (p :: k). f p -> Header
forall {k} (f :: k -> *) (p :: k). GToHeader f => f p -> Header
gToHeader f p
f


instance (GToHeader f, GToHeader g) => GToHeader (f :*: g) where
  gToHeader :: forall (p :: k). (:*:) f g p -> Header
gToHeader (f p
f :*: g p
g) = f p -> Header
forall (p :: k). f p -> Header
forall {k} (f :: k -> *) (p :: k). GToHeader f => f p -> Header
gToHeader f p
f Header -> Header -> Header
forall a. Semigroup a => a -> a -> a
<> g p -> Header
forall (p :: k). g p -> Header
forall {k} (f :: k -> *) (p :: k). GToHeader f => f p -> Header
gToHeader g p
g


instance {-# OVERLAPPABLE #-} (ToKeyword a, Selector s) => GToHeader (M1 S s (K1 R a)) where
  gToHeader :: forall (p :: k). M1 S s (K1 R a) p -> Header
gToHeader (M1 (K1 a
a)) = String -> a -> Header
forall a. ToKeyword a => String -> a -> Header
keywordForField (M1 S s Any Any -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t s f a -> String
selName (M1 S s f p
forall {k} {f :: k -> *} {p :: k}. M1 S s f p
forall a. HasCallStack => a
undefined :: M1 S s f p)) a
a


instance {-# OVERLAPS #-} (ToKeyword a, Selector s) => GToHeader (M1 S s (K1 R (Maybe a))) where
  gToHeader :: forall (p :: k). M1 S s (K1 R (Maybe a)) p -> Header
gToHeader (M1 (K1 Maybe a
Nothing)) = [HeaderRecord] -> Header
Header []
  gToHeader (M1 (K1 (Just a
a))) = String -> a -> Header
forall a. ToKeyword a => String -> a -> Header
keywordForField (M1 S s Any Any -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t s f a -> String
selName (M1 S s f p
forall {k} {f :: k -> *} {p :: k}. M1 S s f p
forall a. HasCallStack => a
undefined :: M1 S s f p)) a
a


instance {-# OVERLAPS #-} (ToHeader a, Selector s) => GToHeader (M1 S s (K1 R (HeaderFor a))) where
  gToHeader :: forall (p :: k). M1 S s (K1 R (HeaderFor a)) p -> Header
gToHeader (M1 (K1 (HeaderFor a
a))) = a -> Header
forall a. ToHeader a => a -> Header
toHeader a
a


class GFromHeader f where
  gParseHeader :: (Parser :> es) => Header -> Eff es (f p)


instance (GFromHeader f) => GFromHeader (M1 D c f) where
  gParseHeader :: forall (es :: [Effect]) (p :: k).
(Parser :> es) =>
Header -> Eff es (M1 D c f p)
gParseHeader Header
h = f p -> M1 D c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> M1 D c f p) -> Eff es (f p) -> Eff es (M1 D c f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Header -> Eff es (f p)
forall (es :: [Effect]) (p :: k).
(Parser :> es) =>
Header -> Eff es (f p)
forall {k} (f :: k -> *) (es :: [Effect]) (p :: k).
(GFromHeader f, Parser :> es) =>
Header -> Eff es (f p)
gParseHeader Header
h


instance (GFromHeader f) => GFromHeader (M1 C c f) where
  gParseHeader :: forall (es :: [Effect]) (p :: k).
(Parser :> es) =>
Header -> Eff es (M1 C c f p)
gParseHeader Header
h = f p -> M1 C c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> M1 C c f p) -> Eff es (f p) -> Eff es (M1 C c f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Header -> Eff es (f p)
forall (es :: [Effect]) (p :: k).
(Parser :> es) =>
Header -> Eff es (f p)
forall {k} (f :: k -> *) (es :: [Effect]) (p :: k).
(GFromHeader f, Parser :> es) =>
Header -> Eff es (f p)
gParseHeader Header
h


instance (GFromHeader f, GFromHeader g) => GFromHeader (f :*: g) where
  gParseHeader :: forall (es :: [Effect]) (p :: k).
(Parser :> es) =>
Header -> Eff es ((:*:) f g p)
gParseHeader Header
h = do
    f p
f <- Header -> Eff es (f p)
forall (es :: [Effect]) (p :: k).
(Parser :> es) =>
Header -> Eff es (f p)
forall {k} (f :: k -> *) (es :: [Effect]) (p :: k).
(GFromHeader f, Parser :> es) =>
Header -> Eff es (f p)
gParseHeader Header
h
    g p
g <- Header -> Eff es (g p)
forall (es :: [Effect]) (p :: k).
(Parser :> es) =>
Header -> Eff es (g p)
forall {k} (f :: k -> *) (es :: [Effect]) (p :: k).
(GFromHeader f, Parser :> es) =>
Header -> Eff es (f p)
gParseHeader Header
h
    (:*:) f g p -> Eff es ((:*:) f g p)
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((:*:) f g p -> Eff es ((:*:) f g p))
-> (:*:) f g p -> Eff es ((:*:) f g p)
forall a b. (a -> b) -> a -> b
$ f p
f f p -> g p -> (:*:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g p
g


instance {-# OVERLAPPABLE #-} (FromKeyword a, Selector s) => GFromHeader (M1 S s (K1 R a)) where
  gParseHeader :: forall (es :: [Effect]) (p :: k).
(Parser :> es) =>
Header -> Eff es (M1 S s (K1 R a) p)
gParseHeader Header
h = do
    let k :: Text
k = String -> Text
cleanKeyword (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ M1 S s Any Any -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t s f a -> String
selName (M1 S s f p
forall {k} {f :: k -> *} {p :: k}. M1 S s f p
forall a. HasCallStack => a
undefined :: M1 S s f p)
    K1 R a p -> M1 S s (K1 R a) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 R a p -> M1 S s (K1 R a) p)
-> (a -> K1 R a p) -> a -> M1 S s (K1 R a) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> K1 R a p
forall k i c (p :: k). c -> K1 i c p
K1 (a -> M1 S s (K1 R a) p) -> Eff es a -> Eff es (M1 S s (K1 R a) p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Header -> Eff es a
forall a (es :: [Effect]).
(FromKeyword a, Parser :> es) =>
Text -> Header -> Eff es a
parseKeyword Text
k Header
h


instance {-# OVERLAPS #-} (FromKeyword a, Selector s) => GFromHeader (M1 S s (K1 R (Maybe a))) where
  gParseHeader :: forall (es :: [Effect]) (p :: k).
(Parser :> es) =>
Header -> Eff es (M1 S s (K1 R (Maybe a)) p)
gParseHeader Header
h = do
    let k :: Text
k = String -> Text
cleanKeyword (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ M1 S s Any Any -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t s f a -> String
selName (M1 S s f p
forall {k} {f :: k -> *} {p :: k}. M1 S s f p
forall a. HasCallStack => a
undefined :: M1 S s f p)
    let mval :: Maybe Value
mval = Text -> Header -> Maybe Value
lookupKeyword Text
k Header
h :: Maybe Value
    K1 R (Maybe a) p -> M1 S s (K1 R (Maybe a)) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 R (Maybe a) p -> M1 S s (K1 R (Maybe a)) p)
-> (Maybe a -> K1 R (Maybe a) p)
-> Maybe a
-> M1 S s (K1 R (Maybe a)) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> K1 R (Maybe a) p
forall k i c (p :: k). c -> K1 i c p
K1 (Maybe a -> M1 S s (K1 R (Maybe a)) p)
-> Eff es (Maybe a) -> Eff es (M1 S s (K1 R (Maybe a)) p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Maybe Value
mval of
      Maybe Value
Nothing -> Maybe a -> Eff es (Maybe a)
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
      Just Value
v -> do
        a
a <- Ref -> Eff es a -> Eff es a
forall (es :: [Effect]) a.
(Parser :> es) =>
Ref -> Eff es a -> Eff es a
parseAt (Text -> Ref
Child Text
k) (Eff es a -> Eff es a) -> Eff es a -> Eff es a
forall a b. (a -> b) -> a -> b
$ Value -> Eff es a
forall (es :: [Effect]). (Parser :> es) => Value -> Eff es a
forall a (es :: [Effect]).
(FromKeyword a, Parser :> es) =>
Value -> Eff es a
parseKeywordValue Value
v
        Maybe a -> Eff es (Maybe a)
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> Eff es (Maybe a)) -> Maybe a -> Eff es (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
a


cleanKeyword :: String -> Text
cleanKeyword :: String -> Text
cleanKeyword = Text -> Text
T.toUpper (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> Text) -> (String -> String) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier String -> String
toSnake (Identifier String -> String)
-> (String -> Identifier String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Identifier String
fromHumps


newtype HeaderFor a = HeaderFor a


keywordForField :: (ToKeyword a) => String -> a -> Header
keywordForField :: forall a. ToKeyword a => String -> a -> Header
keywordForField String
selector a
a =
  [HeaderRecord] -> Header
Header [KeywordRecord -> HeaderRecord
Keyword (KeywordRecord -> HeaderRecord) -> KeywordRecord -> HeaderRecord
forall a b. (a -> b) -> a -> b
$ Text -> a -> KeywordRecord
forall a. ToKeyword a => Text -> a -> KeywordRecord
toKeywordRecord (String -> Text
cleanKeyword String
selector) a
a]