module Hasql.TH.Extraction.PlaceholderTypeMap where

import qualified Data.IntMap.Strict as IntMap
import Hasql.TH.Extraction.ChildExprList (ChildExpr (..))
import qualified Hasql.TH.Extraction.ChildExprList as ChildExprList
import Hasql.TH.Prelude hiding (union)
import PostgresqlSyntax.Ast

preparableStmt :: PreparableStmt -> Either Text (IntMap Typename)
preparableStmt :: PreparableStmt -> Either Text (IntMap Typename)
preparableStmt = [ChildExpr] -> Either Text (IntMap Typename)
childExprList forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. PreparableStmt -> [ChildExpr]
ChildExprList.preparableStmt

childExprList :: [ChildExpr] -> Either Text (IntMap Typename)
childExprList :: [ChildExpr] -> Either Text (IntMap Typename)
childExprList = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM IntMap Typename -> IntMap Typename -> Either Text (IntMap Typename)
union forall a. IntMap a
IntMap.empty forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ChildExpr -> Either Text (IntMap Typename)
childExpr

union :: IntMap Typename -> IntMap Typename -> Either Text (IntMap Typename)
union :: IntMap Typename -> IntMap Typename -> Either Text (IntMap Typename)
union IntMap Typename
a IntMap Typename
b = forall a b c.
(Key -> a -> b -> Maybe c)
-> (IntMap a -> IntMap c)
-> (IntMap b -> IntMap c)
-> IntMap a
-> IntMap b
-> IntMap c
IntMap.mergeWithKey forall {b} {a} {t}.
(Eq b, Semigroup a, IsString a, Show t) =>
t -> b -> b -> Maybe (Either a b)
merge (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right) IntMap Typename
a IntMap Typename
b forall a b. a -> (a -> b) -> b
& forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
  where
    merge :: t -> b -> b -> Maybe (Either a b)
merge t
index b
a b
b =
      if b
a forall a. Eq a => a -> a -> Bool
== b
b
        then forall a. a -> Maybe a
Just (forall a b. b -> Either a b
Right b
a)
        else forall a. a -> Maybe a
Just (forall a b. a -> Either a b
Left (a
"Placeholder $" forall a. Semigroup a => a -> a -> a
<> (forall a. IsString a => String -> a
fromString forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Show a => a -> String
show) t
index forall a. Semigroup a => a -> a -> a
<> a
" has conflicting type annotations"))

childExpr :: ChildExpr -> Either Text (IntMap Typename)
childExpr :: ChildExpr -> Either Text (IntMap Typename)
childExpr = \case
  AChildExpr AExpr
a -> AExpr -> Either Text (IntMap Typename)
aExpr AExpr
a
  BChildExpr BExpr
a -> BExpr -> Either Text (IntMap Typename)
bExpr BExpr
a
  CChildExpr CExpr
a -> CExpr -> Either Text (IntMap Typename)
cExpr CExpr
a

aExpr :: AExpr -> Either Text (IntMap Typename)
aExpr = \case
  CExprAExpr CExpr
a -> CExpr -> Either Text (IntMap Typename)
cExpr CExpr
a
  TypecastAExpr AExpr
a Typename
b -> Typename -> AExpr -> Either Text (IntMap Typename)
castedAExpr Typename
b AExpr
a
  AExpr
a -> [ChildExpr] -> Either Text (IntMap Typename)
childExprList (AExpr -> [ChildExpr]
ChildExprList.aChildExpr AExpr
a)

bExpr :: BExpr -> Either Text (IntMap Typename)
bExpr = \case
  CExprBExpr CExpr
a -> CExpr -> Either Text (IntMap Typename)
cExpr CExpr
a
  TypecastBExpr BExpr
a Typename
b -> Typename -> BExpr -> Either Text (IntMap Typename)
castedBExpr Typename
b BExpr
a
  BExpr
a -> [ChildExpr] -> Either Text (IntMap Typename)
childExprList (BExpr -> [ChildExpr]
ChildExprList.bChildExpr BExpr
a)

cExpr :: CExpr -> Either Text (IntMap Typename)
cExpr = \case
  ParamCExpr Key
a Maybe Indirection
_ -> forall a b. a -> Either a b
Left (Text
"Placeholder $" forall a. Semigroup a => a -> a -> a
<> (forall a. IsString a => String -> a
fromString forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Show a => a -> String
show) Key
a forall a. Semigroup a => a -> a -> a
<> Text
" misses an explicit typecast")
  CExpr
a -> [ChildExpr] -> Either Text (IntMap Typename)
childExprList (CExpr -> [ChildExpr]
ChildExprList.cChildExpr CExpr
a)

castedAExpr :: Typename -> AExpr -> Either Text (IntMap Typename)
castedAExpr Typename
a = \case
  CExprAExpr CExpr
b -> Typename -> CExpr -> Either Text (IntMap Typename)
castedCExpr Typename
a CExpr
b
  TypecastAExpr AExpr
b Typename
c -> Typename -> AExpr -> Either Text (IntMap Typename)
castedAExpr Typename
c AExpr
b
  AExpr
b -> AExpr -> Either Text (IntMap Typename)
aExpr AExpr
b

castedBExpr :: Typename -> BExpr -> Either Text (IntMap Typename)
castedBExpr Typename
a = \case
  CExprBExpr CExpr
b -> Typename -> CExpr -> Either Text (IntMap Typename)
castedCExpr Typename
a CExpr
b
  TypecastBExpr BExpr
b Typename
c -> Typename -> BExpr -> Either Text (IntMap Typename)
castedBExpr Typename
c BExpr
b
  BExpr
b -> BExpr -> Either Text (IntMap Typename)
bExpr BExpr
b

castedCExpr :: Typename -> CExpr -> Either Text (IntMap Typename)
castedCExpr Typename
a = \case
  ParamCExpr Key
b Maybe Indirection
_ -> forall a b. b -> Either a b
Right (forall a. Key -> a -> IntMap a
IntMap.singleton Key
b Typename
a)
  InParensCExpr AExpr
b Maybe Indirection
_ -> Typename -> AExpr -> Either Text (IntMap Typename)
castedAExpr Typename
a AExpr
b
  CExpr
b -> CExpr -> Either Text (IntMap Typename)
cExpr CExpr
b