{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE TemplateHaskell            #-}

module Data.API.Tools.Traversal
    ( traversalTool
    ) where

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

import           Control.Applicative
import qualified Data.Map                       as Map
import           Data.Maybe
import           Data.Monoid
import qualified Data.Set                       as Set
import qualified Data.Text                      as T
import           Data.Traversable
import           Language.Haskell.TH
import           Prelude


-- | Build a traversal of the root type (first argument) that updates
-- values of the second type, e.g. @traversalTool "Root" "Sub"@
-- produces
--
-- > traverseSubRoot :: Applicative f => (Sub -> f Sub) -> Root -> f Root
--
-- along with similar functions for all the types nested inside @Root@
-- that depend on @Sub@.
--
-- Note that types with custom representations will not have
-- traversals generated automatically: if required, these must be
-- defined manually in the same module as the call to 'traversalTool',
-- otherwise the generated code will lead to scope errors.
traversalTool :: TypeName -> TypeName -> APITool
traversalTool :: TypeName -> TypeName -> APITool
traversalTool TypeName
root TypeName
x = (API -> APITool) -> APITool
forall a. (a -> Tool a) -> Tool a
readTool (Tool APINode -> APITool
apiNodeTool (Tool APINode -> APITool)
-> (API -> Tool APINode) -> API -> APITool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. API -> Tool APINode
s)
  where
    s :: API -> Tool APINode
s API
api = Tool (APINode, SpecNewtype)
-> Tool (APINode, SpecRecord)
-> Tool (APINode, SpecUnion)
-> Tool (APINode, SpecEnum)
-> Tool (APINode, APIType)
-> Tool APINode
apiSpecTool Tool (APINode, SpecNewtype)
forall a. Monoid a => a
mempty (((APINode, SpecRecord) -> Q [Dec]) -> Tool (APINode, SpecRecord)
forall a. (a -> Q [Dec]) -> Tool a
simpleTool ((APINode -> SpecRecord -> Q [Dec])
-> (APINode, SpecRecord) -> Q [Dec]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((APINode -> SpecRecord -> Q [Dec])
 -> (APINode, SpecRecord) -> Q [Dec])
-> (APINode -> SpecRecord -> Q [Dec])
-> (APINode, SpecRecord)
-> Q [Dec]
forall a b. (a -> b) -> a -> b
$ NormAPI
-> Set TypeName -> TypeName -> APINode -> SpecRecord -> Q [Dec]
traversalRecord NormAPI
napi Set TypeName
targets TypeName
x))
                               (((APINode, SpecUnion) -> Q [Dec]) -> Tool (APINode, SpecUnion)
forall a. (a -> Q [Dec]) -> Tool a
simpleTool ((APINode -> SpecUnion -> Q [Dec])
-> (APINode, SpecUnion) -> Q [Dec]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((APINode -> SpecUnion -> Q [Dec])
 -> (APINode, SpecUnion) -> Q [Dec])
-> (APINode -> SpecUnion -> Q [Dec])
-> (APINode, SpecUnion)
-> Q [Dec]
forall a b. (a -> b) -> a -> b
$ NormAPI
-> Set TypeName -> TypeName -> APINode -> SpecUnion -> Q [Dec]
traversalUnion  NormAPI
napi Set TypeName
targets TypeName
x)) Tool (APINode, SpecEnum)
forall a. Monoid a => a
mempty Tool (APINode, APIType)
forall a. Monoid a => a
mempty
      where
        napi :: NormAPI
napi    = API -> NormAPI
apiNormalForm API
api

        -- Calculate the types for which we must provide traversals:
        -- those that the root depends on and that depend on the
        -- traversed type
        targets :: Set TypeName
targets = (NormAPI -> Set TypeName -> Set TypeName
transitiveDeps        NormAPI
napi Set TypeName
rootSet Set TypeName -> Set TypeName -> Set TypeName
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set TypeName
rootSet) Set TypeName -> Set TypeName -> Set TypeName
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection`
                  (NormAPI -> Set TypeName -> Set TypeName
transitiveReverseDeps NormAPI
napi Set TypeName
xSet    Set TypeName -> Set TypeName -> Set TypeName
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set TypeName
xSet)
        rootSet :: Set TypeName
rootSet = TypeName -> Set TypeName
forall a. a -> Set a
Set.singleton TypeName
root
        xSet :: Set TypeName
xSet    = TypeName -> Set TypeName
forall a. a -> Set a
Set.singleton TypeName
x


-- | @traversalName x tn@ is the name of the function that traverses
-- @x@ values inside @tn@
traversalName :: TypeName -> TypeName -> Name
traversalName :: TypeName -> TypeName -> Name
traversalName TypeName
x TypeName
tn = Text -> Name
mkNameText (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ Text
"traverse" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeName -> Text
_TypeName TypeName
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeName -> Text
_TypeName TypeName
tn

-- | @traversalType x an@ is the type of the function that traverses
-- @x@ values inside @an@
traversalType :: TypeName -> APINode -> TypeQ
traversalType :: TypeName -> APINode -> TypeQ
traversalType TypeName
x APINode
an = [t| forall f . Applicative f => ($x' -> f $x') -> $ty -> f $ty |]
  where
    x' :: TypeQ
x' = Name -> TypeQ
conT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ Text -> Name
mkNameText (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ TypeName -> Text
_TypeName TypeName
x
    ty :: TypeQ
ty = APINode -> TypeQ
nodeT APINode
an


-- | Construct a traversal of the X substructures of the given type
traverser :: NormAPI -> Set.Set TypeName -> TypeName -> APIType -> ExpQ
traverser :: NormAPI -> Set TypeName -> TypeName -> APIType -> ExpQ
traverser NormAPI
napi Set TypeName
targets TypeName
x APIType
ty = ExpQ -> Maybe ExpQ -> ExpQ
forall a. a -> Maybe a -> a
fromMaybe [| const pure |] (Maybe ExpQ -> ExpQ) -> Maybe ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ NormAPI -> Set TypeName -> TypeName -> APIType -> Maybe ExpQ
traverser' NormAPI
napi Set TypeName
targets TypeName
x APIType
ty

-- | Construct a traversal of the X substructures of the given type,
-- or return 'Nothing' if there are no substructures to traverse
traverser' :: NormAPI -> Set.Set TypeName -> TypeName -> APIType -> Maybe ExpQ
traverser' :: NormAPI -> Set TypeName -> TypeName -> APIType -> Maybe ExpQ
traverser' NormAPI
napi Set TypeName
targets TypeName
x (TyList APIType
ty)  = (ExpQ -> ExpQ) -> Maybe ExpQ -> Maybe ExpQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ExpQ -> ExpQ -> ExpQ
appE [e|(.) traverse|]) (Maybe ExpQ -> Maybe ExpQ) -> Maybe ExpQ -> Maybe ExpQ
forall a b. (a -> b) -> a -> b
$ NormAPI -> Set TypeName -> TypeName -> APIType -> Maybe ExpQ
traverser' NormAPI
napi Set TypeName
targets TypeName
x APIType
ty
traverser' NormAPI
napi Set TypeName
targets TypeName
x (TyMaybe APIType
ty) = (ExpQ -> ExpQ) -> Maybe ExpQ -> Maybe ExpQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ExpQ -> ExpQ -> ExpQ
appE [e|(.) traverse|]) (Maybe ExpQ -> Maybe ExpQ) -> Maybe ExpQ -> Maybe ExpQ
forall a b. (a -> b) -> a -> b
$ NormAPI -> Set TypeName -> TypeName -> APIType -> Maybe ExpQ
traverser' NormAPI
napi Set TypeName
targets TypeName
x APIType
ty
traverser' NormAPI
napi Set TypeName
targets TypeName
x (TyName TypeName
tn)
  | TypeName
tn TypeName -> TypeName -> Bool
forall a. Eq a => a -> a -> Bool
== TypeName
x   = ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just [e| id |]
  | Bool -> Bool
not (TypeName
tn TypeName -> Set TypeName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TypeName
targets) = Maybe ExpQ
forall a. Maybe a
Nothing
  | Bool
otherwise = case TypeName -> NormAPI -> Maybe NormTypeDecl
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TypeName
tn NormAPI
napi of
                           Maybe NormTypeDecl
Nothing                -> [Char] -> Maybe ExpQ
forall a. HasCallStack => [Char] -> a
error ([Char] -> Maybe ExpQ) -> [Char] -> Maybe ExpQ
forall a b. (a -> b) -> a -> b
$ [Char]
"missing API type declaration: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack (TypeName -> Text
_TypeName TypeName
tn)
                           Just (NTypeSynonym APIType
ty) -> NormAPI -> Set TypeName -> TypeName -> APIType -> Maybe ExpQ
traverser' NormAPI
napi Set TypeName
targets TypeName
x APIType
ty
                           Just (NRecordType  NormRecordType
_)  -> ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (ExpQ -> Maybe ExpQ) -> ExpQ -> Maybe ExpQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ TypeName -> TypeName -> Name
traversalName TypeName
x TypeName
tn
                           Just (NUnionType   NormRecordType
_)  -> ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (ExpQ -> Maybe ExpQ) -> ExpQ -> Maybe ExpQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ TypeName -> TypeName -> Name
traversalName TypeName
x TypeName
tn
                           Just (NEnumType    NormEnumType
_)  -> Maybe ExpQ
forall a. Maybe a
Nothing
                           Just (NNewtype     BasicType
_)  -> Maybe ExpQ
forall a. Maybe a
Nothing
traverser' NormAPI
_ Set TypeName
_ TypeName
_ (TyBasic BasicType
_)  = Maybe ExpQ
forall a. Maybe a
Nothing
traverser' NormAPI
_ Set TypeName
_ TypeName
_ APIType
TyJSON       = Maybe ExpQ
forall a. Maybe a
Nothing


-- | Build a traversal for a record type that applies f to any fields
-- of type X, and traverses nested structures.  For example:
--
-- > traverseXFoo :: Applicative f => (X -> f X) -> Foo -> f Foo
-- > traverseXFoo f x = Foo <$> f (foo_a x) <*> traverseXBar (traverse f) (foo_b x)
--
traversalRecord :: NormAPI -> Set.Set TypeName -> TypeName -> APINode -> SpecRecord -> Q [Dec]
traversalRecord :: NormAPI
-> Set TypeName -> TypeName -> APINode -> SpecRecord -> Q [Dec]
traversalRecord NormAPI
napi Set TypeName
targets TypeName
x APINode
an SpecRecord
sr
  | Bool -> Bool
not (APINode -> TypeName
anName APINode
an TypeName -> Set TypeName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TypeName
targets) = [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  | APINode -> Conversion
anConvert APINode
an Conversion -> Conversion -> Bool
forall a. Eq a => a -> a -> Bool
/= Conversion
forall a. Maybe a
Nothing              = [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  | Bool
otherwise                            = Name -> TypeQ -> ExpQ -> Q [Dec]
simpleSigD Name
nom (TypeName -> APINode -> TypeQ
traversalType TypeName
x APINode
an) ExpQ
bdy
  where
    nom :: Name
nom = TypeName -> TypeName -> Name
traversalName TypeName
x (APINode -> TypeName
anName APINode
an)
    bdy :: ExpQ
bdy = do
      Name
f <- [Char] -> Q Name
newName [Char]
"f"
      Name
r <- [Char] -> Q Name
newName [Char]
"r"
      [PatQ] -> ExpQ -> ExpQ
lamE [Name -> PatQ
varP Name
f, Name -> PatQ
varP Name
r] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ ExpQ -> [ExpQ] -> ExpQ
applicativeE (APINode -> ExpQ
nodeConE APINode
an) ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ ((FieldName, FieldType) -> ExpQ)
-> [(FieldName, FieldType)] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Name -> (FieldName, FieldType) -> ExpQ
traverseField Name
f Name
r) (SpecRecord -> [(FieldName, FieldType)]
srFields SpecRecord
sr)
    traverseField :: Name -> Name -> (FieldName, FieldType) -> ExpQ
traverseField Name
f Name
r (FieldName
fn, FieldType
fty) = [e| $(traverser napi targets x (ftType fty)) $(varE f) ($(nodeFieldE an fn) $(varE r)) |]


-- | Build a traversal for a union type that traverses nested structures.
-- For example:
--
-- > traverseXBar :: Applicative f => (X -> f X) -> Bar -> f Bar
-- > traverseXBar f (BAR_one a) = BAR_one <$> f a
-- > traverseXBar f (Bar_two b) = BAR_two <$> traverseXBaz f b
--
traversalUnion :: NormAPI -> Set.Set TypeName -> TypeName -> APINode -> SpecUnion -> Q [Dec]
traversalUnion :: NormAPI
-> Set TypeName -> TypeName -> APINode -> SpecUnion -> Q [Dec]
traversalUnion NormAPI
napi Set TypeName
targets TypeName
x APINode
an SpecUnion
su
  | Bool -> Bool
not (APINode -> TypeName
anName APINode
an TypeName -> Set TypeName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TypeName
targets) = [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  | APINode -> Conversion
anConvert APINode
an Conversion -> Conversion -> Bool
forall a. Eq a => a -> a -> Bool
/= Conversion
forall a. Maybe a
Nothing              = [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  | Bool
otherwise                            = Name -> TypeQ -> [ClauseQ] -> Q [Dec]
funSigD Name
nom (TypeName -> APINode -> TypeQ
traversalType TypeName
x APINode
an) [ClauseQ]
cls
  where
    nom :: Name
nom = TypeName -> TypeName -> Name
traversalName TypeName
x (APINode -> TypeName
anName APINode
an)
    cls :: [ClauseQ]
cls = ((FieldName, (APIType, [Char])) -> ClauseQ)
-> [(FieldName, (APIType, [Char]))] -> [ClauseQ]
forall a b. (a -> b) -> [a] -> [b]
map (FieldName, (APIType, [Char])) -> ClauseQ
forall b. (FieldName, (APIType, b)) -> ClauseQ
cl ([(FieldName, (APIType, [Char]))] -> [ClauseQ])
-> [(FieldName, (APIType, [Char]))] -> [ClauseQ]
forall a b. (a -> b) -> a -> b
$ SpecUnion -> [(FieldName, (APIType, [Char]))]
suFields SpecUnion
su
    cl :: (FieldName, (APIType, b)) -> ClauseQ
cl (FieldName
fn,(APIType
ty,b
_)) = do
      Name
f <- [Char] -> Q Name
newName [Char]
"f"
      Name
z <- [Char] -> Q Name
newName [Char]
"z"
      [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [Name -> PatQ
varP Name
f, APINode -> FieldName -> [PatQ] -> PatQ
nodeAltConP APINode
an FieldName
fn [Name -> PatQ
varP Name
z]] (ExpQ -> BodyQ
normalB (FieldName -> APIType -> Name -> Name -> ExpQ
bdy FieldName
fn APIType
ty Name
f Name
z)) []
    bdy :: FieldName -> APIType -> Name -> Name -> ExpQ
bdy FieldName
fn APIType
ty Name
f Name
z = [e| $(nodeAltConE an fn) <$> $(traverser napi targets x ty) $(varE f) $(varE z) |]