module Sqel.Sum where

import Generics.SOP (NP ((:*)))
import Generics.SOP.GGP (GCode, GDatatypeInfoOf)
import Generics.SOP.Type.Metadata (ConstructorInfo (Constructor, Infix, Record), DatatypeInfo (ADT))
import Prelude hiding (sum)
import Sqel.Comp (CompColumn (compColumn), CompName (compName), ConstructorFields, MetaFor, RecordFields)
import Sqel.Data.Dd (
  Comp (Prod, Sum),
  CompInc (Merge, Nest),
  ConCol,
  Dd (Dd),
  DdInc (DdMerge, DdNest),
  DdK (DdK),
  DdSort (DdCon, DdSum),
  DdStruct (DdComp, DdPrim),
  DdType,
  ProdType (Con),
  ProductField (ProductField),
  Struct (Comp, Prim),
  )
import Sqel.Data.Mods (pattern NoMods, NoMods)
import Sqel.Data.Sel (
  IndexName,
  MkTSel (mkTSel),
  Sel (SelAuto, SelIndex),
  SelPrefix (DefaultPrefix, SelPrefix),
  SelW (SelWAuto, SelWIndex),
  TSel (TSel),
  TypeName,
  )
import Sqel.Merge (merge)
import Sqel.Names.Rename (Rename (rename))
import Sqel.Names.Set (SetName)
import Sqel.Prim (IndexColumn, IndexColumnWith, primIndex)
import qualified Sqel.Type as T
import Type.Errors (ErrorMessage (Text))

type family SumFields' (fields :: [ConstructorInfo]) (ass :: [[Type]]) :: [ProductField] where
  SumFields' '[] '[] = '[]
  SumFields' ('Record name fields : cons) (as : ass) = 'ProductField name (ConCol name 'True (RecordFields fields as) as) : SumFields' cons ass
  SumFields' ('Constructor name : cons) (as : ass) = 'ProductField name (ConCol name 'False (ConstructorFields name 0 as) as) : SumFields' cons ass
  SumFields' ('Infix conName _ _ : _) _ =
    TypeError ("Infix constructor not supported: " <> conName)

type family SumFields (info :: DatatypeInfo) (ass :: [[Type]]) :: [ProductField] where
  SumFields ('ADT _ _ cons _) ass = SumFields' cons ass
  SumFields info _ =
    TypeError ("SumFields:" % info)

class DdType s ~ a => SumWith a isel imods arg s | a isel imods arg -> s where
  sumWith :: Dd ('DdK isel imods Int64 'Prim) -> arg -> Dd s

-- TODO b ~ a is not needed here, apparently, but it is for ConColumn. investigate and remove here
instance (
    b ~ a,
    CompName a ('TSel prefix name),
    fields ~ SumFields (GDatatypeInfoOf a) (GCode a),
    meta ~ MetaFor "sum type" ('ShowType a) "sum",
    CompColumn meta fields a arg s
  ) => SumWith b isel imods arg ('DdK 'SelAuto NoMods a ('Comp ('TSel prefix name) 'Sum 'Nest ('DdK isel imods Int64 'Prim : s))) where
  sumWith :: Dd ('DdK isel imods Int64 'Prim)
-> arg
-> Dd
     ('DdK
        'SelAuto
        NoMods
        a
        ('Comp
           ('TSel prefix name) 'Sum 'Nest ('DdK isel imods Int64 'Prim : s)))
sumWith Dd ('DdK isel imods Int64 'Prim)
index arg
arg =
    forall (sel :: Sel) (mods :: [*]) (s1 :: Struct) a.
SelW sel -> Mods mods -> DdStruct s1 -> Dd ('DdK sel mods a s1)
Dd SelW 'SelAuto
SelWAuto forall (ps :: [*]). (ps ~ NoMods) => Mods ps
NoMods (forall (sel :: TSel) (c :: Comp) (i :: CompInc) (sub :: [DdK]).
TSelW sel
-> DdSort c -> DdInc i -> NP Dd sub -> DdStruct ('Comp sel c i sub)
DdComp (forall a (sel :: TSel). CompName a sel => TSelW sel
compName @a) DdSort 'Sum
DdSum DdInc 'Nest
DdNest (Dd ('DdK isel imods Int64 'Prim)
index forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* forall (meta :: CompMeta) (fields :: [ProductField]) a arg
       (s :: [DdK]).
CompColumn meta fields a arg s =>
arg -> NP Dd s
compColumn @meta @fields @a arg
arg))

class DdType s ~ a => Sum a arg s | a arg -> s where
  sum :: arg -> Dd s

-- TODO b ~ a is not needed here, apparently, but it is for ConColumn. investigate and remove here
instance (
    b ~ a,
    CompName a ('TSel prefix name),
    IndexName 'DefaultPrefix name iname,
    fields ~ SumFields (GDatatypeInfoOf a) (GCode a),
    meta ~ MetaFor "sum type" ('ShowType a) "sum",
    CompColumn meta fields a arg s
  ) => Sum b arg ('DdK 'SelAuto NoMods a ('Comp ('TSel prefix name) 'Sum 'Nest (IndexColumn name : s))) where
  sum :: arg
-> Dd
     ('DdK
        'SelAuto
        NoMods
        a
        ('Comp ('TSel prefix name) 'Sum 'Nest (IndexColumn name : s)))
sum =
    forall a (isel :: Sel) (imods :: [*]) arg (s :: DdK).
SumWith a isel imods arg s =>
Dd ('DdK isel imods Int64 'Prim) -> arg -> Dd s
sumWith forall (tpe :: Symbol) (name :: Symbol).
IndexName 'DefaultPrefix tpe name =>
Dd (IndexColumn tpe)
primIndex

sumAs ::
  ∀ (name :: Symbol) (a :: Type) (s :: DdK) (arg :: Type) .
  Sum a arg s =>
  Rename s (SetName s name) =>
  arg ->
  Dd (SetName s name)
sumAs :: forall (name :: Symbol) a (s :: DdK) arg.
(Sum a arg s, Rename s (SetName s name)) =>
arg -> Dd (SetName s name)
sumAs =
  forall (s0 :: DdK) (s1 :: DdK). Rename s0 s1 => Dd s0 -> Dd s1
rename forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a arg (s :: DdK). Sum a arg s => arg -> Dd s
sum @a @_ @s

mergeSum ::
  ∀ (a :: Type) (s :: DdK) (arg :: Type) .
  Sum a arg s =>
  arg ->
  Dd (T.Merge s)
mergeSum :: forall a (s :: DdK) arg. Sum a arg s => arg -> Dd (Merge s)
mergeSum =
  forall (s :: DdK). Dd s -> Dd (Merge s)
merge forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a arg (s :: DdK). Sum a arg s => arg -> Dd s
sum @a @_ @s

class DdType s ~ a => ConColumn a arg s | a arg -> s where
  con :: arg -> Dd s

instance (
    a ~ ConCol name record fields as,
    MkTSel ('TSel 'DefaultPrefix name),
    meta ~ MetaFor "constructor" ('Text name) "con",
    CompColumn meta fields a arg s
  ) => ConColumn a arg ('DdK 'SelAuto NoMods (ConCol name record fields as) ('Comp ('TSel 'DefaultPrefix name) ('Prod ('Con as)) 'Nest s)) where
  con :: arg
-> Dd
     ('DdK
        'SelAuto
        NoMods
        (ConCol name record fields as)
        ('Comp ('TSel 'DefaultPrefix name) ('Prod ('Con as)) 'Nest s))
con arg
arg =
    forall (sel :: Sel) (mods :: [*]) (s1 :: Struct) a.
SelW sel -> Mods mods -> DdStruct s1 -> Dd ('DdK sel mods a s1)
Dd SelW 'SelAuto
SelWAuto forall (ps :: [*]). (ps ~ NoMods) => Mods ps
NoMods (forall (sel :: TSel) (c :: Comp) (i :: CompInc) (sub :: [DdK]).
TSelW sel
-> DdSort c -> DdInc i -> NP Dd sub -> DdStruct ('Comp sel c i sub)
DdComp forall (sel :: TSel). MkTSel sel => TSelW sel
mkTSel forall (as :: [*]). DdSort ('Prod ('Con as))
DdCon DdInc 'Nest
DdNest (forall (meta :: CompMeta) (fields :: [ProductField]) a arg
       (s :: [DdK]).
CompColumn meta fields a arg s =>
arg -> NP Dd s
compColumn @meta @fields @(ConCol name record fields as) arg
arg))

conAs ::
  ∀ (name :: Symbol) (a :: Type) (s :: DdK) (arg :: Type) .
  ConColumn a arg s =>
  Rename s (SetName s name) =>
  arg ->
  Dd (SetName s name)
conAs :: forall (name :: Symbol) a (s :: DdK) arg.
(ConColumn a arg s, Rename s (SetName s name)) =>
arg -> Dd (SetName s name)
conAs =
  forall (s0 :: DdK) (s1 :: DdK). Rename s0 s1 => Dd s0 -> Dd s1
rename forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a arg (s :: DdK). ConColumn a arg s => arg -> Dd s
con @a @_ @s

type family Con1Fields (con :: Type) :: [ProductField] where
  Con1Fields (ConCol _ 'True '[f] _) = '[f]
  Con1Fields (ConCol name 'False '[ 'ProductField _ a] _) = '[ 'ProductField name a]

class DdType s ~ a => Con1Column a arg s | a arg -> s where
  con1 :: arg -> Dd s

instance (
    a ~ ConCol name record fields as,
    TypeName 'DefaultPrefix name tname,
    meta ~ MetaFor "constructor" ('Text name) "con1",
    CompColumn meta (Con1Fields a) a arg s
  ) => Con1Column a arg ('DdK 'SelAuto NoMods (ConCol name record fields as) ('Comp ('TSel 'DefaultPrefix name) ('Prod ('Con as)) 'Merge s)) where
  con1 :: arg
-> Dd
     ('DdK
        'SelAuto
        NoMods
        (ConCol name record fields as)
        ('Comp ('TSel 'DefaultPrefix name) ('Prod ('Con as)) 'Merge s))
con1 arg
arg =
    forall (sel :: Sel) (mods :: [*]) (s1 :: Struct) a.
SelW sel -> Mods mods -> DdStruct s1 -> Dd ('DdK sel mods a s1)
Dd SelW 'SelAuto
SelWAuto forall (ps :: [*]). (ps ~ NoMods) => Mods ps
NoMods (forall (sel :: TSel) (c :: Comp) (i :: CompInc) (sub :: [DdK]).
TSelW sel
-> DdSort c -> DdInc i -> NP Dd sub -> DdStruct ('Comp sel c i sub)
DdComp forall (sel :: TSel). MkTSel sel => TSelW sel
mkTSel forall (as :: [*]). DdSort ('Prod ('Con as))
DdCon DdInc 'Merge
DdMerge (forall (meta :: CompMeta) (fields :: [ProductField]) a arg
       (s :: [DdK]).
CompColumn meta fields a arg s =>
arg -> NP Dd s
compColumn @meta @(Con1Fields a) @(ConCol name record fields as) arg
arg))

type family RenameCon1 (name :: Symbol) (a :: Type) :: Type where
  RenameCon1 name (ConCol _ record '[ 'ProductField _ a] as) =
    ConCol name record '[ 'ProductField name a] as
  RenameCon1 _ a =
    TypeError ("RenameCon1:" % a)

class DdType s ~ a => Con1AsColumn name a arg s | name a arg -> s where
  con1As :: arg -> Dd s

instance (
    a ~ ConCol _name record _fields as,
    TypeName 'DefaultPrefix name tname,
    fields ~ Con1Fields (RenameCon1 name a),
    meta ~ MetaFor "constructor" ('Text name) "con1As",
    CompColumn meta fields a arg s
  ) => Con1AsColumn name a arg ('DdK 'SelAuto NoMods a ('Comp ('TSel 'DefaultPrefix name) ('Prod ('Con as)) 'Merge s)) where
  con1As :: arg
-> Dd
     ('DdK
        'SelAuto
        NoMods
        a
        ('Comp ('TSel 'DefaultPrefix name) ('Prod ('Con as)) 'Merge s))
con1As arg
arg =
    forall (sel :: Sel) (mods :: [*]) (s1 :: Struct) a.
SelW sel -> Mods mods -> DdStruct s1 -> Dd ('DdK sel mods a s1)
Dd SelW 'SelAuto
SelWAuto forall (ps :: [*]). (ps ~ NoMods) => Mods ps
NoMods (forall (sel :: TSel) (c :: Comp) (i :: CompInc) (sub :: [DdK]).
TSelW sel
-> DdSort c -> DdInc i -> NP Dd sub -> DdStruct ('Comp sel c i sub)
DdComp forall (sel :: TSel). MkTSel sel => TSelW sel
mkTSel forall (as :: [*]). DdSort ('Prod ('Con as))
DdCon DdInc 'Merge
DdMerge (forall (meta :: CompMeta) (fields :: [ProductField]) a arg
       (s :: [DdK]).
CompColumn meta fields a arg s =>
arg -> NP Dd s
compColumn @meta @fields @a arg
arg))

type SetIndexPrefix :: Symbol -> DdK -> DdK -> Constraint
class SetIndexPrefix prefix s0 s1 | prefix s0 -> s1 where
  setIndexPrefix :: Dd s0 -> Dd s1

instance (
    IndexName ('SelPrefix prefix) tpe iname
  ) => SetIndexPrefix prefix ('DdK sel mods a ('Comp tsel 'Sum i ('DdK ('SelIndex oldPrefix tpe) NoMods Int64 'Prim : cons))) ('DdK sel mods a ('Comp tsel 'Sum i (IndexColumnWith ('SelPrefix prefix) tpe : cons))) where
    setIndexPrefix :: Dd
  ('DdK
     sel
     mods
     a
     ('Comp
        tsel
        'Sum
        i
        ('DdK ('SelIndex oldPrefix tpe) NoMods Int64 'Prim : cons)))
-> Dd
     ('DdK
        sel
        mods
        a
        ('Comp
           tsel 'Sum i (IndexColumnWith ('SelPrefix prefix) tpe : cons)))
setIndexPrefix (Dd SelW sel
sel Mods mods
mods (DdComp TSelW sel
tsel DdSort c
DdSum DdInc i
i (Dd (SelWIndex Proxy name
Proxy) Mods mods
NoMods DdStruct s1
DdPrim :* NP Dd xs
cons))) =
      forall (sel :: Sel) (mods :: [*]) (s1 :: Struct) a.
SelW sel -> Mods mods -> DdStruct s1 -> Dd ('DdK sel mods a s1)
Dd SelW sel
sel Mods mods
mods (forall (sel :: TSel) (c :: Comp) (i :: CompInc) (sub :: [DdK]).
TSelW sel
-> DdSort c -> DdInc i -> NP Dd sub -> DdStruct ('Comp sel c i sub)
DdComp TSelW sel
tsel DdSort 'Sum
DdSum DdInc i
i (forall (sel :: Sel) (mods :: [*]) (s1 :: Struct) a.
SelW sel -> Mods mods -> DdStruct s1 -> Dd ('DdK sel mods a s1)
Dd (forall (prefix :: SelPrefix) (tpe :: Symbol) (name :: Symbol).
IndexName prefix tpe name =>
Proxy name -> SelW ('SelIndex prefix tpe)
SelWIndex forall {k} (t :: k). Proxy t
Proxy) forall (ps :: [*]). (ps ~ NoMods) => Mods ps
NoMods DdStruct 'Prim
DdPrim forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP Dd xs
cons))
    setIndexPrefix Dd
  ('DdK
     sel
     mods
     a
     ('Comp
        tsel
        'Sum
        i
        ('DdK ('SelIndex oldPrefix tpe) NoMods Int64 'Prim : cons)))
_ =
      forall a. HasCallStack => [Char] -> a
error [Char]
"ghc bug?"

indexPrefix ::
  ∀ prefix s0 s1 .
  SetIndexPrefix prefix s0 s1 =>
  Dd s0 ->
  Dd s1
indexPrefix :: forall (prefix :: Symbol) (s0 :: DdK) (s1 :: DdK).
SetIndexPrefix prefix s0 s1 =>
Dd s0 -> Dd s1
indexPrefix =
  forall (prefix :: Symbol) (s0 :: DdK) (s1 :: DdK).
SetIndexPrefix prefix s0 s1 =>
Dd s0 -> Dd s1
setIndexPrefix @prefix