-- |
-- This module contains the whole API of \"domain\".
--
-- Many functions come with collapsed example sections.
-- Do check them out for better understanding.
module Domain
  ( -- * Declaration
    declare,

    -- * Schema
    Schema,
    schema,
    loadSchema,

    -- * Deriver
    Deriver.Deriver,
    stdDeriver,

    -- ** Common
    enumDeriver,
    boundedDeriver,
    showDeriver,
    eqDeriver,
    ordDeriver,
    genericDeriver,
    dataDeriver,
    typeableDeriver,
    hashableDeriver,
    liftDeriver,

    -- ** HasField
    hasFieldDeriver,

    -- ** IsLabel
    constructorIsLabelDeriver,
    accessorIsLabelDeriver,
    mapperIsLabelDeriver,

    -- * Clarifications

    -- ** Type Equality Constraint #type-equality-constraint#

    -- |
    -- You may have noticed that some instances (in particular of 'IsLabel')
    -- have some unusual tilde (@~@) constraint:
    --
    -- @
    -- instance a ~ TransportProtocol => IsLabel "protocol" (NetworkAddress -> a)
    -- @
    --
    -- This constraint states that types are equal.
    -- You might be wondering why do that instead of just
    --
    -- @
    -- instance IsLabel "protocol" (NetworkAddress -> TransportProtocol)
    -- @
    --
    -- The reason is that it helps the compiler pick up this instance having
    -- only the non-variable parts of the type signature,
    -- since type equality is verified after the instance match.
    -- This provides for better type inference and better error messages.
    --
    -- In case of our example we're ensuring that the compiler will pick
    -- up the instance for any function parameterised by @NetworkAddress@.
  )
where

import qualified Data.ByteString as ByteString
import qualified Data.Text.Encoding as Text
import Domain.Prelude hiding (readFile)
import qualified Domain.Resolvers.TypeCentricDoc as TypeCentricResolver
import qualified Domain.TH.InstanceDecs as InstanceDecs
import qualified Domain.TH.TypeDec as TypeDec
import qualified Domain.YamlUnscrambler.TypeCentricDoc as TypeCentricYaml
import qualified DomainCore.Deriver as Deriver
import qualified DomainCore.Model as Model
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import qualified YamlUnscrambler

-- |
-- Declare datatypes and typeclass instances
-- from a schema definition according to the provided settings.
--
-- Use this function in combination with the 'schema' quasi-quoter or
-- the 'loadSchema' function.
-- __For examples__ refer to their documentation.
--
-- Call it on the top-level (where you declare your module members).
declare ::
  -- |
  --  Field naming.
  --  When nothing, no fields will be generated.
  --  Otherwise the first wrapped boolean specifies,
  --  whether to prefix the names with underscore,
  --  and the second - whether to prefix with the type name.
  --  Please notice that when you choose not to prefix with the type name
  --  you need to have the @DuplicateRecords@ extension enabled.
  Maybe (Bool, Bool) ->
  -- |
  --  Which instances to derive and how.
  Deriver.Deriver ->
  -- |
  --  Schema definition.
  Schema ->
  -- |
  --  Template Haskell action splicing the generated code on declaration level.
  Q [Dec]
declare :: Maybe (Bool, Bool) -> Deriver -> Schema -> Q [Dec]
declare Maybe (Bool, Bool)
fieldNaming (Deriver.Deriver TypeDec -> Q [Dec]
derive) (Schema [TypeDec]
schema) =
  do
    [Dec]
instanceDecs <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Eq a => [a] -> [a]
nub forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TypeDec -> Q [Dec]
derive [TypeDec]
schema)
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe (Bool, Bool) -> TypeDec -> Dec
TypeDec.typeDec Maybe (Bool, Bool)
fieldNaming) [TypeDec]
schema forall a. Semigroup a => a -> a -> a
<> [Dec]
instanceDecs)

-- * Schema

-------------------------

-- |
-- Parsed and validated schema.
--
-- You can only produce it using the 'schema' quasi-quoter or
-- the 'loadSchema' function
-- and generate the code from it using 'declare'.
newtype Schema
  = Schema [Model.TypeDec]
  deriving (forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Schema -> m Exp
forall (m :: * -> *). Quote m => Schema -> Code m Schema
liftTyped :: forall (m :: * -> *). Quote m => Schema -> Code m Schema
$cliftTyped :: forall (m :: * -> *). Quote m => Schema -> Code m Schema
lift :: forall (m :: * -> *). Quote m => Schema -> m Exp
$clift :: forall (m :: * -> *). Quote m => Schema -> m Exp
Lift)

-- |
-- Quasi-quoter, which parses a YAML schema into a 'Schema' expression.
--
-- Use 'declare' to generate the code from it.
--
-- ==== __Example__
--
-- @
-- {\-# LANGUAGE
--   QuasiQuotes, TemplateHaskell,
--   StandaloneDeriving, DeriveGeneric, DeriveDataTypeable, DeriveLift,
--   FlexibleInstances, MultiParamTypeClasses,
--   DataKinds, TypeFamilies
--   #-\}
-- module Model where
--
-- import Data.Text (Text)
-- import Data.Word (Word16, Word32, Word64)
-- import Domain
--
-- 'declare'
--   (Just (False, True))
--   'stdDeriver'
--   ['schema'|
--
--     Host:
--       sum:
--         ip: Ip
--         name: Text
--
--     Ip:
--       sum:
--         v4: Word32
--         v6: Word128
--
--     Word128:
--       product:
--         part1: Word64
--         part2: Word64
--
--     |]
-- @
schema :: QuasiQuoter
schema :: QuasiQuoter
schema =
  (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter String -> Q Exp
exp forall {m :: * -> *} {b} {a}. MonadFail m => b -> m a
pat forall {m :: * -> *} {b} {a}. MonadFail m => b -> m a
type_ forall {m :: * -> *} {b} {a}. MonadFail m => b -> m a
dec
  where
    unsupported :: b -> m a
unsupported =
      forall a b. a -> b -> a
const (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Quotation in this context is not supported")
    exp :: String -> Q Exp
exp =
      forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> Q Schema
parseString
    pat :: b -> m a
pat =
      forall {m :: * -> *} {b} {a}. MonadFail m => b -> m a
unsupported
    type_ :: b -> m a
type_ =
      forall {m :: * -> *} {b} {a}. MonadFail m => b -> m a
unsupported
    dec :: b -> m a
dec =
      forall {m :: * -> *} {b} {a}. MonadFail m => b -> m a
unsupported

-- |
-- Load and parse a YAML file into a schema definition.
--
-- Use 'declare' to generate the code from it.
--
-- ==== __Example__
--
-- @
-- {\-# LANGUAGE
--   TemplateHaskell,
--   StandaloneDeriving, DeriveGeneric, DeriveDataTypeable, DeriveLift,
--   FlexibleInstances, MultiParamTypeClasses,
--   DataKinds, TypeFamilies
--   #-\}
-- module Model where
--
-- import Data.Text (Text)
-- import Data.Word (Word16, Word32, Word64)
-- import Domain
--
-- 'declare'
--   (Just (True, False))
--   'stdDeriver'
--   =<< 'loadSchema' "domain.yaml"
-- @
loadSchema ::
  -- |
  --  Path to the schema file relative to the root of the project.
  FilePath ->
  -- |
  --  Template Haskell action producing a valid schema.
  Q Schema
loadSchema :: String -> Q Schema
loadSchema String
path =
  String -> Q ByteString
readFile String
path forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Q Schema
parseByteString

-- * Helpers

-------------------------

readFile :: FilePath -> Q ByteString
readFile :: String -> Q ByteString
readFile String
path =
  do
    String -> Q ()
addDependentFile String
path
    Either IOError ByteString
readRes <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IO a -> IO (Either IOError a)
tryIOError (String -> IO ByteString
ByteString.readFile String
path))
    forall a. Either Text a -> Q a
liftEither (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Show a => a -> Text
showAsText Either IOError ByteString
readRes)

parseString :: String -> Q Schema
parseString :: String -> Q Schema
parseString =
  Text -> Q Schema
parseText forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. IsString a => String -> a
fromString

parseText :: Text -> Q Schema
parseText :: Text -> Q Schema
parseText =
  ByteString -> Q Schema
parseByteString forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ByteString
Text.encodeUtf8

parseByteString :: ByteString -> Q Schema
parseByteString :: ByteString -> Q Schema
parseByteString ByteString
input =
  forall a. Either Text a -> Q a
liftEither forall a b. (a -> b) -> a -> b
$ do
    [(Text, Structure)]
doc <- forall a. Value a -> ByteString -> Either Text a
YamlUnscrambler.parseByteString Value [(Text, Structure)]
TypeCentricYaml.doc ByteString
input
    [TypeDec]
decs <- forall (f :: * -> *).
Applicative f =>
[(Text, Structure)] -> f [TypeDec]
TypeCentricResolver.eliminateDoc [(Text, Structure)]
doc
    forall (m :: * -> *) a. Monad m => a -> m a
return ([TypeDec] -> Schema
Schema [TypeDec]
decs)

liftEither :: Either Text a -> Q a
liftEither :: forall a. Either Text a -> Q a
liftEither =
  \case
    Left Text
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (forall l. IsList l => l -> [Item l]
toList Text
err)
    Right a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- * Deriver

-------------------------

-- |
-- Combination of all derivers exported by this module.
stdDeriver :: Deriver.Deriver
stdDeriver :: Deriver
stdDeriver =
  forall a. Monoid a => [a] -> a
mconcat
    [ Deriver
enumDeriver,
      Deriver
boundedDeriver,
      Deriver
showDeriver,
      Deriver
eqDeriver,
      Deriver
ordDeriver,
      Deriver
genericDeriver,
      Deriver
dataDeriver,
      Deriver
typeableDeriver,
      Deriver
hashableDeriver,
      Deriver
liftDeriver,
      Deriver
hasFieldDeriver,
      Deriver
constructorIsLabelDeriver,
      Deriver
mapperIsLabelDeriver,
      Deriver
accessorIsLabelDeriver
    ]

-- |
-- Derives 'Enum' for enums or sums having no members in all variants.
--
-- Requires to have the @StandaloneDeriving@ compiler extension enabled.
enumDeriver :: Deriver.Deriver
enumDeriver :: Deriver
enumDeriver =
  (TypeDec -> [Dec]) -> Deriver
Deriver.effectless TypeDec -> [Dec]
InstanceDecs.enum

-- |
-- Derives 'Bounded' for enums.
--
-- Requires to have the @StandaloneDeriving@ compiler extension enabled.
boundedDeriver :: Deriver.Deriver
boundedDeriver :: Deriver
boundedDeriver =
  (TypeDec -> [Dec]) -> Deriver
Deriver.effectless TypeDec -> [Dec]
InstanceDecs.bounded

-- |
-- Derives 'Show'.
--
-- Requires to have the @StandaloneDeriving@ compiler extension enabled.
showDeriver :: Deriver.Deriver
showDeriver :: Deriver
showDeriver =
  (TypeDec -> [Dec]) -> Deriver
Deriver.effectless TypeDec -> [Dec]
InstanceDecs.show

-- |
-- Derives 'Eq'.
--
-- Requires to have the @StandaloneDeriving@ compiler extension enabled.
eqDeriver :: Deriver.Deriver
eqDeriver :: Deriver
eqDeriver =
  (TypeDec -> [Dec]) -> Deriver
Deriver.effectless TypeDec -> [Dec]
InstanceDecs.eq

-- |
-- Derives 'Ord'.
--
-- Requires to have the @StandaloneDeriving@ compiler extension enabled.
ordDeriver :: Deriver.Deriver
ordDeriver :: Deriver
ordDeriver =
  (TypeDec -> [Dec]) -> Deriver
Deriver.effectless TypeDec -> [Dec]
InstanceDecs.ord

-- |
-- Derives 'Generic'.
--
-- Requires to have the @StandaloneDeriving@ and @DeriveGeneric@ compiler extensions enabled.
genericDeriver :: Deriver.Deriver
genericDeriver :: Deriver
genericDeriver =
  (TypeDec -> [Dec]) -> Deriver
Deriver.effectless TypeDec -> [Dec]
InstanceDecs.generic

-- |
-- Derives 'Data'.
--
-- Requires to have the @StandaloneDeriving@ and @DeriveDataTypeable@ compiler extensions enabled.
dataDeriver :: Deriver.Deriver
dataDeriver :: Deriver
dataDeriver =
  (TypeDec -> [Dec]) -> Deriver
Deriver.effectless TypeDec -> [Dec]
InstanceDecs.data_

-- |
-- Derives 'Typeable'.
--
-- Requires to have the @StandaloneDeriving@ and @DeriveDataTypeable@ compiler extensions enabled.
typeableDeriver :: Deriver.Deriver
typeableDeriver :: Deriver
typeableDeriver =
  (TypeDec -> [Dec]) -> Deriver
Deriver.effectless TypeDec -> [Dec]
InstanceDecs.typeable

-- |
-- Generates 'Generic'-based instances of 'Hashable'.
hashableDeriver :: Deriver.Deriver
hashableDeriver :: Deriver
hashableDeriver =
  (TypeDec -> [Dec]) -> Deriver
Deriver.effectless TypeDec -> [Dec]
InstanceDecs.hashable

-- |
-- Derives 'Lift'.
--
-- Requires to have the @StandaloneDeriving@ and @DeriveLift@ compiler extensions enabled.
liftDeriver :: Deriver.Deriver
liftDeriver :: Deriver
liftDeriver =
  (TypeDec -> [Dec]) -> Deriver
Deriver.effectless TypeDec -> [Dec]
InstanceDecs.lift

-- ** HasField

-------------------------

-- |
-- Derives 'HasField' with unprefixed field names.
--
-- For each field of a product generates instances mapping to their values.
--
-- For each constructor of a sum maps to a 'Maybe' tuple of members of that constructor,
-- unless there\'s no members, in which case it maps to 'Bool'.
--
-- For each variant of an enum maps to 'Bool' signaling whether the value equals to it.
--
-- /Please notice that if you choose to generate unprefixed record field accessors, it will conflict with this deriver, since it\'s gonna generate duplicate instances./
hasFieldDeriver :: Deriver.Deriver
hasFieldDeriver :: Deriver
hasFieldDeriver =
  (TypeDec -> [Dec]) -> Deriver
Deriver.effectless TypeDec -> [Dec]
InstanceDecs.hasField

-- * IsLabel

-------------------------

-- |
-- Generates instances of 'IsLabel' for wrappers, enums and sums,
-- providing mappings from labels to constructors.
--
-- ==== __Sum Example__
--
-- Having the following schema:
--
-- @
-- Host:
--   sum:
--     ip: Ip
--     name: Text
-- @
--
-- The following instances will be generated:
--
-- @
-- instance a ~ Ip => IsLabel "ip" (a -> Host) where
--   fromLabel = IpHost
--
-- instance a ~ Text => IsLabel "name" (a -> Host) where
--   fromLabel = NameHost
-- @
--
-- In case you\'re wondering what this tilde (@~@) constraint business is about,
-- refer to the [Type Equality Constraint](#type-equality-constraint) section.
--
-- ==== __Enum Example__
--
-- Having the following schema:
--
-- @
-- TransportProtocol:
--   enum:
--     - tcp
--     - udp
-- @
--
-- The following instances will be generated:
--
-- @
-- instance IsLabel "tcp" TransportProtocol where
--   fromLabel = TcpTransportProtocol
--
-- instance IsLabel "udp" TransportProtocol where
--   fromLabel = UdpTransportProtocol
-- @
constructorIsLabelDeriver :: Deriver.Deriver
constructorIsLabelDeriver :: Deriver
constructorIsLabelDeriver =
  (TypeDec -> [Dec]) -> Deriver
Deriver.effectless TypeDec -> [Dec]
InstanceDecs.constructorIsLabel

-- |
-- Generates instances of 'IsLabel' for enums, sums and products,
-- providing accessors to their components.
--
-- ==== __Product Example__
--
-- Having the following schema:
--
-- @
-- NetworkAddress:
--   product:
--     protocol: TransportProtocol
--     host: Host
--     port: Word16
-- @
--
-- The following instances will be generated:
--
-- @
-- instance a ~ TransportProtocol => IsLabel "protocol" (NetworkAddress -> a) where
--   fromLabel (NetworkAddress a _ _) = a
--
-- instance a ~ Host => IsLabel "host" (NetworkAddress -> a) where
--   fromLabel (NetworkAddress _ b _) = b
--
-- instance a ~ Word16 => IsLabel "port" (NetworkAddress -> a) where
--   fromLabel (NetworkAddress _ _ c) = c
-- @
--
-- In case you\'re wondering what this tilde (@~@) constraint business is about,
-- refer to the [Type Equality Constraint](#type-equality-constraint) section.
--
-- ==== __Sum Example__
--
-- Having the following schema:
--
-- @
-- Host:
--   sum:
--     ip: Ip
--     name: Text
-- @
--
-- The following instances will be generated:
--
-- @
-- instance a ~ Maybe Ip => IsLabel "ip" (Host -> a) where
--   fromLabel (IpHost a) = Just a
--   fromLabel _ = Nothing
--
-- instance a ~ Maybe Text => IsLabel "name" (Host -> a) where
--   fromLabel (NameHost a) = Just a
--   fromLabel _ = Nothing
-- @
--
-- In case you\'re wondering what this tilde (@~@) constraint business is about,
-- refer to the [Type Equality Constraint](#type-equality-constraint) section.
--
-- ==== __Enum Example__
--
-- Having the following schema:
--
-- @
-- TransportProtocol:
--   enum:
--     - tcp
--     - udp
-- @
--
-- The following instances will be generated:
--
-- @
-- instance a ~ Bool => IsLabel "tcp" (TransportProtocol -> a) where
--   fromLabel TcpTransportProtocol = True
--   fromLabel _ = False
--
-- instance a ~ Bool => IsLabel "udp" (TransportProtocol -> a) where
--   fromLabel UdpTransportProtocol = True
--   fromLabel _ = False
-- @
--
-- In case you\'re wondering what this tilde (@~@) constraint business is about,
-- refer to the [Type Equality Constraint](#type-equality-constraint) section.
accessorIsLabelDeriver :: Deriver.Deriver
accessorIsLabelDeriver :: Deriver
accessorIsLabelDeriver =
  (TypeDec -> [Dec]) -> Deriver
Deriver.effectless TypeDec -> [Dec]
InstanceDecs.accessorIsLabel

-- |
-- Generates instances of 'IsLabel' for sums and products,
-- providing mappers over their components.
--
-- ==== __Product Example__
--
-- Having the following schema:
--
-- @
-- NetworkAddress:
--   product:
--     protocol: TransportProtocol
--     host: Host
--     port: Word16
-- @
--
-- The following instances will be generated:
--
-- @
-- instance
--   mapper ~ (TransportProtocol -> TransportProtocol) =>
--   IsLabel "protocol" (mapper -> NetworkAddress -> NetworkAddress)
--   where
--     fromLabel mapper (NetworkAddress a b c) =
--       NetworkAddress (mapper a) b c
--
-- instance
--   mapper ~ (Host -> Host) =>
--   IsLabel "host" (mapper -> NetworkAddress -> NetworkAddress)
--   where
--     fromLabel mapper (NetworkAddress a b c) =
--       NetworkAddress a (mapper b) c
--
-- instance
--   mapper ~ (Word16 -> Word16) =>
--   IsLabel "port" (mapper -> NetworkAddress -> NetworkAddress)
--   where
--     fromLabel mapper (NetworkAddress a b c) =
--       NetworkAddress a b (mapper c)
-- @
--
-- In case you\'re wondering what this tilde (@~@) constraint business is about,
-- refer to the [Type Equality Constraint](#type-equality-constraint) section.
--
-- ==== __Sum Example__
--
-- Having the following schema:
--
-- @
-- Host:
--   sum:
--     ip: Ip
--     name: Text
-- @
--
-- The following instances will be generated:
--
-- @
-- instance
--   mapper ~ (Ip -> Ip) =>
--   IsLabel "ip" (mapper -> Host -> Host)
--   where
--     fromLabel fn (IpHost a) = IpHost (fn a)
--     fromLabel _ a = a
--
-- instance
--   mapper ~ (Text -> Text) =>
--   IsLabel "name" (mapper -> Host -> Host)
--   where
--     fromLabel fn (NameHost a) = NameHost (fn a)
--     fromLabel _ a = a
-- @
--
-- In case you\'re wondering what this tilde (@~@) constraint business is about,
-- refer to the [Type Equality Constraint](#type-equality-constraint) section.
mapperIsLabelDeriver :: Deriver.Deriver
mapperIsLabelDeriver :: Deriver
mapperIsLabelDeriver =
  (TypeDec -> [Dec]) -> Deriver
Deriver.effectless TypeDec -> [Dec]
InstanceDecs.mapperIsLabel