{-# LANGUAGE QualifiedDo #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Language.Haskell.TH.Natural.Syntax.Expr.Typed.Class (
    IsTypedExprBuilder (..),
    genExpr,
    addDeconstruct,
    addLet,
    letCount,
    returns,
    strictLetBind,
    letBind,
    letBind_,
) where

import Data.Constructor.Extract.Class
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH.Gen (GenTExpr (genTExpr))
import Language.Haskell.TH.Natural.Syntax.Builder as B
import Language.Haskell.TH.Natural.Syntax.Expr.Internal
import Language.Haskell.TH.Natural.Syntax.Expr.Typed.Builder
import Language.Haskell.TH.Natural.Syntax.Expr.Untyped (Definition, IsExprBuilder, runExprBuilder)
import qualified Language.Haskell.TH.Natural.Syntax.Expr.Untyped as Untyped
import qualified Language.Haskell.TH.Syntax as TH

class IsTypedExprBuilder st where
    runTypedExprBuilder ::
        TypedExprBuilder st '[] args (Returns a) () ->
        TH.Q (TH.TExp (args :~> Returns a))

instance (IsExprBuilder st, Definition st ~ TH.Q a, ExtractedConstructor a TH.Exp) => IsTypedExprBuilder st where
    runTypedExprBuilder :: forall (args :: [*]) a.
TypedExprBuilder st '[] args (Returns a) ()
-> Q (TExp (args :~> Returns a))
runTypedExprBuilder (MkTEB ConstBuilder st ()
b) = Exp -> TExp (args :~> Returns a)
forall a. Exp -> TExp a
TH.TExp (Exp -> TExp (args :~> Returns a))
-> (a -> Exp) -> a -> TExp (args :~> Returns a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Exp
forall con ty. ExtractedConstructor con ty => con -> ty
fromEC (a -> TExp (args :~> Returns a))
-> Q a -> Q (TExp (args :~> Returns a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConstBuilder st () -> Definition st
forall st (step :: BuilderStep).
IsExprBuilder st =>
Builder st step 'Ready () -> Definition st
forall (step :: BuilderStep).
Builder st step 'Ready () -> Definition st
runExprBuilder ConstBuilder st ()
b

-- TODO Instance of GenTexp

-- | Alias to 'runTypedExprBuilder'
genExpr :: (IsExprBuilder st, Definition st ~ TH.Q a, ExtractedConstructor a TH.Exp) => TypedExprBuilder st '[] args (Returns a) () -> TH.Q (TH.TExp (args :~> Returns a))
genExpr :: forall st a (args :: [*]).
(IsExprBuilder st, Definition st ~ Q a,
 ExtractedConstructor a Exp) =>
TypedExprBuilder st '[] args (Returns a) ()
-> Q (TExp (args :~> Returns a))
genExpr = TypedExprBuilder st '[] args (Returns a) ()
-> Q (TExp (args :~> Returns a))
forall (args :: [*]) a.
TypedExprBuilder st '[] args (Returns a) ()
-> Q (TExp (args :~> Returns a))
forall st (args :: [*]) a.
IsTypedExprBuilder st =>
TypedExprBuilder st '[] args (Returns a) ()
-> Q (TExp (args :~> Returns a))
runTypedExprBuilder

addDeconstruct :: (IsExprBuilder st) => Deconstruct -> TypedExprBuilder st args args Unknown ()
addDeconstruct :: forall {a} st (args :: [*]).
IsExprBuilder st =>
Deconstruct -> TypedExprBuilder st args args 'Unknown ()
addDeconstruct = Builder st (ZonkAny 5) 'Empty ()
-> TypedExprBuilder st args args 'Unknown ()
forall {k1} {k2} s (step :: k1) (step1 :: k1) a (args0 :: [*])
       (args :: [*]) (res :: k2).
Builder s step step1 a -> TypedExprBuilder s args0 args res a
unsafeUntyped (Builder st (ZonkAny 5) 'Empty ()
 -> TypedExprBuilder st args args 'Unknown ())
-> (Deconstruct -> Builder st (ZonkAny 5) 'Empty ())
-> Deconstruct
-> TypedExprBuilder st args args 'Unknown ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Deconstruct -> Builder st (ZonkAny 5) 'Empty ()
forall st (step :: BuilderStep).
IsExprBuilder st =>
Deconstruct -> Builder st step 'Empty ()
forall (step :: BuilderStep).
Deconstruct -> Builder st step 'Empty ()
Untyped.addDeconstruct

addLet :: (IsExprBuilder st) => Binding -> TypedExprBuilder st args args Unknown ()
addLet :: forall {a} st (args :: [*]).
IsExprBuilder st =>
Binding -> TypedExprBuilder st args args 'Unknown ()
addLet = Builder st (ZonkAny 4) 'Empty ()
-> TypedExprBuilder st args args 'Unknown ()
forall {k1} {k2} s (step :: k1) (step1 :: k1) a (args0 :: [*])
       (args :: [*]) (res :: k2).
Builder s step step1 a -> TypedExprBuilder s args0 args res a
unsafeUntyped (Builder st (ZonkAny 4) 'Empty ()
 -> TypedExprBuilder st args args 'Unknown ())
-> (Binding -> Builder st (ZonkAny 4) 'Empty ())
-> Binding
-> TypedExprBuilder st args args 'Unknown ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binding -> Builder st (ZonkAny 4) 'Empty ()
forall st (step :: BuilderStep).
IsExprBuilder st =>
Binding -> Builder st step 'Empty ()
forall (step :: BuilderStep). Binding -> Builder st step 'Empty ()
Untyped.addLet

letCount :: (IsExprBuilder st) => TypedExprBuilder st args args res Int
letCount :: forall {k} st (args :: [*]) (res :: k).
IsExprBuilder st =>
TypedExprBuilder st args args res Int
letCount = Builder st (ZonkAny 3) (ZonkAny 3) Int
-> TypedExprBuilder st args args res Int
forall {k1} {k2} s (step :: k1) (step1 :: k1) a (args0 :: [*])
       (args :: [*]) (res :: k2).
Builder s step step1 a -> TypedExprBuilder s args0 args res a
unsafeUntyped Builder st (ZonkAny 3) (ZonkAny 3) Int
forall st {k} (step :: k).
IsExprBuilder st =>
Builder st step step Int
forall {k} (step :: k). Builder st step step Int
Untyped.letCount

returns ::
    forall t b args st.
    (IsExprBuilder st) =>
    (GenTExpr t b) =>
    b -> TypedExprBuilder st args args (Returns t) ()
returns :: forall t b (args :: [*]) st.
(IsExprBuilder st, GenTExpr t b) =>
b -> TypedExprBuilder st args args (Returns t) ()
returns b
b = Builder st (ZonkAny 1) 'Ready ()
-> TypedExprBuilder st args args (Returns t) ()
forall {k1} {k2} s (step :: k1) (step1 :: k1) a (args0 :: [*])
       (args :: [*]) (res :: k2).
Builder s step step1 a -> TypedExprBuilder s args0 args res a
unsafeUntyped (Builder st (ZonkAny 1) 'Ready ()
 -> TypedExprBuilder st args args (Returns t) ())
-> Builder st (ZonkAny 1) 'Ready ()
-> TypedExprBuilder st args args (Returns t) ()
forall a b. (a -> b) -> a -> b
$ B.do
    e <- TExp t -> Exp
forall a. TExp a -> Exp
TH.unType (TExp t -> Exp)
-> BaseBuilder Q st (ZonkAny 1) (ZonkAny 1) (TExp t)
-> BaseBuilder Q st (ZonkAny 1) (ZonkAny 1) Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q (TExp t) -> BaseBuilder Q st (ZonkAny 1) (ZonkAny 1) (TExp t)
forall {k} (m :: * -> *) a s (step :: k).
Monad m =>
m a -> BaseBuilder m s step step a
liftB (forall t a. GenTExpr t a => a -> Q (TExp t)
genTExpr @t b
b)
    Untyped.returns e

strictLetBind :: (IsExprBuilder st, GenTExpr t b) => b -> TypedExprBuilder st args args Unknown (TH.TExp t)
strictLetBind :: forall {a} st t b (args :: [*]).
(IsExprBuilder st, GenTExpr t b) =>
b -> TypedExprBuilder st args args 'Unknown (TExp t)
strictLetBind = Bool -> b -> TypedExprBuilder st args args 'Unknown (TExp t)
forall {a} t b st (args :: [*]).
(IsExprBuilder st, GenTExpr t b) =>
Bool -> b -> TypedExprBuilder st args args 'Unknown (TExp t)
letBind_ Bool
True

letBind :: (IsExprBuilder st, GenTExpr t b) => b -> TypedExprBuilder st args args Unknown (TH.TExp t)
letBind :: forall {a} st t b (args :: [*]).
(IsExprBuilder st, GenTExpr t b) =>
b -> TypedExprBuilder st args args 'Unknown (TExp t)
letBind = Bool -> b -> TypedExprBuilder st args args 'Unknown (TExp t)
forall {a} t b st (args :: [*]).
(IsExprBuilder st, GenTExpr t b) =>
Bool -> b -> TypedExprBuilder st args args 'Unknown (TExp t)
letBind_ Bool
False

letBind_ :: forall t b st args. (IsExprBuilder st, GenTExpr t b) => Bool -> b -> TypedExprBuilder st args args Unknown (TH.TExp t)
letBind_ :: forall {a} t b st (args :: [*]).
(IsExprBuilder st, GenTExpr t b) =>
Bool -> b -> TypedExprBuilder st args args 'Unknown (TExp t)
letBind_ Bool
isStrict b
b = ConstBuilder st (TExp t)
-> TypedExprBuilder st args args 'Unknown (TExp t)
forall k s (prevArgs :: [*]) (args :: [*]) (res :: k) a.
ConstBuilder s a -> TypedExprBuilder s prevArgs args res a
MkTEB (ConstBuilder st (TExp t)
 -> TypedExprBuilder st args args 'Unknown (TExp t))
-> ConstBuilder st (TExp t)
-> TypedExprBuilder st args args 'Unknown (TExp t)
forall a b. (a -> b) -> a -> b
$ B.do
    e <- TExp t -> Exp
forall a. TExp a -> Exp
TH.unType (TExp t -> Exp)
-> ConstBuilder st (TExp t) -> BaseBuilder Q st 'Ready 'Ready Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q (TExp t) -> ConstBuilder st (TExp t)
forall {k} (m :: * -> *) a s (step :: k).
Monad m =>
m a -> BaseBuilder m s step step a
liftB (forall t a. GenTExpr t a => a -> Q (TExp t)
genTExpr @t b
b)
    unsafeCastStep (TH.TExp <$> Untyped.letBind_ isStrict e)