{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE TemplateHaskell            #-}
module Data.API.Tools.DeepSeq
    ( deepSeqTool
    ) where

import           Data.API.TH
import           Data.API.Tools.Combinators
import           Data.API.Tools.Datatypes
import           Data.API.Types

import           Control.DeepSeq
import           Data.Monoid
import           Language.Haskell.TH
import           Prelude


-- | Tool to generate 'NFData' instances for generated types.
deepSeqTool :: APITool
deepSeqTool :: APITool
deepSeqTool = Tool APINode -> APITool
apiNodeTool (Tool APINode -> APITool) -> Tool APINode -> APITool
forall a b. (a -> b) -> a -> b
$ Tool (APINode, SpecNewtype)
-> Tool (APINode, SpecRecord)
-> Tool (APINode, SpecUnion)
-> Tool (APINode, SpecEnum)
-> Tool (APINode, APIType)
-> Tool APINode
apiSpecTool Tool (APINode, SpecNewtype)
gen_sn Tool (APINode, SpecRecord)
gen_sr Tool (APINode, SpecUnion)
gen_su Tool (APINode, SpecEnum)
gen_se Tool (APINode, APIType)
forall a. Monoid a => a
mempty


gen_sn :: Tool (APINode, SpecNewtype)
gen_sn :: Tool (APINode, SpecNewtype)
gen_sn = (ToolSettings -> (APINode, SpecNewtype) -> Q [Dec])
-> Tool (APINode, SpecNewtype)
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool ((ToolSettings -> (APINode, SpecNewtype) -> Q [Dec])
 -> Tool (APINode, SpecNewtype))
-> (ToolSettings -> (APINode, SpecNewtype) -> Q [Dec])
-> Tool (APINode, SpecNewtype)
forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts (APINode
an, SpecNewtype
_) -> ToolSettings -> Name -> [TypeQ] -> [DecQ] -> Q [Dec]
optionalInstanceD ToolSettings
ts ''NFData [APINode -> TypeQ
nodeRepT APINode
an]
                                     [Name -> ExpQ -> DecQ
simpleD 'rnf (APINode -> ExpQ
bdy APINode
an)]
  where
    bdy :: APINode -> ExpQ
bdy APINode
an = [e| \ x -> rnf ($(newtypeProjectionE an) x) |]

gen_sr :: Tool (APINode, SpecRecord)
gen_sr :: Tool (APINode, SpecRecord)
gen_sr = (ToolSettings -> (APINode, SpecRecord) -> Q [Dec])
-> Tool (APINode, SpecRecord)
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool ((ToolSettings -> (APINode, SpecRecord) -> Q [Dec])
 -> Tool (APINode, SpecRecord))
-> (ToolSettings -> (APINode, SpecRecord) -> Q [Dec])
-> Tool (APINode, SpecRecord)
forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts (APINode
an, SpecRecord
sr) -> do
    Name
x <- String -> Q Name
newName String
"x"
    ToolSettings -> Name -> [TypeQ] -> [DecQ] -> Q [Dec]
optionalInstanceD ToolSettings
ts ''NFData [APINode -> TypeQ
nodeRepT APINode
an] [Name -> ExpQ -> DecQ
simpleD 'rnf (APINode -> SpecRecord -> Name -> ExpQ
bdy APINode
an SpecRecord
sr Name
x)]
  where
    bdy :: APINode -> SpecRecord -> Name -> ExpQ
bdy APINode
an SpecRecord
sr Name
x = [PatQ] -> ExpQ -> ExpQ
lamE [Name -> PatQ
varP Name
x] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ ((FieldName, FieldType) -> ExpQ -> ExpQ)
-> ExpQ -> [(FieldName, FieldType)] -> ExpQ
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (FieldName, FieldType) -> ExpQ -> ExpQ
forall b. (FieldName, b) -> ExpQ -> ExpQ
f [e|()|] (SpecRecord -> [(FieldName, FieldType)]
srFields SpecRecord
sr)
      where
        f :: (FieldName, b) -> ExpQ -> ExpQ
f (FieldName
fn,b
_) ExpQ
r = [e| rnf ($(nodeFieldE an fn) $(varE x)) `seq` $r |]

gen_su :: Tool (APINode, SpecUnion)
gen_su :: Tool (APINode, SpecUnion)
gen_su = (ToolSettings -> (APINode, SpecUnion) -> Q [Dec])
-> Tool (APINode, SpecUnion)
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool ((ToolSettings -> (APINode, SpecUnion) -> Q [Dec])
 -> Tool (APINode, SpecUnion))
-> (ToolSettings -> (APINode, SpecUnion) -> Q [Dec])
-> Tool (APINode, SpecUnion)
forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts (APINode
an, SpecUnion
su) -> do
    Name
x <- String -> Q Name
newName String
"x"
    Name
y <- String -> Q Name
newName String
"y"
    ToolSettings -> Name -> [TypeQ] -> [DecQ] -> Q [Dec]
optionalInstanceD ToolSettings
ts ''NFData [APINode -> TypeQ
nodeRepT APINode
an] [Name -> ExpQ -> DecQ
simpleD 'rnf (APINode -> SpecUnion -> Name -> Name -> ExpQ
bdy APINode
an SpecUnion
su Name
x Name
y)]
  where
    bdy :: APINode -> SpecUnion -> Name -> Name -> ExpQ
bdy APINode
an SpecUnion
su Name
x Name
y = [PatQ] -> ExpQ -> ExpQ
lamE [Name -> PatQ
varP Name
x] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
x) [MatchQ]
cs
      where
        cs :: [MatchQ]
cs = ((FieldName, (APIType, String)) -> MatchQ)
-> [(FieldName, (APIType, String))] -> [MatchQ]
forall a b. (a -> b) -> [a] -> [b]
map (FieldName, (APIType, String)) -> MatchQ
forall b. (FieldName, b) -> MatchQ
f (SpecUnion -> [(FieldName, (APIType, String))]
suFields SpecUnion
su)
        f :: (FieldName, b) -> MatchQ
f (FieldName
fn,b
_) = PatQ -> BodyQ -> [DecQ] -> MatchQ
match (APINode -> FieldName -> [PatQ] -> PatQ
nodeAltConP APINode
an FieldName
fn [Name -> PatQ
varP Name
y]) (ExpQ -> BodyQ
normalB [e|rnf $(varE y)|]) []

gen_se :: Tool (APINode, SpecEnum)
gen_se :: Tool (APINode, SpecEnum)
gen_se = (ToolSettings -> (APINode, SpecEnum) -> Q [Dec])
-> Tool (APINode, SpecEnum)
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool ((ToolSettings -> (APINode, SpecEnum) -> Q [Dec])
 -> Tool (APINode, SpecEnum))
-> (ToolSettings -> (APINode, SpecEnum) -> Q [Dec])
-> Tool (APINode, SpecEnum)
forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts (APINode
an, SpecEnum
_) ->
    ToolSettings -> Name -> [TypeQ] -> [DecQ] -> Q [Dec]
optionalInstanceD ToolSettings
ts ''NFData [APINode -> TypeQ
nodeRepT APINode
an]
        [Name -> ExpQ -> DecQ
simpleD 'rnf [e| \ x -> seq x () |] ]