{-# 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 (..))
import           Database.Bolt.Extras       (FromValue (..), Labels (..),
                                             NodeLike (..),
                                             Properties (..), ToValue (..),
                                             URelationLike (..))
import           Database.Bolt.Extras.Utils (currentLoc, dummyId)
import           Instances.TH.Lift          ()
import           Language.Haskell.TH
import           Language.Haskell.TH.Syntax

-- 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 ([Maybe Exp] -> Exp) -> ([Exp] -> [Maybe Exp]) -> [Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp -> Maybe Exp) -> [Exp] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Maybe Exp
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 :: Name -> Name -> Name -> Name -> BiClassInfo
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 :: Name -> Name -> Name -> Name -> BiClassInfo
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 :: Name -> Q [Dec]
makeNodeLike :: Name -> Q [Dec]
makeNodeLike Name
name = BiClassInfo -> Name -> (String -> String) -> Q [Dec]
makeBiClassInstance BiClassInfo
nodeLikeClass Name
name String -> String
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 :: Name -> (String -> String) -> Q [Dec]
makeNodeLikeWith :: Name -> (String -> String) -> Q [Dec]
makeNodeLikeWith = 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 :: Name -> Q [Dec]
makeURelationLike :: Name -> Q [Dec]
makeURelationLike Name
name = BiClassInfo -> Name -> (String -> String) -> Q [Dec]
makeBiClassInstance BiClassInfo
uRelationLikeClass Name
name String -> String
forall a. a -> a
id

-- | As 'makeNodeLikeWith'.
makeURelationLikeWith :: Name -> (String -> String) -> Q [Dec]
makeURelationLikeWith :: Name -> (String -> String) -> Q [Dec]
makeURelationLikeWith = 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 :: BiClassInfo -> Name -> (String -> String) -> Q [Dec]
makeBiClassInstance :: 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) = 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) = [(Name, Type)] -> ([Name], [Type])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Name, Type)] -> ([Name], [Type]))
-> [(Name, Type)] -> ([Name], [Type])
forall a b. (a -> b) -> a -> b
$ (Con -> [(Name, Type)]) -> [Con] -> [(Name, Type)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Name, [(Name, Type)]) -> [(Name, Type)]
forall a b. (a, b) -> b
snd ((Name, [(Name, Type)]) -> [(Name, Type)])
-> (Con -> (Name, [(Name, Type)])) -> Con -> [(Name, Type)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Con -> (Name, [(Name, Type)])
getConsFields) [Con]
constr

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

  -- Just a fresh variable. It will be used in labmda abstractions in makeFromClause function.
  Name
fresh <- String -> Q 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.
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
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 :: Con -> (Name, [(Name, Type)])
getConsFields :: Con -> (Name, [(Name, Type)])
getConsFields (RecC Name
cName [VarBangType]
decs)           = (Name
cName, (VarBangType -> (Name, Type)) -> [VarBangType] -> [(Name, Type)]
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]
_ [Type]
_ Con
cons)          = Con -> (Name, [(Name, Type)])
getConsFields Con
cons
getConsFields (RecGadtC (Name
cName:[Name]
_) [VarBangType]
decs Type
_) = (Name
cName, (VarBangType -> (Name, Type)) -> [VarBangType] -> [(Name, Type)]
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
_                           = String -> (Name, [(Name, Type)])
forall a. HasCallStack => String -> a
error (String -> (Name, [(Name, Type)]))
-> String -> (Name, [(Name, Type)])
forall a b. (a -> b) -> a -> b
$ String
$currentLoc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"unsupported data declaration."


-- | Parse a type declaration and retrieve its name and its constructors.
--
getTypeCons :: Dec -> (Name, [Con])
getTypeCons :: 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 = String -> (Name, [Con])
forall a. HasCallStack => String -> a
error (String -> (Name, [Con])) -> String -> (Name, [Con])
forall a b. (a -> b) -> a -> b
$ String
$currentLoc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"unsupported declaration: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Dec -> String
forall a. Show a => a -> String
show Dec
otherDecl String -> String -> String
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
  | [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
dataFields = Clause -> Q Clause
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
WildP] (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ [Name] -> Exp
result []) []
  | Bool
otherwise       = do
    [Name]
fieldVars <- [Q Name] -> Q [Name]
forall a. [Q a] -> Q [a]
sequenceQ ([Q Name] -> Q [Name]) -> [Q Name] -> Q [Name]
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"_field" Q Name -> [Name] -> [Q Name]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Name]
dataFields -- var for each field
    Clause -> Q Clause
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [[Name] -> Pat
recPat [Name]
fieldVars] (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
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 (Pat -> Pat) -> Pat -> Pat
forall a b. (a -> b) -> a -> b
$ Name -> [FieldPat] -> Pat
RecP Name
consName ([FieldPat] -> Pat) -> [FieldPat] -> Pat
forall a b. (a -> b) -> a -> b
$ [Name] -> [Pat] -> [FieldPat]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
dataFields ([Pat] -> [FieldPat]) -> [Pat] -> [FieldPat]
forall a b. (a -> b) -> a -> b
$ Name -> Pat
VarP (Name -> Pat) -> [Name] -> [Pat]
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 = (Name -> Exp) -> [Name] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'toValue) (Exp -> Exp) -> (Name -> Exp) -> Name -> Exp
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 = (Name -> String) -> [Name] -> [String]
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 = (String -> Exp -> Exp) -> [String] -> [Exp] -> [Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\String
fld Exp
val -> [Exp] -> Exp
tupE' [String -> Exp
strToTextE (String -> Exp) -> String -> Exp
forall a b. (a -> b) -> a -> b
$ String -> String
fieldLabelModifier String
fld, Exp
val]) [String]
fieldNames ([Exp] -> [Exp]) -> ([Name] -> [Exp]) -> [Name] -> [Exp]
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 ([Exp] -> Exp) -> [Exp] -> Exp
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 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"URelationship" = Exp -> Exp
forall a. a -> a
id
             | Name -> String
nameBase Name
dataCons String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Node"          = [Exp] -> Exp
ListE ([Exp] -> Exp) -> (Exp -> [Exp]) -> Exp -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
:[])
             | Bool
otherwise                = String -> Exp -> Exp
forall a. HasCallStack => String -> a
error (String -> Exp -> Exp) -> String -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ String
$currentLoc String -> String -> String
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 (Lit -> Exp) -> (Int -> Lit) -> Int -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
IntegerL (Integer -> Lit) -> (Int -> Integer) -> Int -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Exp) -> Int -> Exp
forall a b. (a -> b) -> a -> b
$ Int
dummyId)) (Exp -> Exp
fieldFun (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Exp
strToTextE String
label)) (Exp -> Exp) -> ([Name] -> Exp) -> [Name] -> Exp
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 = (Type -> Bool) -> [Type] -> [Bool]
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 = (Name -> Text) -> [Name] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Text
pack (String -> Text) -> (Name -> String) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
fieldLabelModifier (String -> String) -> (Name -> String) -> Name -> String
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 = [Text] -> [Bool] -> [(Text, Bool)]
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 <- (Text -> Q Exp) -> [Text] -> Q [Exp]
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 = (Exp -> Bool -> Exp) -> [Exp] -> [Bool] -> [Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Exp
n Bool
m -> [Exp] -> Exp
tupE' [Exp
n, Name -> Exp
ConE (Name -> Exp) -> Name -> Exp
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 = Exp -> Q Exp
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 (Exp -> Guard) -> Q Exp -> Q Guard
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 (Exp -> Guard) -> Q Exp -> Q Guard
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 = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Exp
a Exp
f -> Exp -> Exp -> Exp
AppE Exp
a (Exp -> Exp) -> Exp -> Exp
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)

  Clause -> Q Clause
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Clause -> Q Clause) -> Clause -> Q Clause
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 Name -> Name -> Bool
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 (Lit -> Exp) -> (String -> Lit) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL (String -> Exp) -> String -> Exp
forall a b. (a -> b) -> a -> b
$ String
str)

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

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

getProp :: (Properties t, FromValue a) => t -> (Text, Bool) -> a
getProp :: t -> (Text, Bool) -> a
getProp t
container (Text
fieldName, Bool
fieldMaybe) | Bool
fieldMaybe Bool -> Bool -> Bool
&& Text
fieldName Text -> Map Text Value -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`notMember` t -> Map Text Value
forall a. Properties a => a -> Map Text Value
getProps t
container = Value -> a
forall a. FromValue a => Value -> a
fromValue (Value -> a) -> Value -> a
forall a b. (a -> b) -> a -> b
$ () -> Value
N ()
                                          | Bool
otherwise = Value -> a
forall a. FromValue a => Value -> a
fromValue (t -> Map Text Value
forall a. Properties a => a -> Map Text Value
getProps t
container Map Text Value -> Text -> Value
forall k a. Ord k => Map k a -> k -> a
! Text
fieldName)

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

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