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

module Data.API.Tools.Combinators
    ( Tool
    , APITool
    , APINodeTool
    , runTool

      -- * Smart constructors and combinators
    , simpleTool
    , mkTool
    , contramapTool
    , readTool
    , subTools
    , apiNodeTool
    , apiDataTypeTool
    , apiSpecTool

      -- * Tool settings
    , ToolSettings
    , warnOnOmittedInstance
    , newtypeSmartConstructors
    , defaultToolSettings
    ) where

import           Data.API.Types

import           Control.Applicative
import           Data.Monoid
import           Data.Semigroup as Sem
import           Language.Haskell.TH
import           Prelude


-- | Settings to control the behaviour of API tools.  This record may
-- be extended in the future, so you should construct a value by
-- overriding individual fields of 'defaultToolSettings'.
data ToolSettings = ToolSettings
    { ToolSettings -> Bool
warnOnOmittedInstance :: Bool
      -- ^ Generate a warning when an instance declaration is omitted
      -- because it already exists
    , ToolSettings -> Bool
newtypeSmartConstructors :: Bool
      -- ^ Rename the constructors of filtered newtypes and generate
      -- smart constructors that enforce the invariants
    }

-- | Default settings designed to be overridden.
defaultToolSettings :: ToolSettings
defaultToolSettings :: ToolSettings
defaultToolSettings = ToolSettings :: Bool -> Bool -> ToolSettings
ToolSettings
    { warnOnOmittedInstance :: Bool
warnOnOmittedInstance = Bool
False
    , newtypeSmartConstructors :: Bool
newtypeSmartConstructors = Bool
False
    }

-- | A @'Tool' a@ is something that can generate TH declarations from
-- a value of type @a@.  Tools can be combined using the 'Monoid'
-- instance.
newtype Tool a   = Tool
    { Tool a -> ToolSettings -> a -> Q [Dec]
runTool :: ToolSettings -> a -> Q [Dec]
      -- ^ Execute a tool to generate some TH declarations.
    }

type APITool     = Tool API
type APINodeTool = Tool APINode

instance Sem.Semigroup (Tool a) where
  Tool ToolSettings -> a -> Q [Dec]
t1 <> :: Tool a -> Tool a -> Tool a
<> Tool ToolSettings -> a -> Q [Dec]
t2 = (ToolSettings -> a -> Q [Dec]) -> Tool a
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
Tool ((ToolSettings -> a -> Q [Dec]) -> Tool a)
-> (ToolSettings -> a -> Q [Dec]) -> Tool a
forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts a
x -> [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
(++) ([Dec] -> [Dec] -> [Dec]) -> Q [Dec] -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ToolSettings -> a -> Q [Dec]
t1 ToolSettings
ts a
x Q ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ToolSettings -> a -> Q [Dec]
t2 ToolSettings
ts a
x

instance Monoid (Tool a) where
  mempty :: Tool a
mempty                    = (ToolSettings -> a -> Q [Dec]) -> Tool a
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
Tool ((ToolSettings -> a -> Q [Dec]) -> Tool a)
-> (ToolSettings -> a -> Q [Dec]) -> Tool a
forall a b. (a -> b) -> a -> b
$ \ ToolSettings
_ a
_ -> [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
#if !(MIN_VERSION_base(4,11,0))
  Tool t1 `mappend` Tool t2 = Tool $ \ ts x -> (++) <$> t1 ts x <*> t2 ts x
#endif

-- | Construct a tool that does not depend on any settings
simpleTool :: (a -> Q [Dec]) -> Tool a
simpleTool :: (a -> Q [Dec]) -> Tool a
simpleTool a -> Q [Dec]
f = (ToolSettings -> a -> Q [Dec]) -> Tool a
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
Tool ((ToolSettings -> a -> Q [Dec]) -> Tool a)
-> (ToolSettings -> a -> Q [Dec]) -> Tool a
forall a b. (a -> b) -> a -> b
$ (a -> Q [Dec]) -> ToolSettings -> a -> Q [Dec]
forall a b. a -> b -> a
const a -> Q [Dec]
f

-- | Construct a tool that may depend on the settings
mkTool :: (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool :: (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool = (ToolSettings -> a -> Q [Dec]) -> Tool a
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
Tool

-- | 'Tool' is a contravariant functor
contramapTool :: (a -> b) -> Tool b -> Tool a
contramapTool :: (a -> b) -> Tool b -> Tool a
contramapTool a -> b
f Tool b
t = (ToolSettings -> a -> Q [Dec]) -> Tool a
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
Tool ((ToolSettings -> a -> Q [Dec]) -> Tool a)
-> (ToolSettings -> a -> Q [Dec]) -> Tool a
forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts a
a -> Tool b -> ToolSettings -> b -> Q [Dec]
forall a. Tool a -> ToolSettings -> a -> Q [Dec]
runTool Tool b
t ToolSettings
ts (a -> b
f a
a)

-- | Make a tool that reads its argument to decide what to do
readTool :: (a -> Tool a) -> Tool a
readTool :: (a -> Tool a) -> Tool a
readTool a -> Tool a
t = (ToolSettings -> a -> Q [Dec]) -> Tool a
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool ((ToolSettings -> a -> Q [Dec]) -> Tool a)
-> (ToolSettings -> a -> Q [Dec]) -> Tool a
forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts a
x -> Tool a -> ToolSettings -> a -> Q [Dec]
forall a. Tool a -> ToolSettings -> a -> Q [Dec]
runTool (a -> Tool a
t a
x) ToolSettings
ts a
x

-- | Apply a tool that acts on elements of a list to the entire list
subTools :: Tool a -> Tool [a]
subTools :: Tool a -> Tool [a]
subTools Tool a
t = (ToolSettings -> [a] -> Q [Dec]) -> Tool [a]
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
Tool ((ToolSettings -> [a] -> Q [Dec]) -> Tool [a])
-> (ToolSettings -> [a] -> Q [Dec]) -> Tool [a]
forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts [a]
as -> [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> Q [Dec]) -> [a] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Tool a -> ToolSettings -> a -> Q [Dec]
forall a. Tool a -> ToolSettings -> a -> Q [Dec]
runTool Tool a
t ToolSettings
ts) [a]
as

-- | Apply a tool that acts on nodes to an entire API
apiNodeTool :: Tool APINode -> Tool API
apiNodeTool :: Tool APINode -> Tool API
apiNodeTool = (API -> [APINode]) -> Tool [APINode] -> Tool API
forall a b. (a -> b) -> Tool b -> Tool a
contramapTool (\ API
api -> [APINode
an | ThNode APINode
an <- API
api ]) (Tool [APINode] -> Tool API)
-> (Tool APINode -> Tool [APINode]) -> Tool APINode -> Tool API
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tool APINode -> Tool [APINode]
forall a. Tool a -> Tool [a]
subTools

-- | Apply a tool that acts on datatype nodes (i.e. those that are not
-- synonyms) to an entire API
apiDataTypeTool :: Tool APINode -> Tool API
apiDataTypeTool :: Tool APINode -> Tool API
apiDataTypeTool = (API -> [APINode]) -> Tool [APINode] -> Tool API
forall a b. (a -> b) -> Tool b -> Tool a
contramapTool (\ API
api -> [APINode
an | ThNode APINode
an <- API
api, Spec -> Bool
hasDataType (Spec -> Bool) -> Spec -> Bool
forall a b. (a -> b) -> a -> b
$ APINode -> Spec
anSpec APINode
an ]) (Tool [APINode] -> Tool API)
-> (Tool APINode -> Tool [APINode]) -> Tool APINode -> Tool API
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tool APINode -> Tool [APINode]
forall a. Tool a -> Tool [a]
subTools
  where
    hasDataType :: Spec -> Bool
hasDataType (SpSynonym APIType
_) = Bool
False
    hasDataType Spec
_             = Bool
True

-- | Create a tool that acts on nodes from its action on individual
-- specs.
apiSpecTool :: Tool (APINode, SpecNewtype)
            -> Tool (APINode, SpecRecord )
            -> Tool (APINode, SpecUnion  )
            -> Tool (APINode, SpecEnum   )
            -> Tool (APINode, APIType    )
            -> Tool APINode
apiSpecTool :: Tool (APINode, SpecNewtype)
-> Tool (APINode, SpecRecord)
-> Tool (APINode, SpecUnion)
-> Tool (APINode, SpecEnum)
-> Tool (APINode, APIType)
-> Tool APINode
apiSpecTool Tool (APINode, SpecNewtype)
n Tool (APINode, SpecRecord)
r Tool (APINode, SpecUnion)
u Tool (APINode, SpecEnum)
e Tool (APINode, APIType)
s = (ToolSettings -> APINode -> Q [Dec]) -> Tool APINode
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
Tool ((ToolSettings -> APINode -> Q [Dec]) -> Tool APINode)
-> (ToolSettings -> APINode -> Q [Dec]) -> Tool APINode
forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts APINode
an -> case APINode -> Spec
anSpec APINode
an of
              SpNewtype SpecNewtype
sn -> Tool (APINode, SpecNewtype)
-> ToolSettings -> (APINode, SpecNewtype) -> Q [Dec]
forall a. Tool a -> ToolSettings -> a -> Q [Dec]
runTool Tool (APINode, SpecNewtype)
n ToolSettings
ts (APINode
an, SpecNewtype
sn)
              SpRecord  SpecRecord
sr -> Tool (APINode, SpecRecord)
-> ToolSettings -> (APINode, SpecRecord) -> Q [Dec]
forall a. Tool a -> ToolSettings -> a -> Q [Dec]
runTool Tool (APINode, SpecRecord)
r ToolSettings
ts (APINode
an, SpecRecord
sr)
              SpUnion   SpecUnion
su -> Tool (APINode, SpecUnion)
-> ToolSettings -> (APINode, SpecUnion) -> Q [Dec]
forall a. Tool a -> ToolSettings -> a -> Q [Dec]
runTool Tool (APINode, SpecUnion)
u ToolSettings
ts (APINode
an, SpecUnion
su)
              SpEnum    SpecEnum
se -> Tool (APINode, SpecEnum)
-> ToolSettings -> (APINode, SpecEnum) -> Q [Dec]
forall a. Tool a -> ToolSettings -> a -> Q [Dec]
runTool Tool (APINode, SpecEnum)
e ToolSettings
ts (APINode
an, SpecEnum
se)
              SpSynonym APIType
ss -> Tool (APINode, APIType)
-> ToolSettings -> (APINode, APIType) -> Q [Dec]
forall a. Tool a -> ToolSettings -> a -> Q [Dec]
runTool Tool (APINode, APIType)
s ToolSettings
ts (APINode
an, APIType
ss)