Combinators.hs

{-# 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
    , defaultDerivedClasses
    ) where

import           Data.API.Types

import           Control.Applicative
import           Data.Monoid
import           Data.Semigroup as Sem
import           Data.String
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
    { warnOnOmittedInstance :: Bool
      -- ^ Generate a warning when an instance declaration is omitted
      -- because it already exists
    , newtypeSmartConstructors :: Bool
      -- ^ Rename the constructors of filtered newtypes and generate
      -- smart constructors that enforce the invariants
    , defaultDerivedClasses :: APINode -> [Name]
      -- ^ The classes which are derived automatically for datatypes created by 'datatypesTool'.
    }

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

-- | Default names of classes for which to derive instances, depending
-- on the type of API node.
default_derived_classes :: APINode -> [Name]
default_derived_classes an = case anSpec an of
    SpNewtype sn -> case snType sn of
                      BTstring -> ''IsString : derive_leaf_nms
                      BTbinary -> derive_leaf_nms
                      BTbool   -> derive_leaf_nms
                      BTint    -> derive_leaf_nms
                      BTutc    -> derive_leaf_nms
    SpRecord  _  -> derive_node_nms
    SpUnion   _  -> derive_node_nms
    SpEnum    _  -> derive_leaf_nms ++ [''Bounded, ''Enum]
    SpSynonym _  -> []

derive_leaf_nms :: [Name]
derive_leaf_nms = [''Show,''Eq,''Ord]

derive_node_nms :: [Name]
derive_node_nms = [''Show,''Eq]



-- | 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
    { 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 t1 <> Tool t2 = Tool $ \ ts x -> (++) <$> t1 ts x <*> t2 ts x

instance Monoid (Tool a) where
  mempty                    = Tool $ \ _ _ -> 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 f = Tool $ const f

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

-- | 'Tool' is a contravariant functor
contramapTool :: (a -> b) -> Tool b -> Tool a
contramapTool f t = Tool $ \ ts a -> runTool t ts (f a)

-- | Make a tool that reads its argument to decide what to do
readTool :: (a -> Tool a) -> Tool a
readTool t = mkTool $ \ ts x -> runTool (t x) ts x

-- | Apply a tool that acts on elements of a list to the entire list
subTools :: Tool a -> Tool [a]
subTools t = Tool $ \ ts as -> concat <$> mapM (runTool t ts) as

-- | Apply a tool that acts on nodes to an entire API
apiNodeTool :: Tool APINode -> Tool API
apiNodeTool = contramapTool (\ api -> [an | ThNode an <- api ]) . 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 = contramapTool (\ api -> [an | ThNode an <- api, hasDataType $ anSpec an ]) . subTools
  where
    hasDataType (SpSynonym _) = False
    hasDataType _             = 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 n r u e s = Tool $ \ ts an -> case anSpec an of
              SpNewtype sn -> runTool n ts (an, sn)
              SpRecord  sr -> runTool r ts (an, sr)
              SpUnion   su -> runTool u ts (an, su)
              SpEnum    se -> runTool e ts (an, se)
              SpSynonym ss -> runTool s ts (an, ss)