{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP             #-}
{-# LANGUAGE TemplateHaskell #-}

module Database.Bolt.Extras.Template.Internal.Converters
 (
    makeNodeLike
  , makeNodeLikeWith
  , makeURelationLike
  , makeURelationLikeWith
  ) where

import           Data.Map.Strict            (fromList, member, notMember, (!))
import           Data.Text                  (Text, pack, unpack)
import           Database.Bolt (Node (..), URelationship (..), Value (..), IsValue(..), RecordValue(..))
import           Database.Bolt.Extras       (Labels (..),
                                             NodeLike (..),
                                             Properties (..),
                                             URelationLike (..))
import           Database.Bolt.Extras.Utils (currentLoc, dummyId)
import           Instances.TH.Lift          ()
import           Language.Haskell.TH
import           Language.Haskell.TH.Syntax
import           GHC.Stack                  (HasCallStack)

-- Starting with template-haskell-2.16.0.0, 'TupE' constructor accepts @Maybe Exp@, to support
-- TupleSections. We use this alias for compatibility with both old and new versions.
tupE' :: [Exp] -> Exp
#if MIN_VERSION_template_haskell(2, 16, 0)
tupE' :: [Exp] -> Exp
tupE' = [Maybe Exp] -> Exp
TupE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just
#else
tupE' = TupE
#endif


-- | Describes a @bijective@ class, i.e. class that has two functions: @phi :: a -> SomeType@ and @phiInv :: SomeType -> a@.
-- Requires class name, @SomeType@ name and names of the class functions (@phi@ and @phiInv@).
--
data BiClassInfo = BiClassInfo { BiClassInfo -> Name
className    :: Name
                               , BiClassInfo -> Name
dataName     :: Name
                               , BiClassInfo -> Name
classToFun   :: Name
                               , BiClassInfo -> Name
classFromFun :: Name
                               }

-- | Example of @bijective@ class is 'NodeLike'.
-- Describes conversions into and from 'Node'.
-- That is, this class provides a bridge between Neo4j world and Haskell world.
--
nodeLikeClass :: BiClassInfo
nodeLikeClass :: BiClassInfo
nodeLikeClass = BiClassInfo { className :: Name
className     = ''NodeLike
                            , dataName :: Name
dataName      = 'Node
                            , classToFun :: Name
classToFun    = 'toNode
                            , classFromFun :: Name
classFromFun  = 'fromNode
                            }

-- | Another example of @bijective@ class is 'URelationLike'.
-- Describes conversions into and from 'URelationship'.
--
uRelationLikeClass :: BiClassInfo
uRelationLikeClass :: BiClassInfo
uRelationLikeClass = BiClassInfo { className :: Name
className    = ''URelationLike
                                 , dataName :: Name
dataName     = 'URelationship
                                 , classToFun :: Name
classToFun   = 'toURelation
                                 , classFromFun :: Name
classFromFun = 'fromURelation
                                 }

-- | Make an instance of 'NodeLike' class.
-- Only data types with one constructor are currently supported.
-- Each field is transformed into 'Text' key and its value is transformed into a 'Value'.
-- For example, we have a structure and define an instance:
--
-- >>> :{
-- data Foo = Bar
--   { baz  :: Double
--   , quux :: Text
--   , quuz :: Maybe Int
--   } deriving (Show)
-- makeNodeLike ''Foo
-- :}
--
-- Then you may create example and convert it to and from Node:
--
-- >>> let foo = Bar 42.0 "Loren ipsum" (Just 7)
-- >>> toNode foo
-- Node {nodeIdentity = -1, labels = ["Foo"], nodeProps = fromList [("baz",F 42.0),("quux",T "Loren ipsum"),("quuz",I 7)]}
-- >>> fromNode . toNode $ foo :: Foo
-- Bar {baz = 42.0, quux = "Loren ipsum", quuz = Just 7}
--
-- 'Maybe' fields are handled correctly:
--
-- >>> let bar = Bar 42.0 "Hello world" Nothing
-- >>> toNode bar
-- Node {nodeIdentity = -1, labels = ["Foo"], nodeProps = fromList [("baz",F 42.0),("quux",T "Hello world"),("quuz",N ())]}
-- >>> :{
-- let barNode = Node
--       { nodeIdentity = -1
--       , labels = ["Foo"]
--       , nodeProps = fromList [("baz", F 42.0), ("quux", T "Hello world")] -- No "quuz" here
--       }
-- :}
--
-- >>> fromNode barNode :: Foo
-- Bar {baz = 42.0, quux = "Hello world", quuz = Nothing}
makeNodeLike :: HasCallStack => Name -> Q [Dec]
makeNodeLike :: HasCallStack => Name -> Q [Dec]
makeNodeLike Name
name = HasCallStack =>
BiClassInfo -> Name -> (String -> String) -> Q [Dec]
makeBiClassInstance BiClassInfo
nodeLikeClass Name
name forall a. a -> a
id

-- | The same as 'makeNodeLike', but applies a function to all field names before storing them
-- in Neo4j, like @aeson@ does.
--
-- This can be used with @fieldLabelModifier@ from 'Data.Aeson.Types.Options' in @aeson@:
--
-- > makeNodeLikeWith ''Foo $ fieldLabelModifier $ aesonPrefix camelCase
--
makeNodeLikeWith :: HasCallStack => Name -> (String -> String) -> Q [Dec]
makeNodeLikeWith :: HasCallStack => Name -> (String -> String) -> Q [Dec]
makeNodeLikeWith = HasCallStack =>
BiClassInfo -> Name -> (String -> String) -> Q [Dec]
makeBiClassInstance BiClassInfo
nodeLikeClass

-- | Make an instance of 'URelationLike' class.
-- Transformations are the same as in 'NodeLike' instance declaration with the only one difference:
-- 'URelationship' holds only one label (or type), but 'Node' holds list of labels.
--
makeURelationLike :: HasCallStack => Name -> Q [Dec]
makeURelationLike :: HasCallStack => Name -> Q [Dec]
makeURelationLike Name
name = HasCallStack =>
BiClassInfo -> Name -> (String -> String) -> Q [Dec]
makeBiClassInstance BiClassInfo
uRelationLikeClass Name
name forall a. a -> a
id

-- | As 'makeNodeLikeWith'.
makeURelationLikeWith :: HasCallStack => Name -> (String -> String) -> Q [Dec]
makeURelationLikeWith :: HasCallStack => Name -> (String -> String) -> Q [Dec]
makeURelationLikeWith = HasCallStack =>
BiClassInfo -> Name -> (String -> String) -> Q [Dec]
makeBiClassInstance BiClassInfo
uRelationLikeClass

-- | Declare an instance of `bijective` class using TemplateHaskell.
-- It works as follows:
-- Say we have a type with field records, e.g.
--
-- > data VariableDomainScoring = VDS { specie   :: Text
-- >                                  , vgen     :: Double
-- >                                  , fr       :: Double
-- >                                  , sim      :: Double
-- >                                  , germline :: Text
-- >                                  }
--
-- As an example, transformation into Node is described below.
--
-- > data Node = Node { nodeIdentity :: Int             -- ^Neo4j node identifier
-- >                  , labels       :: [Text]          -- ^Set of node labels (types)
-- >                  , nodeProps    :: Map Text Value  -- ^Dict of node properties
-- >                  }
-- >  deriving (Show, Eq)
--
-- @nodeIdentity@ will be set to a dummy value (-1). There is no way of obtaining object ID before uploading it into database.
-- @labels@ will be set to type name, i.e. @VariableDomainScoring@. This is due to our convention: object label into Neo4j is the same as its type name in Haskell.
-- @nodeProps@ will be set to a Map: keys are field record names, values are data in the corresponding fields.
--
-- Therefore, applying toNode on a @VariableDomainScoring@ will give the following:
-- > Node { nodeIdentity = -1
-- >      , labels = ["VariableDomainScoring"]
-- >      , nodeProps = fromList [("specie", T "text value"), ("vgen", F %float_value), ("fr", F %float_value), ("sim", F %float_value), ("germline", T "text value")]
-- >     }
--
makeBiClassInstance :: HasCallStack => BiClassInfo -> Name -> (String -> String) -> Q [Dec]
makeBiClassInstance :: HasCallStack =>
BiClassInfo -> Name -> (String -> String) -> Q [Dec]
makeBiClassInstance BiClassInfo {Name
classFromFun :: Name
classToFun :: Name
dataName :: Name
className :: Name
classFromFun :: BiClassInfo -> Name
classToFun :: BiClassInfo -> Name
dataName :: BiClassInfo -> Name
className :: BiClassInfo -> Name
..} Name
typeCon String -> String
fieldLabelModifier = do
  -- reify function gives Info about Name such as constructor name and its fields. See: https://hackage.haskell.org/package/template-haskell-2.12.0.0/docs/Language-Haskell-TH.html#t:Info
  TyConI Dec
declaration <- Name -> Q Info
reify Name
typeCon

  -- get type declaration parameters: type name and fields. Supports data and newtype only. These will be used in properties Map formation.
  let (Name
tyName, [Con]
constr) = HasCallStack => Dec -> (Name, [Con])
getTypeCons Dec
declaration

  -- nameBase gives object name without package prefix. `label` is the type name here.
  let label :: String
label = Name -> String
nameBase Name
tyName

  -- collects names and types of all fields in the type.
  let ([Name]
dataFields, [Type]
fieldTypes) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Con -> (Name, [(Name, Type)])
getConsFields) [Con]
constr

  -- gets data constructor name
  let (Name
consName, [(Name, Type)]
_) = forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HasCallStack => Con -> (Name, [(Name, Type)])
getConsFields [Con]
constr

  -- Just a fresh variable. It will be used in labmda abstractions in makeFromClause function.
  Name
fresh <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"

  -- constructs `bijective` class functions (phi and phiInv – toClause and fromClause correspondingly here).
  Clause
toClause   <- String -> Name -> Name -> [Name] -> (String -> String) -> Q Clause
makeToClause String
label Name
dataName Name
consName [Name]
dataFields String -> String
fieldLabelModifier
  Clause
fromClause <- String
-> Name
-> Name
-> [Name]
-> [Type]
-> (String -> String)
-> Q Clause
makeFromClause String
label Name
consName Name
fresh [Name]
dataFields [Type]
fieldTypes String -> String
fieldLabelModifier

  -- function declarations themselves.
  let bodyDecl :: [Dec]
bodyDecl = [Name -> [Clause] -> Dec
FunD Name
classToFun [Clause
toClause], Name -> [Clause] -> Dec
FunD Name
classFromFun [Clause
fromClause]]

  -- Instance declaration itself.
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD forall a. Maybe a
Nothing [] (Type -> Type -> Type
AppT (Name -> Type
ConT Name
className) (Name -> Type
ConT Name
typeCon)) [Dec]
bodyDecl]

-- | Extract information about type: constructor name and field record names with corresponding types.
--
getConsFields :: HasCallStack => Con -> (Name, [(Name, Type)])
getConsFields :: HasCallStack => Con -> (Name, [(Name, Type)])
getConsFields (RecC Name
cName [VarBangType]
decs)           = (Name
cName, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Name
fname, Bang
_, Type
ftype) -> (Name
fname, Type
ftype)) [VarBangType]
decs)
getConsFields (ForallC [TyVarBndr Specificity]
_ [Type]
_ Con
cons)          = HasCallStack => Con -> (Name, [(Name, Type)])
getConsFields Con
cons
getConsFields (RecGadtC (Name
cName:[Name]
_) [VarBangType]
decs Type
_) = (Name
cName, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Name
fname, Bang
_, Type
ftype) -> (Name
fname, Type
ftype)) [VarBangType]
decs)
getConsFields (NormalC Name
cName [BangType]
_)           = (Name
cName, [])
getConsFields Con
_                           = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ $String
currentLoc forall a. [a] -> [a] -> [a]
++ String
"unsupported data declaration."


-- | Parse a type declaration and retrieve its name and its constructors.
--
getTypeCons :: HasCallStack => Dec -> (Name, [Con])
getTypeCons :: HasCallStack => Dec -> (Name, [Con])
getTypeCons (DataD    [Type]
_ Name
typeName [TyVarBndr ()]
_ Maybe Type
_ [Con]
constructors [DerivClause]
_) = (Name
typeName, [Con]
constructors)
getTypeCons (NewtypeD [Type]
_ Name
typeName [TyVarBndr ()]
_ Maybe Type
_ Con
constructor  [DerivClause]
_) = (Name
typeName, [Con
constructor])
getTypeCons Dec
otherDecl = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ $String
currentLoc forall a. [a] -> [a] -> [a]
++ String
"unsupported declaration: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Dec
otherDecl forall a. [a] -> [a] -> [a]
++ String
"\nShould be either 'data' or 'newtype'."

-- | Describes the body of conversion to target type function.
--
makeToClause :: String -> Name -> Name -> [Name] -> (String -> String) -> Q Clause
makeToClause :: String -> Name -> Name -> [Name] -> (String -> String) -> Q Clause
makeToClause String
label Name
dataCons Name
consName [Name]
dataFields String -> String
fieldLabelModifier
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
dataFields = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
WildP] (Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ [Name] -> Exp
result []) []
  | Bool
otherwise       = do
    [Name]
fieldVars <- forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequenceQ forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => String -> m Name
newName String
"_field" forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Name]
dataFields -- var for each field
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [[Name] -> Pat
recPat [Name]
fieldVars] (Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ [Name] -> Exp
result [Name]
fieldVars) []
  where
    -- construct record pattern: (Rec {f1 = v1, ... })
    recPat :: [Name] -> Pat
    recPat :: [Name] -> Pat
recPat [Name]
fieldVars = Pat -> Pat
ParensP forall a b. (a -> b) -> a -> b
$ Name -> [FieldPat] -> Pat
RecP Name
consName forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
dataFields forall a b. (a -> b) -> a -> b
$ Name -> Pat
VarP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
fieldVars

    -- List of values which a data holds.
    -- The same in terms of Haskell :: valuesExp = fmap (\field -> toValue fieldVar)
    valuesExp :: [Name] -> [Exp]
    valuesExp :: [Name] -> [Exp]
valuesExp = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'toValue) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE)

    -- Retrieve all field record names from the convertible type.
    fieldNames :: [String]
    fieldNames :: [String]
fieldNames = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> String
nameBase [Name]
dataFields

    -- List of pairs :: [(key, value)]
    -- `key` is field record name.
    -- `value` is the data that corresponding field holds.
    pairs :: [Name] -> [Exp]
    pairs :: [Name] -> [Exp]
pairs = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\String
fld Exp
val -> [Exp] -> Exp
tupE' [String -> Exp
strToTextE forall a b. (a -> b) -> a -> b
$ String -> String
fieldLabelModifier String
fld, Exp
val]) [String]
fieldNames forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> [Exp]
valuesExp

    -- Map representation:
    -- mapE = fromList pairs
    -- in terms of Haskell.
    mapE :: [Name] -> Exp
    mapE :: [Name] -> Exp
mapE [Name]
vars = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'fromList) ([Exp] -> Exp
ListE forall a b. (a -> b) -> a -> b
$ [Name] -> [Exp]
pairs [Name]
vars)

    -- A bit of crutches.
    -- The difference between Node and URelationship is in the number of labels they hold.
    -- strToTextE returns Text packed in Exp so `id` is applied to it when constructing URelationship.
    -- Node takes list of labels so the label must be packed into list using ListE . (:[])
    fieldFun :: Exp -> Exp
    fieldFun :: Exp -> Exp
fieldFun | Name -> String
nameBase Name
dataCons forall a. Eq a => a -> a -> Bool
== String
"URelationship" = forall a. a -> a
id
             | Name -> String
nameBase Name
dataCons forall a. Eq a => a -> a -> Bool
== String
"Node"          = [Exp] -> Exp
ListE forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[])
             | Bool
otherwise                = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ $String
currentLoc forall a. [a] -> [a] -> [a]
++ String
"unsupported data type."

    -- In terms of Haskell:
    -- dataCons (fromIntegral dummyId) (fieldFun label) mapE
    -- Constructs data with three fields.
    result :: [Name] -> Exp
    result :: [Name] -> Exp
result = Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
dataCons) (Lit -> Exp
LitE forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
IntegerL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
dummyId)) (Exp -> Exp
fieldFun forall a b. (a -> b) -> a -> b
$ String -> Exp
strToTextE String
label)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Exp
mapE


-- | Describes the body of conversion from target type function.
--
makeFromClause :: String -> Name -> Name -> [Name] -> [Type] -> (String -> String) -> Q Clause
makeFromClause :: String
-> Name
-> Name
-> [Name]
-> [Type]
-> (String -> String)
-> Q Clause
makeFromClause String
label Name
conName Name
varName [Name]
dataFields [Type]
fieldTypes String -> String
fieldLabelModifier = do
  -- Contains 'True' in each position where 'Maybe a' type occured and 'False' everywhere else.
  let maybeFields :: [Bool]
maybeFields = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Bool
isMaybe [Type]
fieldTypes

  -- fieldNames :: [Text]
  -- field records of the target type.
  let fieldNames :: [Text]
fieldNames = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
fieldLabelModifier forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) [Name]
dataFields

  -- maybeLabels :: [(Text, Bool)]
  -- field records of the target type and 'isMaybe' check results.
  let maybeNames :: [(Text, Bool)]
maybeNames = forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
fieldNames [Bool]
maybeFields

  -- dataLabel :: Text
  -- Label a.k.a type name
  let dataLabel :: Text
dataLabel = String -> Text
pack String
label

  -- Field record names packed in Exp
  -- \x -> [|x|] :: a -> Q Exp
  -- Therefore, fieldNamesE :: [Exp]
  [Exp]
fieldNamesE <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Text
x -> [|x|]) [Text]
fieldNames

  -- maybeNamesE :: [Exp]
  -- Contains Exp representation of (Text, Bool) – field name and isMaybe check result on it.
  let maybeNamesE :: [Exp]
maybeNamesE = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Exp
n Bool
m -> [Exp] -> Exp
tupE' [Exp
n, Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ if Bool
m then Name
trueName else Name
falseName]) [Exp]
fieldNamesE [Bool]
maybeFields

  -- varExp :: Q Exp
  -- Pattern match variable packed in Exp. It will be used in QuasiQuotation below.
  let varExp :: Q Exp
varExp = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Exp
VarE Name
varName)

  -- Guard checks that all necessary fields are present in the container.
  Guard
guardSuccess <- Exp -> Guard
NormalG forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [|checkLabels $(varExp) [dataLabel] && checkProps $(varExp) maybeNames|]

  -- `otherwise` case.
  Guard
guardFail <- Exp -> Guard
NormalG forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [|otherwise|]

  -- Unpack error message.
  Exp
failExp <- [|unpackError $(varExp) (unpack dataLabel)|]

  -- Kind of this function realization in terms of Haskell:
  -- fromNode :: Node -> a
  -- fromNode varName | checkLabels varName [dataLabel] && checkProps varName fieldNames = ConName (getProp varName "fieldName1") (getProp varName "fieldName2") ...
  --                  | otherwise = unpackError varName (unpack dataLabel)
  let successExp :: Exp
successExp = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Exp
a Exp
f -> Exp -> Exp -> Exp
AppE Exp
a forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'getProp) (Name -> Exp
VarE Name
varName)) Exp
f) (Name -> Exp
ConE Name
conName) [Exp]
maybeNamesE
  let successCase :: (Guard, Exp)
successCase = (Guard
guardSuccess, Exp
successExp)
  let failCase :: (Guard, Exp)
failCase = (Guard
guardFail, Exp
failExp)

  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
varName] ([(Guard, Exp)] -> Body
GuardedB [(Guard, Exp)
successCase, (Guard, Exp)
failCase]) []


-- | Check whether given type is 'Maybe _'
-- It pattern matches type T applied to any argument and checks if T is ''Maybe
isMaybe :: Type -> Bool
isMaybe :: Type -> Bool
isMaybe (AppT (ConT Name
t) Type
_) = Name
t forall a. Eq a => a -> a -> Bool
== ''Maybe
isMaybe Type
_                 = Bool
False

strToTextE :: String -> Exp
strToTextE :: String -> Exp
strToTextE String
str = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'pack) (Lit -> Exp
LitE forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL forall a b. (a -> b) -> a -> b
$ String
str)

checkProps :: Properties t => t -> [(Text, Bool)] -> Bool
checkProps :: forall t. Properties t => t -> [(Text, Bool)] -> Bool
checkProps t
container = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(Text
fieldName, Bool
fieldMaybe) -> Bool
fieldMaybe Bool -> Bool -> Bool
|| Text
fieldName forall k a. Ord k => k -> Map k a -> Bool
`member` forall a. (Properties a, HasCallStack) => a -> Map Text Value
getProps t
container)

checkLabels :: Labels t => t -> [Text] -> Bool
checkLabels :: forall t. Labels t => t -> [Text] -> Bool
checkLabels t
container = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a. (Labels a, HasCallStack) => a -> [Text]
getLabels t
container)

getProp :: (HasCallStack, Properties t, RecordValue a) => t -> (Text, Bool) -> a
getProp :: forall t a.
(HasCallStack, Properties t, RecordValue a) =>
t -> (Text, Bool) -> a
getProp t
container (Text
fieldName, Bool
fieldMaybe) | Bool
fieldMaybe Bool -> Bool -> Bool
&& Text
fieldName forall k a. Ord k => k -> Map k a -> Bool
`notMember` forall a. (Properties a, HasCallStack) => a -> Map Text Value
getProps t
container = forall {a}. RecordValue a => Value -> a
exactE forall a b. (a -> b) -> a -> b
$ () -> Value
N ()
                                          | Bool
otherwise = forall {a}. RecordValue a => Value -> a
exactE (forall a. (Properties a, HasCallStack) => a -> Map Text Value
getProps t
container forall k a. Ord k => Map k a -> k -> a
! Text
fieldName)
  where
    exactE :: Value -> a
exactE Value
v = case forall a. RecordValue a => Value -> Either UnpackError a
exactEither Value
v of
      Right a
res -> a
res
      Left UnpackError
err -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show UnpackError
err

unpackError :: HasCallStack => Show c => c -> String -> a
unpackError :: forall c a. (HasCallStack, Show c) => c -> String -> a
unpackError c
container String
label = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ $String
currentLoc forall a. [a] -> [a] -> [a]
++ String
" could not unpack " forall a. [a] -> [a] -> [a]
++ String
label forall a. [a] -> [a] -> [a]
++ String
" from " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show c
container

{- $setup
>>> :set -XTemplateHaskell
>>> :set -XOverloadedStrings
>>> import Data.Text (Text)
-}