packages feed

domain (empty) → 0.1

raw patch · 22 files changed

+2547/−0 lines, 22 filesdep +QuickCheckdep +attoparsecdep +basesetup-changed

Dependencies added: QuickCheck, attoparsec, base, bytestring, domain, domain-core, foldl, hashable, parser-combinators, quickcheck-instances, rerebase, tasty, tasty-hunit, tasty-quickcheck, template-haskell, template-haskell-compat-v0208, text, th-lego, th-orphans, yaml-unscrambler

Files

+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2020 Nikita Volkov++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,546 @@+# About++Codegen solving multiple problems of the standard Haskell approach to defining models.++# Problem++Declaring a data model in Haskell can get cumbersome. While it is much better than in most popular languages it still suffers from boilerplate, it distracts the developer by forcing to solve unrelated problems in the same place and the code is not terribly readable. On top of that we have the notorious records problem and other naming issues to solve causing inconsistent naming conventions or absense thereof, or workarounds causing more distraction and noise. Declaring instances for typeclasses other than the basic ones requires multiple approaches depending on the class, becoming a non-trivial task for non-experts and producing even more boilerplate.++# Mission++In its approach to those problems this projects sets the following goals:++- Let the domain model definition be focused on data and nothing else.+- Let it be readable and comfortably editable, avoiding syntactic noise.+- Separate its declaration from the problems of declaration of instances, accessor functions, optics and etc.+- Have the records problem solved.+- Have the problem of conflicting constructor names solved.+- Avoid boilerplate while doing all the above.+- Avoid complications of the build process while doing all the above.++# Solution++This project introduces a clear boundary between the data model declaration and the rest of the code base.+It introduces a low-noise YAML format designed specifically for the problem of defining types and relations between them and that only. We call it Domain Schema.++Schemas can be loaded at compile time and transformed into Haskell declarations using Template Haskell. Since it's just Template Haskell, no extra build software is needed for you to use this library. It is a simple Haskell package.++Schema gets analysed allowing to generate all kinds of instances automatically using a set of prepackaged derivers. An API is provided for creation of custom derivers of uncovered typeclasses.++# Case in point++We'll show you how this whole thing works on an example of a model of a service address.++## Schema++```yaml+# Service can be either located on the network or+# by a socket file.+#+# Choice between two or more types can be encoded using+# "sum" type composition, which you may also know as+# "union" or "variant". That's what we use here.+ServiceAddress:+  sum:+    network: NetworkAddress+    local: FilePath++# Network address is a combination of transport protocol,+# host and port. All those three things at once.+#+# "product" type composition lets us encode that.+# You may also know it as "record" or "tuple".+NetworkAddress:+  product:+    protocol: TransportProtocol+    host: Host+    port: Word16++# Transport protocol is either TCP or UDP.+# We encode that using enumeration.+TransportProtocol:+  enum:+    - tcp+    - udp++# Host can be adressed by either an IP or its name,+# so "sum" again.+Host:+  sum:+    ip: Ip+    name: Text++# IP can be either of version 4 or version 6.+# We encode it as a sum over words of the accordingly required+# amount of bits.+Ip:+  sum:+    v4: Word32+    v6: Word128++# Since the standard lib lacks a definition+# of a 128-bit word, we define a custom one+# as a product of two 64-bit words.+Word128:+  product:+    part1: Word64+    part2: Word64+```++As you can see in the specification above we're not concerned with typeclass instances or problems of name disambiguation. We're only concerned with data and relations that it has. This is what we meant by focus. It makes the experience of designing a model way smoother and the maintenance easier.++Those three methods of defining types (product, sum, enum) are all that you need to define a model of any complexity. If you understand them, there's nothing new to learn.++### Codegen++Now, having that schema defined in a file at path `schemas/model.yaml`,+we can load it in a Haskell module as follows:++```haskell+{-# 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 (False, True)) mempty+  =<< loadSchema "schemas/model.yaml"+```++And that will cause the compiler to generate the following declarations:++```haskell+data ServiceAddress =+  NetworkServiceAddress !NetworkAddress |+  LocalServiceAddress !FilePath++data NetworkAddress =+  NetworkAddress {+    networkAddressProtocol :: !TransportProtocol,+    networkAddressHost :: !Host,+    networkAddressPort :: !Word16+  }++data TransportProtocol =+  TcpTransportProtocol |+  UdpTransportProtocol++data Host =+  IpHost !Ip |+  NameHost !Text++data Ip =+  V4Ip !Word32 |+  V6Ip !Word128++data Word128 =+  Word128 {+    word128Part1 :: !Word64,+    word128Part2 :: !Word64+  }+```++As you can see in the generated code the field names from the schema get translated to record fields or constructors depending on the type composition method.++In this example the record fields are prefixed with type names for disambiguation, but by modifying the options passed to the `declare` function it is possible to remove the type name prefix or prepend with underscore, you can also avoid generating record fields altogether (to keep the value-level namespace clean).++The constructor names are also disambiguated by appending the type name to the label from schema. Thus we are introducing a consistent naming convention, while avoiding the boilerplate in the declaration of the model.++### Instances++If we introduce the following change to our code:++```diff+-declare (Just (False, True)) mempty++declare (Just (False, True)) stdDeriver+```++We'll get a ton of instances generated including the obvious `Show`, `Eq` and even `Hashable` for all the declared types. We'll also get some useful ones, which you wouldn't derive otherwise.++<details>+  <summary><strong>Listing of generated instances</strong> (it's big)</summary>++```haskell+deriving instance Show ServiceAddress+deriving instance Eq ServiceAddress+deriving instance Ord ServiceAddress+deriving instance GHC.Generics.Generic ServiceAddress+deriving instance Data.Data.Data ServiceAddress+deriving instance base-4.14.1.0:Data.Typeable.Internal.Typeable ServiceAddress+instance hashable-1.3.0.0:Data.Hashable.Class.Hashable ServiceAddress+deriving instance template-haskell-2.16.0.0:Language.Haskell.TH.Syntax.Lift ServiceAddress+instance GHC.Records.HasField "network" ServiceAddress (Maybe NetworkAddress) where+  GHC.Records.getField (NetworkServiceAddress a) = Just a+  GHC.Records.getField _ = Nothing+instance GHC.Records.HasField "local" ServiceAddress (Maybe FilePath) where+  GHC.Records.getField (LocalServiceAddress a) = Just a+  GHC.Records.getField _ = Nothing+instance (a ~ NetworkAddress) =>+         GHC.OverloadedLabels.IsLabel "network" (a -> ServiceAddress) where+  GHC.OverloadedLabels.fromLabel = NetworkServiceAddress+instance (a ~ FilePath) =>+         GHC.OverloadedLabels.IsLabel "local" (a -> ServiceAddress) where+  GHC.OverloadedLabels.fromLabel = LocalServiceAddress+instance (mapper ~ (NetworkAddress -> NetworkAddress)) =>+         GHC.OverloadedLabels.IsLabel "network" (mapper+                                                 -> ServiceAddress -> ServiceAddress) where+  GHC.OverloadedLabels.fromLabel+    = \ fn+        -> \ a+             -> case a of+                  NetworkServiceAddress a -> NetworkServiceAddress (fn a)+                  a -> a+instance (mapper ~ (FilePath -> FilePath)) =>+         GHC.OverloadedLabels.IsLabel "local" (mapper+                                               -> ServiceAddress -> ServiceAddress) where+  GHC.OverloadedLabels.fromLabel+    = \ fn+        -> \ a+             -> case a of+                  LocalServiceAddress a -> LocalServiceAddress (fn a)+                  a -> a+instance (a ~ Maybe NetworkAddress) =>+         GHC.OverloadedLabels.IsLabel "network" (ServiceAddress -> a) where+  GHC.OverloadedLabels.fromLabel+    = \ a+        -> case a of+             NetworkServiceAddress a -> Just a+             _ -> Nothing+instance (a ~ Maybe FilePath) =>+         GHC.OverloadedLabels.IsLabel "local" (ServiceAddress -> a) where+  GHC.OverloadedLabels.fromLabel+    = \ a+        -> case a of+             LocalServiceAddress a -> Just a+             _ -> Nothing+deriving instance Show NetworkAddress+deriving instance Eq NetworkAddress+deriving instance Ord NetworkAddress+deriving instance GHC.Generics.Generic NetworkAddress+deriving instance Data.Data.Data NetworkAddress+deriving instance base-4.14.1.0:Data.Typeable.Internal.Typeable NetworkAddress+instance hashable-1.3.0.0:Data.Hashable.Class.Hashable NetworkAddress+deriving instance template-haskell-2.16.0.0:Language.Haskell.TH.Syntax.Lift NetworkAddress+instance GHC.Records.HasField "protocol" NetworkAddress TransportProtocol where+  GHC.Records.getField (NetworkAddress a _ _) = a+instance GHC.Records.HasField "host" NetworkAddress Host where+  GHC.Records.getField (NetworkAddress _ a _) = a+instance GHC.Records.HasField "port" NetworkAddress Word16 where+  GHC.Records.getField (NetworkAddress _ _ a) = a+instance (mapper ~ (TransportProtocol -> TransportProtocol)) =>+         GHC.OverloadedLabels.IsLabel "protocol" (mapper+                                                  -> NetworkAddress -> NetworkAddress) where+  GHC.OverloadedLabels.fromLabel+    = \ fn (NetworkAddress a b c) -> ((NetworkAddress (fn a)) b) c+instance (mapper ~ (Host -> Host)) =>+         GHC.OverloadedLabels.IsLabel "host" (mapper+                                              -> NetworkAddress -> NetworkAddress) where+  GHC.OverloadedLabels.fromLabel+    = \ fn (NetworkAddress a b c) -> ((NetworkAddress a) (fn b)) c+instance (mapper ~ (Word16 -> Word16)) =>+         GHC.OverloadedLabels.IsLabel "port" (mapper+                                              -> NetworkAddress -> NetworkAddress) where+  GHC.OverloadedLabels.fromLabel+    = \ fn (NetworkAddress a b c) -> ((NetworkAddress a) b) (fn c)+instance (a ~ TransportProtocol) =>+         GHC.OverloadedLabels.IsLabel "protocol" (NetworkAddress -> a) where+  GHC.OverloadedLabels.fromLabel = \ (NetworkAddress a _ _) -> a+instance (a ~ Host) =>+         GHC.OverloadedLabels.IsLabel "host" (NetworkAddress -> a) where+  GHC.OverloadedLabels.fromLabel = \ (NetworkAddress _ b _) -> b+instance (a ~ Word16) =>+         GHC.OverloadedLabels.IsLabel "port" (NetworkAddress -> a) where+  GHC.OverloadedLabels.fromLabel = \ (NetworkAddress _ _ c) -> c+deriving instance Enum TransportProtocol+deriving instance Bounded TransportProtocol+deriving instance Show TransportProtocol+deriving instance Eq TransportProtocol+deriving instance Ord TransportProtocol+deriving instance GHC.Generics.Generic TransportProtocol+deriving instance Data.Data.Data TransportProtocol+deriving instance base-4.14.1.0:Data.Typeable.Internal.Typeable TransportProtocol+instance hashable-1.3.0.0:Data.Hashable.Class.Hashable TransportProtocol+deriving instance template-haskell-2.16.0.0:Language.Haskell.TH.Syntax.Lift TransportProtocol+instance GHC.Records.HasField "tcp" TransportProtocol Bool where+  GHC.Records.getField TcpTransportProtocol = True+  GHC.Records.getField _ = False+instance GHC.Records.HasField "udp" TransportProtocol Bool where+  GHC.Records.getField UdpTransportProtocol = True+  GHC.Records.getField _ = False+instance GHC.OverloadedLabels.IsLabel "tcp" TransportProtocol where+  GHC.OverloadedLabels.fromLabel = TcpTransportProtocol+instance GHC.OverloadedLabels.IsLabel "udp" TransportProtocol where+  GHC.OverloadedLabels.fromLabel = UdpTransportProtocol+instance (a ~ Bool) =>+         GHC.OverloadedLabels.IsLabel "tcp" (TransportProtocol -> a) where+  GHC.OverloadedLabels.fromLabel+    = \ a+        -> case a of+             TcpTransportProtocol -> True+             _ -> False+instance (a ~ Bool) =>+         GHC.OverloadedLabels.IsLabel "udp" (TransportProtocol -> a) where+  GHC.OverloadedLabels.fromLabel+    = \ a+        -> case a of+             UdpTransportProtocol -> True+             _ -> False+deriving instance Show Host+deriving instance Eq Host+deriving instance Ord Host+deriving instance GHC.Generics.Generic Host+deriving instance Data.Data.Data Host+deriving instance base-4.14.1.0:Data.Typeable.Internal.Typeable Host+instance hashable-1.3.0.0:Data.Hashable.Class.Hashable Host+deriving instance template-haskell-2.16.0.0:Language.Haskell.TH.Syntax.Lift Host+instance GHC.Records.HasField "ip" Host (Maybe Ip) where+  GHC.Records.getField (IpHost a) = Just a+  GHC.Records.getField _ = Nothing+instance GHC.Records.HasField "name" Host (Maybe Text) where+  GHC.Records.getField (NameHost a) = Just a+  GHC.Records.getField _ = Nothing+instance (a ~ Ip) =>+         GHC.OverloadedLabels.IsLabel "ip" (a -> Host) where+  GHC.OverloadedLabels.fromLabel = IpHost+instance (a ~ Text) =>+         GHC.OverloadedLabels.IsLabel "name" (a -> Host) where+  GHC.OverloadedLabels.fromLabel = NameHost+instance (mapper ~ (Ip -> Ip)) =>+         GHC.OverloadedLabels.IsLabel "ip" (mapper -> Host -> Host) where+  GHC.OverloadedLabels.fromLabel+    = \ fn+        -> \ a+             -> case a of+                  IpHost a -> IpHost (fn a)+                  a -> a+instance (mapper ~ (Text -> Text)) =>+         GHC.OverloadedLabels.IsLabel "name" (mapper -> Host -> Host) where+  GHC.OverloadedLabels.fromLabel+    = \ fn+        -> \ a+             -> case a of+                  NameHost a -> NameHost (fn a)+                  a -> a+instance (a ~ Maybe Ip) =>+         GHC.OverloadedLabels.IsLabel "ip" (Host -> a) where+  GHC.OverloadedLabels.fromLabel+    = \ a+        -> case a of+             IpHost a -> Just a+             _ -> Nothing+instance (a ~ Maybe Text) =>+         GHC.OverloadedLabels.IsLabel "name" (Host -> a) where+  GHC.OverloadedLabels.fromLabel+    = \ a+        -> case a of+             NameHost a -> Just a+             _ -> Nothing+deriving instance Show Ip+deriving instance Eq Ip+deriving instance Ord Ip+deriving instance GHC.Generics.Generic Ip+deriving instance Data.Data.Data Ip+deriving instance base-4.14.1.0:Data.Typeable.Internal.Typeable Ip+instance hashable-1.3.0.0:Data.Hashable.Class.Hashable Ip+deriving instance template-haskell-2.16.0.0:Language.Haskell.TH.Syntax.Lift Ip+instance GHC.Records.HasField "v4" Ip (Maybe Word32) where+  GHC.Records.getField (V4Ip a) = Just a+  GHC.Records.getField _ = Nothing+instance GHC.Records.HasField "v6" Ip (Maybe Word128) where+  GHC.Records.getField (V6Ip a) = Just a+  GHC.Records.getField _ = Nothing+instance (a ~ Word32) =>+         GHC.OverloadedLabels.IsLabel "v4" (a -> Ip) where+  GHC.OverloadedLabels.fromLabel = V4Ip+instance (a ~ Word128) =>+         GHC.OverloadedLabels.IsLabel "v6" (a -> Ip) where+  GHC.OverloadedLabels.fromLabel = V6Ip+instance (mapper ~ (Word32 -> Word32)) =>+         GHC.OverloadedLabels.IsLabel "v4" (mapper -> Ip -> Ip) where+  GHC.OverloadedLabels.fromLabel+    = \ fn+        -> \ a+             -> case a of+                  V4Ip a -> V4Ip (fn a)+                  a -> a+instance (mapper ~ (Word128 -> Word128)) =>+         GHC.OverloadedLabels.IsLabel "v6" (mapper -> Ip -> Ip) where+  GHC.OverloadedLabels.fromLabel+    = \ fn+        -> \ a+             -> case a of+                  V6Ip a -> V6Ip (fn a)+                  a -> a+instance (a ~ Maybe Word32) =>+         GHC.OverloadedLabels.IsLabel "v4" (Ip -> a) where+  GHC.OverloadedLabels.fromLabel+    = \ a+        -> case a of+             V4Ip a -> Just a+             _ -> Nothing+instance (a ~ Maybe Word128) =>+         GHC.OverloadedLabels.IsLabel "v6" (Ip -> a) where+  GHC.OverloadedLabels.fromLabel+    = \ a+        -> case a of+             V6Ip a -> Just a+             _ -> Nothing+deriving instance Show Word128+deriving instance Eq Word128+deriving instance Ord Word128+deriving instance GHC.Generics.Generic Word128+deriving instance Data.Data.Data Word128+deriving instance base-4.14.1.0:Data.Typeable.Internal.Typeable Word128+instance hashable-1.3.0.0:Data.Hashable.Class.Hashable Word128+deriving instance template-haskell-2.16.0.0:Language.Haskell.TH.Syntax.Lift Word128+instance GHC.Records.HasField "part1" Word128 Word64 where+  GHC.Records.getField (Word128 a _) = a+instance GHC.Records.HasField "part2" Word128 Word64 where+  GHC.Records.getField (Word128 _ a) = a+instance (mapper ~ (Word64 -> Word64)) =>+         GHC.OverloadedLabels.IsLabel "part1" (mapper+                                               -> Word128 -> Word128) where+  GHC.OverloadedLabels.fromLabel+    = \ fn (Word128 a b) -> (Word128 (fn a)) b+instance (mapper ~ (Word64 -> Word64)) =>+         GHC.OverloadedLabels.IsLabel "part2" (mapper+                                               -> Word128 -> Word128) where+  GHC.OverloadedLabels.fromLabel+    = \ fn (Word128 a b) -> (Word128 a) (fn b)+instance (a ~ Word64) =>+         GHC.OverloadedLabels.IsLabel "part1" (Word128 -> a) where+  GHC.OverloadedLabels.fromLabel = \ (Word128 a _) -> a+instance (a ~ Word64) =>+         GHC.OverloadedLabels.IsLabel "part2" (Word128 -> a) where+  GHC.OverloadedLabels.fromLabel = \ (Word128 _ b) -> b+```+</details>+<p/>+++### Labels++Among the generated instances you'll find instances for the `IsLabel` class. It is a class powering Haskell's `OverloadedLabels` extension. The instances we define for it let us reduce the boilerplate in the way we address our model. Here's how.++#### We can access the members of records:++```haskell+getNetworkAddressPort :: NetworkAddress -> Word16+getNetworkAddressPort = #port+```++Yep. Finally. Address your fields without crazy prefixes or dealing with disambiguation otherwise.++_Labels will be unprefixed regardless of what you choose to do about record fields. You can also name them whatever you like. Literally, even `type` and `data` make up valid labels, and unless you choose to generate unprefixed record fields, you can freely use them._++#### We get accessors to the members of sums as well:++```haskell+getHostIp :: Host -> Maybe Ip+getHostIp = #ip+```++Yep. Sum types can have accessors if you look at them from a certain perspective.++#### Accessors to enums - why not?++```haskell+isTransportProtocolTcp :: TransportProtocol -> Bool+isTransportProtocolTcp = #tcp+```++#### We get shortcuts to enums:++```haskell+tcpTransportProtocol :: TransportProtocol+tcpTransportProtocol = #tcp+```++#### We can instantiate sums:++```haskell+ipHost :: Ip -> Host+ipHost = #ip+```++#### We can map over both record fields and sum variants:++```haskell+mapNetworkAddressHost :: (Host -> Host) -> NetworkAddress -> NetworkAddress+mapNetworkAddressHost = #host+```++```haskell+mapHostIp :: (Ip -> Ip) -> Host -> Host+mapHostIp = #ip+```++There's a few things worth noticing here. Unfortunately the type inferencer will be unable to automatically detect the type of the mapping lambda parameter, so it needs to have an unambiguous type. This means that often times you'll have to provide an explicit type for it. But there's a solution.++There is a ["domain-optics"](https://github.com/nikita-volkov/domain-optics) library which provides an integration with the ["optics"](https://github.com/well-typed/optics) library. By including the derivers from it in the parameters to the `declare` macro, you'll be able to map as follows without type inference issues:++```haskell+mapNetworkAddressHost :: (Host -> Host) -> NetworkAddress -> NetworkAddress+mapNetworkAddressHost = over #host+```++You can read more about the "optics" library integration in [the Optics section](#optics).++#### If we can map, then we can also set:++```haskell+setNetworkAddressHost :: Host -> NetworkAddress -> NetworkAddress+setNetworkAddressHost host = #host (const host)+```++## Optics++Extensional ["domain-optics"](https://github.com/nikita-volkov/domain-optics) library provides integration with ["optics"](https://github.com/well-typed/optics). By using the derivers from it we can get optics using labels as well.++Coming back to our example here's all we'll have to do to enable our model with optics:++```haskell+{-# LANGUAGE+  TemplateHaskell,+  StandaloneDeriving, DeriveGeneric, DeriveDataTypeable, DeriveLift,+  FlexibleInstances, MultiParamTypeClasses,+  DataKinds, TypeFamilies,+  UndecidableInstances+  #-}+module Model where++import Data.Text (Text)+import Data.Word (Word16, Word32, Word64)+import Domain+import DomainOptics++declare (Just (False, True)) (stdDeriver <> labelOpticDeriver)+  =<< loadSchema "schemas/model.yaml"+```++Here are some of the optics that will become available to us:++```haskell+networkAddressHostOptic :: Lens' NetworkAddress Host+networkAddressHostOptic = #host+```++```haskell+hostIpOptic :: Prism' Host Ip+hostIpOptic = #ip+```++```haskell+tcpTransportProtocolOptic :: Prism' TransportProtocol ()+tcpTransportProtocolOptic = #tcp+```++_As you may have noticed, we avoid the "underscore-uppercase" naming convention for prisms. With labels there's no longer any need for it._++We recommend using "optics" instead of direct `IsLabel` instances, because functions like `view`, `over`, `set`, `review` make your intent clearer to the reader in many cases and in some cases provide better type inference.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ domain.cabal view
@@ -0,0 +1,97 @@+name: domain+version: 0.1+synopsis: Codegen helping you define domain models+description:+  - For introduction and demo skip to [Readme](#readme).+  - For documentation and syntax reference see the "Domain.Docs" module.+  - For API documentation refer to the "Domain" module,+    which exports the whole API of this package.+homepage: https://github.com/nikita-volkov/domain+bug-reports: https://github.com/nikita-volkov/domain/issues+author: Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer: Nikita Volkov <nikita.y.volkov@mail.ru>+copyright: (c) 2020 Nikita Volkov+license: MIT+license-file: LICENSE+build-type: Simple+cabal-version: >=1.10+extra-source-files:+  README.md+  samples/*.yaml++source-repository head+  type: git+  location: git://github.com/nikita-volkov/domain.git++library+  hs-source-dirs: library+  default-extensions: BangPatterns, BlockArguments, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveLift, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, InstanceSigs, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedLabels, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, StrictData, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators+  default-language: Haskell2010+  exposed-modules:+    Domain+    Domain.Docs+  other-modules:+    Domain.Attoparsec.General+    Domain.Attoparsec.TypeString+    Domain.Models.TypeCentricDoc+    Domain.Models.TypeString+    Domain.Prelude+    Domain.Resolvers.TypeCentricDoc+    Domain.TH.InstanceDec+    Domain.TH.InstanceDecs+    Domain.TH.TypeDec+    Domain.YamlUnscrambler.TypeCentricDoc+  build-depends:+    attoparsec >=0.13 && <0.14,+    base >=4.9 && <5,+    bytestring >=0.10 && <0.11,+    domain-core >=0.1 && <0.2,+    foldl >=1.4.9 && <2,+    hashable >=1 && <2,+    parser-combinators >=1.2.1 && <1.3,+    template-haskell >=2.13 && <3,+    template-haskell-compat-v0208 >=0.1.5 && <0.2,+    text >=1.2.3 && <2,+    th-lego >=0.2.3 && <0.3,+    yaml-unscrambler >=0.1 && <0.2++test-suite loading-demo+  type: exitcode-stdio-1.0+  hs-source-dirs: loading-demo+  main-is: Main.hs+  default-language: Haskell2010+  build-depends:+    base,+    domain,+    text++test-suite inline-demo+  type: exitcode-stdio-1.0+  hs-source-dirs: inline-demo+  main-is: Main.hs+  default-language: Haskell2010+  build-depends:+    base,+    domain,+    text++test-suite test+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  default-extensions: BangPatterns, BlockArguments, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveLift, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, InstanceSigs, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedLabels, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, StrictData, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators+  default-language: Haskell2010+  main-is: Main.hs+  other-modules:+    Util.TH+    Util.TH.LeafTypes+  build-depends:+    domain,+    domain-core,+    QuickCheck >=2.8.1 && <3,+    quickcheck-instances >=0.3.11 && <0.4,+    rerebase >=1.10.0.1 && <2,+    tasty >=0.12 && <2,+    tasty-hunit >=0.9 && <0.11,+    tasty-quickcheck >=0.9 && <0.11,+    template-haskell,+    th-orphans >=0.13 && <0.14
+ inline-demo/Main.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE+  QuasiQuotes, TemplateHaskell,+  StandaloneDeriving, DeriveGeneric, DeriveDataTypeable, DeriveLift,+  FlexibleInstances, MultiParamTypeClasses,+  DataKinds, TypeFamilies,+  OverloadedStrings, OverloadedLabels, TypeApplications+  #-}+module Main where++import Data.Text (Text)+import Data.Word (Word16, Word32, Word64)+import Domain+++main =+  return ()++declare (Just (False, True)) stdDeriver [schema|++  ServiceAddress:+    sum:+      network: NetworkAddress+      local: FilePath++  NetworkAddress:+    product:+      protocol: TransportProtocol+      host: Host+      port: Word16++  TransportProtocol:+    enum:+      - tcp+      - udp++  Host:+    sum:+      ip: Ip+      name: Text++  Ip:+    sum:+      v4: Word32+      v6: Word128++  Word128:+    product:+      part1: Word64+      part2: Word64++  |]++{-|+Shows how you can construct sum-types and enum-types using labels.++We need to specify the type for the #name constructor member,+because otherwise the compiler interprets it as String.+-}+serviceAddress :: ServiceAddress+serviceAddress =+  #network (NetworkAddress #tcp (#name ("local" :: Text)) 1234)++{-|+Shows how you can map. Unfortunately that requires a lot of manual typing.+-}+updatedServiceAddress :: ServiceAddress+updatedServiceAddress =+  #network (#port (succ @Word16) :: NetworkAddress -> NetworkAddress) serviceAddress
+ library/Domain.hs view
@@ -0,0 +1,599 @@+{-|+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 fieldNaming (Deriver.Deriver derive) (Schema schema) =+  do+    instanceDecs <- fmap (nub . concat) (traverse derive schema)+    return (fmap (TypeDec.typeDec fieldNaming) schema <> 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 (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 exp pat type_ dec+  where+    unsupported =+      const (fail "Quotation in this context is not supported")+    exp =+      lift <=< parseString+    pat =+      unsupported+    type_ =+      unsupported+    dec =+      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 path =+  readFile path >>= parseByteString+++-- * Helpers+-------------------------++readFile :: FilePath -> Q ByteString+readFile path =+  do+    addDependentFile path+    readRes <- liftIO (tryIOError (ByteString.readFile path))+    liftEither (first showAsText readRes)++parseString :: String -> Q Schema+parseString =+  parseText . fromString++parseText :: Text -> Q Schema+parseText =+  parseByteString . Text.encodeUtf8++parseByteString :: ByteString -> Q Schema+parseByteString input =+  liftEither $ do+    doc <- YamlUnscrambler.parseByteString TypeCentricYaml.doc input+    decs <- TypeCentricResolver.eliminateDoc doc+    return (Schema decs)++liftEither :: Either Text a -> Q a+liftEither =+  \ case+    Left err -> fail (toList err)+    Right a -> return a +++-- * Deriver+-------------------------++{-|+Combination of all derivers exported by this module.+-}+stdDeriver =+  mconcat [+    enumDeriver,+    boundedDeriver,+    showDeriver,+    eqDeriver,+    ordDeriver,+    genericDeriver,+    dataDeriver,+    typeableDeriver,+    hashableDeriver,+    liftDeriver,+    hasFieldDeriver,+    constructorIsLabelDeriver,+    mapperIsLabelDeriver,+    accessorIsLabelDeriver+    ]++{-|+Derives 'Enum' for enums or sums having no members in all variants.++Requires to have the @StandaloneDeriving@ compiler extension enabled.+-}+enumDeriver =+  Deriver.effectless InstanceDecs.enum++{-|+Derives 'Bounded' for enums.++Requires to have the @StandaloneDeriving@ compiler extension enabled.+-}+boundedDeriver =+  Deriver.effectless InstanceDecs.bounded++{-|+Derives 'Show'.++Requires to have the @StandaloneDeriving@ compiler extension enabled.+-}+showDeriver =+  Deriver.effectless InstanceDecs.show++{-|+Derives 'Eq'.++Requires to have the @StandaloneDeriving@ compiler extension enabled.+-}+eqDeriver =+  Deriver.effectless InstanceDecs.eq++{-|+Derives 'Ord'.++Requires to have the @StandaloneDeriving@ compiler extension enabled.+-}+ordDeriver =+  Deriver.effectless InstanceDecs.ord++{-|+Derives 'Generic'.++Requires to have the @StandaloneDeriving@ and @DeriveGeneric@ compiler extensions enabled.+-}+genericDeriver =+  Deriver.effectless InstanceDecs.generic++{-|+Derives 'Data'.++Requires to have the @StandaloneDeriving@ and @DeriveDataTypeable@ compiler extensions enabled.+-}+dataDeriver =+  Deriver.effectless InstanceDecs.data_++{-|+Derives 'Typeable'.++Requires to have the @StandaloneDeriving@ and @DeriveDataTypeable@ compiler extensions enabled.+-}+typeableDeriver =+  Deriver.effectless InstanceDecs.typeable++{-|+Generates 'Generic'-based instances of 'Hashable'.+-}+hashableDeriver =+  Deriver.effectless InstanceDecs.hashable++{-|+Derives 'Lift'.++Requires to have the @StandaloneDeriving@ and @DeriveLift@ compiler extensions enabled.+-}+liftDeriver =+  Deriver.effectless 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.effectless 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.effectless 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.effectless 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.effectless InstanceDecs.mapperIsLabel
+ library/Domain/Attoparsec/General.hs view
@@ -0,0 +1,49 @@+module Domain.Attoparsec.General+where++import Domain.Prelude hiding (takeWhile)+import Data.Attoparsec.Text+import qualified Data.Text as Text+++only parser =+  skipSpace *> parser <* skipSpace <* endOfInput++commaSeparated parser =+  sepBy parser comma++comma =+  skipSpace *> char ',' <* skipSpace++inParens parser =+  do+    char '('+    skipSpace+    a <- parser+    skipSpace+    char ')'+    return a++inSquareBrackets parser =+  do+    char '['+    skipSpace+    a <- parser+    skipSpace+    char ']'+    return a++skipSpace1 =+  space *> skipSpace++name firstCharPred =+  do+    a <- satisfy firstCharPred+    b <- takeWhile (\ a -> isAlphaNum a || a == '\'' || a == '_')+    return (Text.cons a b)++ucName =+  name isUpper++lcName =+  name (\ a -> isLower a || a == '_')
+ library/Domain/Attoparsec/TypeString.hs view
@@ -0,0 +1,27 @@+module Domain.Attoparsec.TypeString+where++import Domain.Prelude hiding (takeWhile)+import Domain.Models.TypeString+import Data.Attoparsec.Text hiding (sepBy1)+import Domain.Attoparsec.General+import Control.Applicative.Combinators.NonEmpty+++commaSeq =+  commaSeparated appSeq++appSeq =+  sepBy1 unit skipSpace1++unit =+  asum [+    InSquareBracketsUnit <$> inSquareBrackets appSeq+    ,+    InParensUnit <$> inParens commaSeq+    ,+    RefUnit <$> typeRef+    ]++typeRef =+  sepBy1 ucName (char '.')
+ library/Domain/Docs.hs view
@@ -0,0 +1,258 @@+module Domain.Docs+(+  -- * How it works+  {-|+  \"domain\" operates around Schema AST which describes the structure of your model.+  This AST gets constructed by either parsing a file or a quasi-quote+  conforming to a <#g:schemaSyntaxReference further described> format.+  Then it is used to generate Haskell type declarations and+  typeclass instances according to your configuration.+  All that is done at compile time, so you're incurring zero run time cost+  for using \"domain\".+  -}+  -- * Schema Syntax Reference #schemaSyntaxReference#+  {-|+  Schema definition is a YAML document listing declarations of your domain+  types. The listing is represented as a dictionary from type names to their+  definitions. There is 3 types of definitions: <#product Product>,+  <#sum Sum>, <#enum Enum>.+  -}+  -- ** Product #product#+  {-|+  Defines a type comprised of other types using+  <https://en.wikipedia.org/wiki/Product_type Product type composition>,+  associating a unique textual label with each member. You may know it as+  \"record\".++  Here\'s an example of a product type declaration in schema:++  > NetworkAddress:+  >   product:+  >     protocol: TransportProtocol+  >     host: Host+  >     port: Word16++  Depending on the settings you provide one of the following Haskell type+  declarations can be generated from it:++  > data NetworkAddress =+  >   NetworkAddress !TransportProtocol !Host !Word16++  > data NetworkAddress =+  >   NetworkAddress {+  >     networkAddressProtocol :: !TransportProtocol,+  >     networkAddressHost :: !Host,+  >     networkAddressPort :: !Word16+  >   }++  > data NetworkAddress =+  >   NetworkAddress {+  >     _protocol :: !TransportProtocol,+  >     _host :: !Host,+  >     _port :: !Word16+  >   }++  > data NetworkAddress =+  >   NetworkAddress {+  >     protocol :: !TransportProtocol,+  >     host :: !Host,+  >     port :: !Word16+  >   }+  -}+  -- *** Accessing fields #accessing-product-fields#+  {-|++  Regardless of the way you choose to generate the data declaration, neat+  mechanisms of accessing members can be provided using the automatically+  generated @IsLabel@ instances or instances of @LabelOptic@ (using the+  \"domain-optics\" package).++  E.g., here\'s how you can be accessing the members of the example+  data-type:++  > getNetworkAddressPort :: NetworkAddress -> Word16+  > getNetworkAddressPort = #port++  > mapNetworkAddressHost :: (Host -> Host) -> NetworkAddress -> NetworkAddress+  > mapNetworkAddressHost = over #host -- Using "domain-optics" and "optics"++  -}+  -- ** Sum #sum#+  {-|++  Defines a type comprised of other types using+  <https://en.wikipedia.org/wiki/Tagged_union Sum type composition>,+  associating a unique textual label with each member. You may know it as+  tagged union or variant.++  Here\'s an example of a schema declaration of a sum type:++  > Host:+  >   sum:+  >     ip: Ip+  >     name: Text++  The following Haskell code will be generated from it:++  > data Host =+  >   IpHost !Ip |+  >   NameHost !Text++  As you can see the constructor names are intentionally made to be+  unambiguous. You may already be thinking \"But the code is gonna get so+  verbose\". It\'s not. Thanks to the automatically generatable @IsLabel@+  and @LabelOptic@ instances.++  E.g., here\'s how you\'ll be able to access the variants of the+  data-type:++  > getHostIp :: Host -> Maybe Ip+  > getHostIp = #ip++  > ipHost :: Ip -> Host+  > ipHost = #ip++  > mapHostIp :: (Ip -> Ip) -> Host -> Host+  > mapHostIp = over #ip -- Using "domain-optics" and "optics"+  +  -}+  -- *** Multi-member sums #multi-member-sums#+  {-|++  It is possible to provide multiple members of a sum variant using a+  comma-separated list or YAML sequence. You can provide zero members as+  well. E.g.,++  > Error:+  >   sum:+  >     channel:+  >       - ChannelId+  >       - Text+  >     connectionLost:++  This will generate the following declaration:++  > data Error =+  >   ChannelError !ChannelId !Text |+  >   ConnectionLostError++  Depending on the number of variant members the generated accessors will+  point to tuples or booleans:++  > getErrorChannel :: Error -> Maybe (ChannelId, Text)+  > getErrorChannel = #channel+  >+  > getErrorConnectionLost :: Error -> Bool+  > getErrorConnectionLost = #connectionLost+  -}+  -- ** Enum #enum#+  {-|+  Type which can have one value out of a specific set of options.++  Here\'s an example of a schema declaration of an enum type:++  > TransportProtocol:+  >   enum:+  >     - tcp+  >     - udp++  This will generate the following Haskell data type:++  > data TransportProtocol =+  >   TcpTransportProtocol |+  >   UdpTransportProtocol++  The following 'IsLabel' helpers will be available for it:++  > tcpTransportProtocol :: TransportProtocol+  > tcpTransportProtocol = #tcp+  >+  > getTransportProtocolTcp :: TransportProtocol -> Bool+  > getTransportProtocolTcp = #tcp++  -}+  -- ** Notes #notes#+  -- *** List Data-type #list-data-type#+  {-|+  Since square brackets get interpreted in YAML as array literal, you have to+  explicitly state that the value is a string literal. To achieve that prefix+  the value with the vertical line character (@|@). E.g.,++  > Artist:+  >   product:+  >     name: Text+  >     genres: | [Genre]+  -}+  -- *** Reserved Names+  {-|+  You can use the otherwise banned field names like \"data\", \"type\",+  \"class\".+  -}+  -- *** Newtypes+  {-|+  Single-field products get represented as newtypes,+  so use them whenever you need to generate a newtype declaration.+  -}+  -- *** Type Aliases+  {-|+  Schemas intentionally lack support for type aliases,+  since they haven't yet proven to be very useful in practice.++  However we\'re open for discussion on the subject.+  So do provide your arguments on the project\'s issue tracker+  if you feel like they should be added as a feature.+  -}+  -- *** Polymorphic Types+  {-|+  Polymorphic types are not supported.+  Domain model is expected to consist of specific data structures,+  not abstractions.+  -}+  -- * Instance Derivation+  {-|+  Instance derivation is intentionally isolated from the schema definition+  to let both tasks be focused.+  Instances get derived for all the types in your schema that they are suitable for.+  We treat schema as a group entity over multiple types+  having them share settings including the instance generation rules.++  Whenever you find yourself in a situation where you need different instances+  for parts of your model it should serve as a signal that you\'re likely+  dealing with multiple models merged into one.+  The solution to such situation is to extract smaller models.+  When dealing with Domain Schema that is what will also let you+  generate different instances.+  -}+  -- ** Custom Derivers+  {-|+  The \"domain\" package does not expose any means to create custom derivers,+  since its API focuses on their usage as part of the problems of+  the general audience.+  To create custom derivers you\'ll have to use the+  ["domain-core"](http://hackage.haskell.org/package/domain-core) package,+  which exposes the internal definition of the 'DomainCore.Deriver.Deriver' abstraction and+  everything you need to define custom derivers.++  Such isolation of libraries lets us have a stable API for the general audience,+  serving for better backward compatibility, and keep it isolated from+  the distractions of lower level details.+  -}+  -- ** Deriver Extensions+  {-|+  We expect the community to publish their general custom derivers as extensional+  packages.++  So far there is one package known (which we\'ve published ourselves):++  - ["domain-optics"](http://hackage.haskell.org/package/domain-optics) - provides+    integration with the ["optics"](http://hackage.haskell.org/package/optics) package.++  If you\'re looking to contribute,+  some likely needed candidates for extensions are \"QuickCheck\", \"aeson\", \"binary\",+  \"cereal\".+  -}+)+where++import Domain.Prelude hiding (liftEither, readFile, lift)+import Domain
+ library/Domain/Models/TypeCentricDoc.hs view
@@ -0,0 +1,20 @@+module Domain.Models.TypeCentricDoc+where++import Domain.Prelude hiding (Product, Sum, Enum)+import qualified Domain.Models.TypeString as TypeString+++type Doc =+  [(Text, Structure)]++data Structure =+  ProductStructure [(Text, TypeString.AppSeq)] |+  SumStructure [(Text, SumTypeExpression)] |+  EnumStructure [Text]+  deriving (Show)++data SumTypeExpression =+  SequenceSumTypeExpression [TypeString.AppSeq] |+  StringSumTypeExpression TypeString.CommaSeq+  deriving (Show)
+ library/Domain/Models/TypeString.hs view
@@ -0,0 +1,17 @@+module Domain.Models.TypeString+where++import Domain.Prelude+++type CommaSeq =+  [AppSeq]++type AppSeq =+  NonEmpty Unit++data Unit =+  InSquareBracketsUnit AppSeq |+  InParensUnit CommaSeq |+  RefUnit (NonEmpty Text)+  deriving (Show)
+ library/Domain/Prelude.hs view
@@ -0,0 +1,97 @@+module Domain.Prelude+( +  module Exports,+  showAsText,+)+where++-- base+-------------------------+import Control.Applicative as Exports hiding (WrappedArrow(..))+import Control.Arrow as Exports hiding (first, second)+import Control.Category as Exports+import Control.Concurrent as Exports+import Control.Exception as Exports+import Control.Monad as Exports hiding (fail, mapM_, sequence_, forM_, msum, mapM, sequence, forM)+import Control.Monad.IO.Class as Exports+import Control.Monad.Fail as Exports+import Control.Monad.Fix as Exports hiding (fix)+import Control.Monad.ST as Exports+import Data.Bifunctor as Exports+import Data.Bits as Exports+import Data.Bool as Exports+import Data.Char as Exports+import Data.Coerce as Exports+import Data.Complex as Exports+import Data.Data as Exports+import Data.Dynamic as Exports+import Data.Either as Exports+import Data.Fixed as Exports+import Data.Foldable as Exports hiding (toList)+import Data.Function as Exports hiding (id, (.))+import Data.Functor as Exports+import Data.Functor.Compose as Exports+import Data.Functor.Contravariant as Exports+import Data.Int as Exports+import Data.IORef as Exports+import Data.Ix as Exports+import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl')+import Data.List.NonEmpty as Exports (NonEmpty(..))+import Data.Maybe as Exports+import Data.Monoid as Exports hiding (Alt)+import Data.Ord as Exports+import Data.Proxy as Exports+import Data.Ratio as Exports+import Data.STRef as Exports+import Data.String as Exports+import Data.Traversable as Exports+import Data.Tuple as Exports+import Data.Unique as Exports+import Data.Version as Exports+import Data.Void as Exports+import Data.Word as Exports+import Debug.Trace as Exports+import Foreign.ForeignPtr as Exports+import Foreign.Ptr as Exports+import Foreign.StablePtr as Exports+import Foreign.Storable as Exports+import GHC.Conc as Exports hiding (orElse, withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead)+import GHC.Exts as Exports (IsList(..), lazy, inline, sortWith, groupWith)+import GHC.Generics as Exports (Generic)+import GHC.IO.Exception as Exports+import GHC.OverloadedLabels as Exports+import GHC.Records as Exports+import Numeric as Exports+import Prelude as Exports hiding (fail, concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.))+import System.Environment as Exports+import System.Exit as Exports+import System.IO as Exports (Handle, hClose)+import System.IO.Error as Exports+import System.IO.Unsafe as Exports+import System.Mem as Exports+import System.Mem.StableName as Exports+import System.Timeout as Exports+import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P)+import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec)+import Text.Printf as Exports (printf, hPrintf)+import Text.Read as Exports (Read(..), readMaybe, readEither)+import Unsafe.Coerce as Exports++-- text+-------------------------+import Data.Text as Exports (Text)++-- bytestring+-------------------------+import Data.ByteString as Exports (ByteString)++-- hashable+-------------------------+import Data.Hashable as Exports (Hashable)++-- template-haskell+-------------------------+import Language.Haskell.TH.Syntax as Exports (Lift)++showAsText :: Show a => a -> Text+showAsText = show >>> fromString
+ library/Domain/Resolvers/TypeCentricDoc.hs view
@@ -0,0 +1,65 @@+module Domain.Resolvers.TypeCentricDoc+where++import Domain.Prelude hiding (lookup)+import DomainCore.Model+import qualified Domain.Models.TypeCentricDoc as Doc+import qualified Domain.Models.TypeString as TypeString+import qualified Data.Text as Text+++eliminateDoc =+  traverse eliminateNameAndStructure++eliminateNameAndStructure (name, structure) =+  TypeDec name <$> eliminateStructure structure++eliminateStructure =+  \ case+    Doc.ProductStructure structure ->+      ProductTypeDef <$>+      traverse eliminateProductStructureUnit structure+    Doc.SumStructure structure ->+      SumTypeDef <$>+      traverse eliminateSumStructureUnit structure+    Doc.EnumStructure variants ->+      pure (SumTypeDef (fmap (,[]) variants))++eliminateProductStructureUnit (name, appSeq) =+  (,) name . AppType <$> eliminateTypeStringAppSeq appSeq++eliminateSumStructureUnit (name, sumTypeExpression) =+  (,) name <$> eliminateSumTypeExpression sumTypeExpression++eliminateSumTypeExpression =+  \ case+    Doc.SequenceSumTypeExpression a ->+      traverse (fmap AppType . eliminateTypeStringAppSeq) a+    Doc.StringSumTypeExpression a ->+      traverse (fmap AppType . eliminateTypeStringAppSeq) a++eliminateTypeStringCommaSeq =+  traverse eliminateTypeStringAppSeq++eliminateTypeStringAppSeq =+  traverse eliminateTypeStringUnit++eliminateTypeStringUnit =+  \ case+    TypeString.InSquareBracketsUnit appSeq ->+      eliminateTypeStringAppSeq appSeq &+        fmap (ListType . AppType)+    TypeString.InParensUnit commaSeq ->+      eliminateTypeStringCommaSeq commaSeq &+        fmap (tupleIfNotOne . fmap AppType)+      where+        tupleIfNotOne =+          \ case+            [a] -> a+            a -> TupleType a+    TypeString.RefUnit typeRef ->+      eliminateTypeRef typeRef &+        fmap RefType++eliminateTypeRef =+  pure . Text.intercalate "." . toList
+ library/Domain/TH/InstanceDec.hs view
@@ -0,0 +1,233 @@+{-|+Model-adapted instance declaration templates.+-}+module Domain.TH.InstanceDec+where++import Domain.Prelude+import DomainCore.Model+import qualified Language.Haskell.TH as TH+import qualified DomainCore.TH as CoreTH+import qualified Data.Text as Text+import qualified THLego.Instances as Instances+import qualified THLego.Helpers as Helpers+++-- * HasField+-------------------------++enumHasField :: Text -> Text -> TH.Dec+enumHasField typeName label =+  Instances.enumHasField fieldLabel ownerType constructorName+  where+    fieldLabel =+      Helpers.textTyLit label+    ownerType =+      TH.ConT (Helpers.textName typeName)+    constructorName =+      CoreTH.sumConstructorName typeName label++sumHasField :: Text -> Text -> [Type] -> TH.Dec+sumHasField typeName label memberTypes =+  if null memberTypes+    then +      Instances.enumHasField thFieldLabel thOwnerType thConstructorName+    else+      Instances.sumHasField thFieldLabel thOwnerType thConstructorName thMemberTypes+  where+    thFieldLabel =+      Helpers.textTyLit label+    thOwnerType =+      TH.ConT (Helpers.textName typeName)+    thConstructorName =+      CoreTH.sumConstructorName typeName label+    thMemberTypes =+      fmap CoreTH.typeType memberTypes++productHasField :: Text -> Text -> Type -> Int -> Int -> TH.Dec+productHasField typeName fieldName projectionType numMemberTypes offset =+  Instances.productHasField thFieldLabel thOwnerType thProjectionType+    thConstructorName numMemberTypes offset+  where+    thFieldLabel =+      Helpers.textTyLit fieldName+    thOwnerType =+      TH.ConT (Helpers.textName typeName)+    thProjectionType =+      CoreTH.typeType projectionType+    thConstructorName =+      Helpers.textName typeName+++-- * IsLabel+-------------------------++-- ** Accessor+-------------------------++productAccessorIsLabel :: Text -> Text -> Type -> Int -> Int -> TH.Dec+productAccessorIsLabel typeName fieldName projectionType numMemberTypes offset =+  Instances.productAccessorIsLabel+    thFieldLabel thOwnerType thProjectionType thConstructorName+    numMemberTypes offset+  where+    thFieldLabel =+      Helpers.textTyLit fieldName+    thOwnerType =+      TH.ConT (Helpers.textName typeName)+    thProjectionType =+      CoreTH.typeType projectionType+    thConstructorName =+      Helpers.textName typeName++sumAccessorIsLabel :: Text -> Text -> [Type] -> TH.Dec+sumAccessorIsLabel typeName label memberTypes =+  if null memberTypes+    then+      Instances.enumAccessorIsLabel+        thFieldLabel thOwnerType thConstructorName+    else+      Instances.sumAccessorIsLabel+        thFieldLabel thOwnerType thConstructorName thMemberTypes+  where+    thFieldLabel =+      Helpers.textTyLit label+    thOwnerType =+      TH.ConT (Helpers.textName typeName)+    thConstructorName =+      CoreTH.sumConstructorName typeName label+    thMemberTypes =+      fmap CoreTH.typeType memberTypes++enumAccessorIsLabel :: Text -> Text -> TH.Dec+enumAccessorIsLabel typeName label =+  Instances.enumAccessorIsLabel+    thFieldLabel thOwnerType thConstructorName+  where+    thFieldLabel =+      Helpers.textTyLit label+    thOwnerType =+      TH.ConT (Helpers.textName typeName)+    thConstructorName =+      CoreTH.sumConstructorName typeName label++-- ** Constructor+-------------------------++curriedSumConstructorIsLabel :: Text -> Text -> [Type] -> TH.Dec+curriedSumConstructorIsLabel typeName label memberTypes =+  Instances.sumConstructorIsLabel+    thFieldLabel thOwnerType thConstructorName thMemberTypes+  where+    thFieldLabel =+      Helpers.textTyLit label+    thOwnerType =+      TH.ConT (Helpers.textName typeName)+    thConstructorName =+      CoreTH.sumConstructorName typeName label+    thMemberTypes =+      fmap CoreTH.typeType memberTypes++uncurriedSumConstructorIsLabel :: Text -> Text -> [Type] -> TH.Dec+uncurriedSumConstructorIsLabel typeName label memberTypes =+  Instances.tupleAdtConstructorIsLabel+    thFieldLabel thOwnerType thConstructorName thMemberTypes+  where+    thFieldLabel =+      Helpers.textTyLit label+    thOwnerType =+      TH.ConT (Helpers.textName typeName)+    thConstructorName =+      CoreTH.sumConstructorName typeName label+    thMemberTypes =+      fmap CoreTH.typeType memberTypes++enumConstructorIsLabel :: Text -> Text -> TH.Dec+enumConstructorIsLabel typeName label =+  Instances.enumConstructorIsLabel+    thFieldLabel thOwnerType thConstructorName+  where+    thFieldLabel =+      Helpers.textTyLit label+    thOwnerType =+      TH.ConT (Helpers.textName typeName)+    thConstructorName =+      CoreTH.sumConstructorName typeName label++wrapperConstructorIsLabel :: Text -> Type -> TH.Dec+wrapperConstructorIsLabel typeName memberType =+  Instances.newtypeConstructorIsLabel+    thFieldLabel thOwnerType thConstructorName thMemberType+  where+    thFieldLabel =+      TH.StrTyLit "value"+    thOwnerType =+      TH.ConT (Helpers.textName typeName)+    thConstructorName =+      Helpers.textName typeName+    thMemberType =+      CoreTH.typeType memberType++-- ** Mapper+-------------------------++wrapperMapperIsLabel :: Text -> Type -> TH.Dec+wrapperMapperIsLabel typeName memberType =+  Instances.productMapperIsLabel+    thFieldLabel thOwnerType thMemberType thConstructorName 1 0+  where+    thFieldLabel =+      TH.StrTyLit "value"+    thOwnerType =+      TH.ConT (Helpers.textName typeName)+    thConstructorName =+      Helpers.textName typeName+    thMemberType =+      CoreTH.typeType memberType++productMapperIsLabel :: Text -> Text -> Type -> Int -> Int -> TH.Dec+productMapperIsLabel typeName fieldName projectionType numMemberTypes offset =+  Instances.productMapperIsLabel+    thFieldLabel thOwnerType thProjectionType thConstructorName+    numMemberTypes offset+  where+    thFieldLabel =+      Helpers.textTyLit fieldName+    thOwnerType =+      TH.ConT (Helpers.textName typeName)+    thProjectionType =+      CoreTH.typeType projectionType+    thConstructorName =+      Helpers.textName typeName++sumMapperIsLabel :: Text -> Text -> [Type] -> TH.Dec+sumMapperIsLabel typeName label memberTypes =+  Instances.sumMapperIsLabel+    thFieldLabel thOwnerType thConstructorName thMemberTypes+  where+    thFieldLabel =+      Helpers.textTyLit label+    thOwnerType =+      TH.ConT (Helpers.textName typeName)+    thConstructorName =+      CoreTH.sumConstructorName typeName label+    thMemberTypes =+      fmap CoreTH.typeType memberTypes+++-- *+-------------------------++deriving_ :: TH.Name -> Text -> TH.Dec+deriving_ className typeNameText =+  TH.StandaloneDerivD Nothing [] headType+  where+    headType =+      TH.AppT (TH.ConT className) (TH.ConT (Helpers.textName typeNameText))++empty :: TH.Name -> Text -> TH.Dec+empty className typeNameText =+  TH.InstanceD Nothing [] headType []+  where+    headType =+      TH.AppT (TH.ConT className) (TH.ConT (Helpers.textName typeNameText))
+ library/Domain/TH/InstanceDecs.hs view
@@ -0,0 +1,128 @@+module Domain.TH.InstanceDecs+where++import Domain.Prelude+import DomainCore.Model+import qualified Domain.TH.InstanceDec as InstanceDec+import qualified Language.Haskell.TH as TH (Dec, Name)+++hasField :: TypeDec -> [TH.Dec]+hasField (TypeDec typeName typeDef) =+  case typeDef of+    ProductTypeDef members ->+      zipWith zipper (enumFrom 0) members+      where+        numMembers =+          length members+        zipper offset (fieldName, fieldType) =+          InstanceDec.productHasField typeName fieldName fieldType numMembers offset+    SumTypeDef variants ->+      fmap mapper variants+      where+        mapper (variantName, memberTypes) =+          InstanceDec.sumHasField typeName variantName memberTypes++accessorIsLabel :: TypeDec -> [TH.Dec]+accessorIsLabel (TypeDec typeName typeDef) =+  case typeDef of+    ProductTypeDef members ->+      zipWith zipper (enumFrom 0) members+      where+        numMembers =+          length members+        zipper offset (fieldName, fieldType) =+          InstanceDec.productAccessorIsLabel typeName fieldName fieldType numMembers offset+    SumTypeDef variants ->+      variants &+      fmap (\ (variantName, memberTypes) ->+        InstanceDec.sumAccessorIsLabel typeName variantName memberTypes+        )++constructorIsLabel :: TypeDec -> [TH.Dec]+constructorIsLabel (TypeDec typeName typeDef) =+  case typeDef of+    ProductTypeDef members ->+      []+    SumTypeDef variants ->+      variants &+      fmap (\ (variantName, memberTypes) ->+        InstanceDec.curriedSumConstructorIsLabel typeName variantName memberTypes)++variantConstructorIsLabel :: Text -> (Text, [Type]) -> [TH.Dec]+variantConstructorIsLabel typeName (variantName, memberTypes) =+  let+    curried =+      InstanceDec.curriedSumConstructorIsLabel typeName variantName memberTypes+    uncurried =+      InstanceDec.uncurriedSumConstructorIsLabel typeName variantName memberTypes+    in case memberTypes of+      [] ->+        [curried]+      [_] ->+        [curried]+      _ ->+        [curried, uncurried]++mapperIsLabel :: TypeDec -> [TH.Dec]+mapperIsLabel (TypeDec typeName typeDef) =+  case typeDef of+    ProductTypeDef members ->+      zipWith zipper (enumFrom 0) members+      where+        numMembers =+          length members+        zipper offset (fieldName, fieldType) =+          InstanceDec.productMapperIsLabel typeName fieldName fieldType numMembers offset+    SumTypeDef variants ->+      do+        (variantName, memberTypes) <- variants+        if null memberTypes+          then empty+          else pure (InstanceDec.sumMapperIsLabel typeName variantName memberTypes)+++-- * Deriving+-------------------------++byNonAliasName :: (Text -> TH.Dec) -> TypeDec -> [TH.Dec]+byNonAliasName cont (TypeDec a b) =+  [cont a]++byEnumName :: (Text -> TH.Dec) -> TypeDec -> [TH.Dec]+byEnumName cont (TypeDec name def) =+  case def of+    SumTypeDef variants | all (null . snd) variants ->+      [cont name]+    _ ->+      []++enum =+  byEnumName (InstanceDec.deriving_ ''Enum)++bounded =+  byEnumName (InstanceDec.deriving_ ''Bounded)++show =+  byNonAliasName (InstanceDec.deriving_ ''Show)++eq =+  byNonAliasName (InstanceDec.deriving_ ''Eq)++ord =+  byNonAliasName (InstanceDec.deriving_ ''Ord)++generic =+  byNonAliasName (InstanceDec.deriving_ ''Generic)++data_ =+  byNonAliasName (InstanceDec.deriving_ ''Data)++typeable =+  byNonAliasName (InstanceDec.deriving_ ''Typeable)++hashable =+  byNonAliasName (InstanceDec.empty ''Hashable)++lift =+  byNonAliasName (InstanceDec.deriving_ ''Lift)
+ library/Domain/TH/TypeDec.hs view
@@ -0,0 +1,28 @@+module Domain.TH.TypeDec+where++import Domain.Prelude+import DomainCore.Model+import qualified Language.Haskell.TH as TH+import qualified THLego.Helpers as TH+import qualified DomainCore.TH as CoreTH+++typeDec fieldNaming (TypeDec a b) =+  case b of+    SumTypeDef b ->+      TH.sumAdtDec (TH.textName a) (fmap (bimap (CoreTH.sumConstructorName a) (fmap CoreTH.typeType)) b)+    ProductTypeDef fields ->+      case fieldNaming of+        Just (underscore, prefixWithTypeName) ->+          case fields of+            [(memberName, memberType)] ->+              TH.recordNewtypeDec (TH.textName a) (CoreTH.recordFieldName underscore prefixWithTypeName a memberName) (CoreTH.typeType memberType)+            _ ->+              TH.recordAdtDec (TH.textName a) (fmap (bimap (CoreTH.recordFieldName underscore prefixWithTypeName a) CoreTH.typeType) fields)+        Nothing ->+          case fields of+            [(_, memberType)] ->+              TH.normalNewtypeDec (TH.textName a) (CoreTH.typeType memberType)+            _ ->+              TH.productAdtDec (TH.textName a) (fmap (CoreTH.typeType . snd) fields)
+ library/Domain/YamlUnscrambler/TypeCentricDoc.hs view
@@ -0,0 +1,78 @@+module Domain.YamlUnscrambler.TypeCentricDoc+where++import Domain.Prelude+import Domain.Models.TypeCentricDoc+import YamlUnscrambler+import qualified Domain.Attoparsec.TypeString as TypeStringAttoparsec+import qualified Domain.Attoparsec.General as GeneralAttoparsec+import qualified Control.Foldl as Fold+import qualified Data.Text as Text+++doc =+  value onScalar (Just onMapping) Nothing+  where+    onScalar =+      [nullScalar []]+    onMapping =+      foldMapping (,) Fold.list typeNameString structure+      where+        typeNameString =+          formattedString "type name" $ \ input ->+            case Text.uncons input of+              Just (h, t) ->+                if isUpper h+                  then+                    if Text.all (\ a -> isAlphaNum a || a == '\'' || a == '_') t+                      then+                        Right input+                      else+                        Left "Contains invalid chars"+                  else+                    Left "First char is not upper-case"+              Nothing ->+                Left "Empty string"++structure =+  value [] (Just onMapping) Nothing+  where+    onMapping =+      byKeyMapping (CaseSensitive True) $+        atByKey "product" (ProductStructure <$> byFieldName appTypeString) <|>+        atByKey "sum" (SumStructure <$> byFieldName sumTypeExpression) <|>+        atByKey "enum" (EnumStructure <$> enumVariants)++byFieldName onElement =+  value onScalar (Just onMapping) Nothing+  where+    onScalar =+      [nullScalar []]+    onMapping =+      foldMapping (,) Fold.list textString onElement++appTypeString =+  value [+    stringScalar $ attoparsedString "Type signature" $+    GeneralAttoparsec.only TypeStringAttoparsec.appSeq+    ] Nothing Nothing++sumTypeExpression =+  value onScalar Nothing (Just onSequence)+  where+    onScalar =+      [+        nullScalar (SequenceSumTypeExpression [])+        ,+        fmap StringSumTypeExpression $+        stringScalar $ attoparsedString "Type signature" $+        GeneralAttoparsec.only TypeStringAttoparsec.commaSeq+        ]+    onSequence =+      SequenceSumTypeExpression <$> foldSequence Fold.list appTypeString++enumVariants =+  sequenceValue (foldSequence Fold.list variant)+  where+    variant =+      scalarsValue [stringScalar textString]
+ loading-demo/Main.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE+  TemplateHaskell,+  StandaloneDeriving, DeriveGeneric, DeriveDataTypeable, DeriveLift,+  FlexibleInstances, MultiParamTypeClasses,+  DataKinds, TypeFamilies+  #-}+module Main where++import Data.Text (Text)+import Data.Word (Word16, Word32, Word64)+import Domain+++main =+  return ()++declare (Just (True, False)) stdDeriver+  =<< loadSchema "samples/1.yaml"
+ samples/1.yaml view
@@ -0,0 +1,51 @@+# Service can be either located on the network or+# by a socket file.+#+# Choice between two or more types can be encoded using+# "sum" type composition, which you may also know as+# "union" or "variant". That's what we use here.+ServiceAddress:+  sum:+    network: NetworkAddress+    local: FilePath++# Network address is a combination of transport protocol,+# host and port. All those three things at once.+#+# "product" type composition lets us encode that.+# You may also know it as "record" or "tuple".+NetworkAddress:+  product:+    protocol: TransportProtocol+    host: Host+    port: Word16++# Transport protocol is either TCP or UDP.+# We encode that using enumeration.+TransportProtocol:+  enum:+    - tcp+    - udp++# Host can be adressed by either an IP or its name,+# so "sum" again.+Host:+  sum:+    ip: Ip+    name: Text++# IP can be either of version 4 or version 6.+# We encode it as a sum over words of the accordingly required+# amount of bits.+Ip:+  sum:+    v4: Word32+    v6: Word128++# Since the standard lib lacks a definition+# of a 128-bit word, we define a custom one+# as a product of two 64-bit words.+Word128:+  product:+    part1: Word64+    part2: Word64
+ test/Main.hs view
@@ -0,0 +1,54 @@+module Main where++import Prelude hiding (assert)+import Language.Haskell.TH.Instances ()+import Test.QuickCheck.Instances+import Test.Tasty+import Test.Tasty.Runners+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck+import qualified Domain+import qualified DomainCore.Model as Model+import qualified Test.QuickCheck as QuickCheck+import qualified Data.Text as Text+import qualified Util.TH as TH+import qualified Util.TH.LeafTypes as THLeafTypes+import qualified Language.Haskell.TH.Syntax as TH+++main =+  defaultMain $ +  testGroup "All tests" [+    testCase "Should fail when wrong member of sum-type is supplied" $ let+      res :: Maybe [Model.TypeDec]+      res =+        [TH.maybeDecsQQ|+          A:+            sum:+              a:+                c: Int+              b: Char, Double+          |]+      in case res of+        Just res ->+          assertFailure (show res)+        Nothing ->+          return ()+    ,+    testCase "Nested structures shouldn't contain any unit-tuple types" $ let+      decs :: [TH.Dec]+      decs =+        $(TH.lift+            =<< Domain.declare Nothing mempty [Domain.schema|+                  A:+                    product:+                      a: Maybe (Maybe Int)+                  |])+      leafTypes =+        foldMap THLeafTypes.fromDec decs+      in case elemIndex (TH.TupleT 1) leafTypes of+        Just _ ->+          assertFailure (show decs)+        Nothing ->+          return ()+    ]
+ test/Util/TH.hs view
@@ -0,0 +1,37 @@+module Util.TH where++import Prelude+import Language.Haskell.TH.Syntax as TH+import Language.Haskell.TH.Quote as TH+import qualified Domain+import qualified DomainCore.Model as Model+++tryQuoteExp :: QuasiQuoter -> String -> Q Exp+tryQuoteExp q =+  recover (pure (ConE 'Nothing)) .+  fmap (AppE (ConE 'Just)) .+  quoteExp q++tryExpQ :: Q Exp -> Q Exp+tryExpQ =+  recover (pure (ConE 'Nothing)) .+  fmap (AppE (ConE 'Just))++mapQQExpQ :: (Q Exp -> Q Exp) -> QuasiQuoter -> QuasiQuoter+mapQQExpQ mapper (QuasiQuoter a b c d) =+  QuasiQuoter (mapper . a) b c d++maybeDecsQQ :: QuasiQuoter+maybeDecsQQ =+  mapQQExpQ (fmap mapper . tryExpQ) Domain.schema+  where+    mapper =+      AppE+        (AppE (VarE 'fmap) +          (SigE (VarE 'unsafeCoerce) sig))+      where+        sig =+          AppT+            (AppT ArrowT (ConT ''Domain.Schema))+            (AppT ListT (ConT ''Model.TypeDec))
+ test/Util/TH/LeafTypes.hs view
@@ -0,0 +1,53 @@+module Util.TH.LeafTypes where++import Prelude+import Language.Haskell.TH.Syntax+++fromDec =+  \ case+    NewtypeD a _ b c d _ ->+      fromCxt a <>+      concatMap fromTyVarBndr b <>+      foldMap fromType c <>+      fromCon d++fromTyVarBndr =+  \ case+    KindedTV _ a ->+      fromType a+    _ ->+      []++fromCxt =+  concatMap fromType++fromCon =+  \ case+    NormalC _ bangTypes -> concatMap fromBangType bangTypes++fromBangType (_, t) =+  fromType t++fromType =+  \ case+    ForallT a b c ->+      concatMap fromTyVarBndr a <> fromCxt b <> fromType c+    ForallVisT a b ->+      concatMap fromTyVarBndr a <> fromType b+    AppT l r ->+      fromType l <> fromType r+    AppKindT a _ ->+      fromType a+    SigT a _ ->+      fromType a+    InfixT a _ b ->+      fromType a <> fromType b+    UInfixT a _ b ->+      fromType a <> fromType b+    ParensT a ->+      fromType a+    ImplicitParamT _ a ->+      fromType a+    t ->+      [t]