{-|
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 Domain.Prelude hiding (liftEither, readFile, lift)
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Quote
import qualified Data.ByteString as ByteString
import qualified Data.Text.Encoding as Text
import qualified Domain.Resolvers.TypeCentricDoc as TypeCentricResolver
import qualified Domain.TH.TypeDec as TypeDec
import qualified Domain.TH.InstanceDecs as InstanceDecs
import qualified Domain.YamlUnscrambler.TypeCentricDoc as TypeCentricYaml
import qualified DomainCore.Deriver as Deriver
import qualified DomainCore.Model as Model
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 <- ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Dec] -> [Dec]
forall a. Eq a => [a] -> [a]
nub ([Dec] -> [Dec]) -> ([[Dec]] -> [Dec]) -> [[Dec]] -> [Dec]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) ((TypeDec -> Q [Dec]) -> [TypeDec] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TypeDec -> Q [Dec]
derive [TypeDec]
schema)
    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ((TypeDec -> Dec) -> [TypeDec] -> [Dec]
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 [Dec] -> [Dec] -> [Dec]
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 (Schema -> Q Exp
Schema -> Q (TExp Schema)
(Schema -> Q Exp) -> (Schema -> Q (TExp Schema)) -> Lift Schema
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Schema -> Q (TExp Schema)
$cliftTyped :: Schema -> Q (TExp Schema)
lift :: Schema -> Q Exp
$clift :: Schema -> Q 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 String -> Q Pat
forall (m :: * -> *) b a. MonadFail m => b -> m a
pat String -> Q Type
forall (m :: * -> *) b a. MonadFail m => b -> m a
type_ String -> Q [Dec]
forall (m :: * -> *) b a. MonadFail m => b -> m a
dec
  where
    unsupported :: b -> m a
unsupported =
      m a -> b -> m a
forall a b. a -> b -> a
const (String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Quotation in this context is not supported")
    exp :: String -> Q Exp
exp =
      Schema -> Q Exp
forall t. Lift t => t -> Q Exp
lift (Schema -> Q Exp) -> (String -> Q Schema) -> String -> Q Exp
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 =
      b -> m a
forall (m :: * -> *) b a. MonadFail m => b -> m a
unsupported
    type_ :: b -> m a
type_ =
      b -> m a
forall (m :: * -> *) b a. MonadFail m => b -> m a
unsupported
    dec :: b -> m a
dec =
      b -> m a
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 Q ByteString -> (ByteString -> Q Schema) -> Q Schema
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 <- IO (Either IOError ByteString) -> Q (Either IOError ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> IO (Either IOError ByteString)
forall a. IO a -> IO (Either IOError a)
tryIOError (String -> IO ByteString
ByteString.readFile String
path))
    Either Text ByteString -> Q ByteString
forall a. Either Text a -> Q a
liftEither ((IOError -> Text)
-> Either IOError ByteString -> Either Text ByteString
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first IOError -> Text
forall a. Show a => a -> Text
showAsText Either IOError ByteString
readRes)

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

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

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


-- * Deriver
-------------------------

{-|
Combination of all derivers exported by this module.
-}
stdDeriver :: Deriver
stdDeriver =
  [Deriver] -> Deriver
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
enumDeriver =
  (TypeDec -> [Dec]) -> Deriver
Deriver.effectless TypeDec -> [Dec]
InstanceDecs.enum

{-|
Derives 'Bounded' for enums.

Requires to have the @StandaloneDeriving@ compiler extension enabled.
-}
boundedDeriver :: Deriver
boundedDeriver =
  (TypeDec -> [Dec]) -> Deriver
Deriver.effectless TypeDec -> [Dec]
InstanceDecs.bounded

{-|
Derives 'Show'.

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

{-|
Derives 'Eq'.

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

{-|
Derives 'Ord'.

Requires to have the @StandaloneDeriving@ compiler extension enabled.
-}
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
genericDeriver =
  (TypeDec -> [Dec]) -> Deriver
Deriver.effectless TypeDec -> [Dec]
InstanceDecs.generic

{-|
Derives 'Data'.

Requires to have the @StandaloneDeriving@ and @DeriveDataTypeable@ compiler extensions enabled.
-}
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
typeableDeriver =
  (TypeDec -> [Dec]) -> Deriver
Deriver.effectless TypeDec -> [Dec]
InstanceDecs.typeable

{-|
Generates 'Generic'-based instances of 'Hashable'.
-}
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
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
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
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
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
mapperIsLabelDeriver =
  (TypeDec -> [Dec]) -> Deriver
Deriver.effectless TypeDec -> [Dec]
InstanceDecs.mapperIsLabel