packages feed

domain 0.1.1.4 → 0.1.1.5

raw patch · 19 files changed

+1176/−1034 lines, 19 filesdep −QuickCheckdep −quickcheck-instancesdep −tasty-quickcheckdep ~bytestringdep ~domain-coredep ~th-legoPVP ok

version bump matches the API change (PVP)

Dependencies removed: QuickCheck, quickcheck-instances, tasty-quickcheck

Dependency ranges changed: bytestring, domain-core, th-lego

API changes (from Hackage documentation)

Files

domain.cabal view
@@ -1,35 +1,78 @@-name: domain-version: 0.1.1.4-synopsis: Codegen helping you define domain models+cabal-version:      3.0+name:               domain+version:            0.1.1.5+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+  which exports the whole API of this package.++category:           IDL+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 extra-source-files:   README.md   samples/*.yaml  source-repository head-  type: git+  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+  hs-source-dirs:     library+  default-extensions:+    NoImplicitPrelude+    NoMonomorphismRestriction+    BangPatterns+    BlockArguments+    ConstraintKinds+    DataKinds+    DefaultSignatures+    DeriveDataTypeable+    DeriveFoldable+    DeriveFunctor+    DeriveGeneric+    DeriveLift+    DeriveTraversable+    EmptyDataDecls+    FlexibleContexts+    FlexibleInstances+    FunctionalDependencies+    GADTs+    GeneralizedNewtypeDeriving+    InstanceSigs+    LambdaCase+    LiberalTypeSynonyms+    MagicHash+    MultiParamTypeClasses+    MultiWayIf+    OverloadedLabels+    OverloadedStrings+    ParallelListComp+    PatternGuards+    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@@ -42,58 +85,97 @@     Domain.TH.InstanceDecs     Domain.TH.TypeDec     Domain.YamlUnscrambler.TypeCentricDoc+   build-depends:-    attoparsec >=0.13 && <0.15,-    base >=4.9 && <5,-    bytestring >=0.10 && <0.12,-    domain-core >=0.1 && <0.2,-    foldl >=1.4.9 && <2,-    hashable >=1 && <2,-    parser-combinators >=1.3 && <1.4,-    template-haskell >=2.13 && <3,-    template-haskell-compat-v0208 >=0.1.6 && <0.2,-    text >=1.2.3 && <3,-    th-lego >=0.2.3 && <0.4,-    yaml-unscrambler >=0.1 && <0.2+    , attoparsec >=0.13 && <0.15+    , base >=4.9 && <5+    , bytestring >=0.10 && <0.13+    , domain-core ^>=0.1.0.4+    , foldl >=1.4.9 && <2+    , hashable >=1 && <2+    , parser-combinators >=1.3 && <1.4+    , template-haskell >=2.13 && <3+    , text >=1.2.3 && <3+    , th-lego ^>=0.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+  type:             exitcode-stdio-1.0+  hs-source-dirs:   loading-demo+  main-is:          Main.hs   default-language: Haskell2010   build-depends:-    base,-    domain,-    text+    , base+    , domain+    , text  test-suite inline-demo-  type: exitcode-stdio-1.0-  hs-source-dirs: inline-demo-  main-is: Main.hs+  type:             exitcode-stdio-1.0+  hs-source-dirs:   inline-demo+  main-is:          Main.hs   default-language: Haskell2010   build-depends:-    base,-    domain,-    text+    , 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+  type:               exitcode-stdio-1.0+  hs-source-dirs:     test+  default-extensions:+    NoImplicitPrelude+    NoMonomorphismRestriction+    BangPatterns+    BlockArguments+    ConstraintKinds+    DataKinds+    DefaultSignatures+    DeriveDataTypeable+    DeriveFoldable+    DeriveFunctor+    DeriveGeneric+    DeriveLift+    DeriveTraversable+    EmptyDataDecls+    FlexibleContexts+    FlexibleInstances+    FunctionalDependencies+    GADTs+    GeneralizedNewtypeDeriving+    InstanceSigs+    LambdaCase+    LiberalTypeSynonyms+    MagicHash+    MultiParamTypeClasses+    MultiWayIf+    OverloadedLabels+    OverloadedStrings+    ParallelListComp+    PatternGuards+    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,-    template-haskell-compat-v0208 >=0.1.6 && <0.2,-    th-orphans >=0.13 && <0.14+    , domain+    , domain-core+    , rerebase >=1.10.0.1 && <2+    , tasty >=0.12 && <2+    , tasty-hunit >=0.9 && <0.11+    , template-haskell+    , template-haskell-compat-v0208 >=0.1.6 && <0.2+    , th-orphans >=0.13 && <0.14
inline-demo/Main.hs view
@@ -1,22 +1,32 @@-{-# LANGUAGE-  QuasiQuotes, TemplateHaskell,-  StandaloneDeriving, DeriveGeneric, DeriveDataTypeable, DeriveLift,-  FlexibleInstances, MultiParamTypeClasses,-  DataKinds, TypeFamilies,-  OverloadedStrings, OverloadedLabels, TypeApplications-  #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-type-equality-requires-operators #-}+ module Main where  import Data.Text (Text) import Data.Word (Word16, Word32, Word64) import Domain - main :: IO () main =   return () -declare (Just (False, True)) stdDeriver [schema|+declare+  (Just (False, True))+  stdDeriver+  [schema|    ServiceAddress:     sum:@@ -51,19 +61,17 @@    |] -{-|-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.--}+-- |+-- 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.--}+-- |+-- 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
@@ -1,175 +1,172 @@-{-|-This module contains the whole API of \"domain\".--Many functions come with collapsed example sections.-Do check them out for better understanding.--}+-- |+-- 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@.-)+  ( -- * 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 Domain.Prelude hiding (readFile) import qualified Domain.Resolvers.TypeCentricDoc as TypeCentricResolver-import qualified Domain.TH.TypeDec as TypeDec import qualified Domain.TH.InstanceDecs as InstanceDecs+import qualified Domain.TH.TypeDec as TypeDec import qualified Domain.YamlUnscrambler.TypeCentricDoc as TypeCentricYaml import qualified DomainCore.Deriver as Deriver import qualified DomainCore.Model as Model+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax import qualified YamlUnscrambler --{-|-Declare datatypes and typeclass instances-from a schema definition according to the provided settings.--Use this function in combination with the 'schema' quasi-quoter or-the 'loadSchema' function.-__For examples__ refer to their documentation.--Call it on the top-level (where you declare your module members).--}+-- |+-- Declare 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.-  -}+  -- |+  --  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.-  -}+  -- |+  --  Which instances to derive and how.   Deriver.Deriver ->-  {-|-  Schema definition.-  -}+  -- |+  --  Schema definition.   Schema ->-  {-|-  Template Haskell action splicing the generated code on declaration level.-  -}+  -- |+  --  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]+-- |+-- 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--    |]-@---}+-- |+-- 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@@ -185,46 +182,43 @@     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"-@--}+-- |+-- 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.-  -}+  -- |+  --  Path to the schema file relative to the root of the project.   FilePath ->-  {-|-  Template Haskell action producing a valid schema.-  -}+  -- |+  --  Template Haskell action producing a valid schema.   Q Schema loadSchema path =   readFile path >>= parseByteString - -- * Helpers+ -------------------------  readFile :: FilePath -> Q ByteString@@ -251,349 +245,350 @@  liftEither :: Either Text a -> Q a liftEither =-  \ case+  \case     Left err -> fail (toList err)-    Right a -> return a -+    Right a -> return a  -- * Deriver+ ------------------------- -{-|-Combination of all derivers exported by this module.--}+-- |+-- Combination of all derivers exported by this module.+stdDeriver :: Deriver.Deriver stdDeriver =-  mconcat [-    enumDeriver,-    boundedDeriver,-    showDeriver,-    eqDeriver,-    ordDeriver,-    genericDeriver,-    dataDeriver,-    typeableDeriver,-    hashableDeriver,-    liftDeriver,-    hasFieldDeriver,-    constructorIsLabelDeriver,-    mapperIsLabelDeriver,-    accessorIsLabelDeriver+  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.--}+-- |+-- Derives 'Enum' for enums or sums having no members in all variants.+--+-- Requires to have the @StandaloneDeriving@ compiler extension enabled.+enumDeriver :: Deriver.Deriver enumDeriver =   Deriver.effectless InstanceDecs.enum -{-|-Derives 'Bounded' for enums.--Requires to have the @StandaloneDeriving@ compiler extension enabled.--}+-- |+-- Derives 'Bounded' for enums.+--+-- Requires to have the @StandaloneDeriving@ compiler extension enabled.+boundedDeriver :: Deriver.Deriver boundedDeriver =   Deriver.effectless InstanceDecs.bounded -{-|-Derives 'Show'.--Requires to have the @StandaloneDeriving@ compiler extension enabled.--}+-- |+-- Derives 'Show'.+--+-- Requires to have the @StandaloneDeriving@ compiler extension enabled.+showDeriver :: Deriver.Deriver showDeriver =   Deriver.effectless InstanceDecs.show -{-|-Derives 'Eq'.--Requires to have the @StandaloneDeriving@ compiler extension enabled.--}+-- |+-- Derives 'Eq'.+--+-- Requires to have the @StandaloneDeriving@ compiler extension enabled.+eqDeriver :: Deriver.Deriver eqDeriver =   Deriver.effectless InstanceDecs.eq -{-|-Derives 'Ord'.--Requires to have the @StandaloneDeriving@ compiler extension enabled.--}+-- |+-- Derives 'Ord'.+--+-- Requires to have the @StandaloneDeriving@ compiler extension enabled.+ordDeriver :: Deriver.Deriver ordDeriver =   Deriver.effectless InstanceDecs.ord -{-|-Derives 'Generic'.--Requires to have the @StandaloneDeriving@ and @DeriveGeneric@ compiler extensions enabled.--}+-- |+-- Derives 'Generic'.+--+-- Requires to have the @StandaloneDeriving@ and @DeriveGeneric@ compiler extensions enabled.+genericDeriver :: Deriver.Deriver genericDeriver =   Deriver.effectless InstanceDecs.generic -{-|-Derives 'Data'.--Requires to have the @StandaloneDeriving@ and @DeriveDataTypeable@ compiler extensions enabled.--}+-- |+-- Derives 'Data'.+--+-- Requires to have the @StandaloneDeriving@ and @DeriveDataTypeable@ compiler extensions enabled.+dataDeriver :: Deriver.Deriver dataDeriver =   Deriver.effectless InstanceDecs.data_ -{-|-Derives 'Typeable'.--Requires to have the @StandaloneDeriving@ and @DeriveDataTypeable@ compiler extensions enabled.--}+-- |+-- Derives 'Typeable'.+--+-- Requires to have the @StandaloneDeriving@ and @DeriveDataTypeable@ compiler extensions enabled.+typeableDeriver :: Deriver.Deriver typeableDeriver =   Deriver.effectless InstanceDecs.typeable -{-|-Generates 'Generic'-based instances of 'Hashable'.--}+-- |+-- Generates 'Generic'-based instances of 'Hashable'.+hashableDeriver :: Deriver.Deriver hashableDeriver =   Deriver.effectless InstanceDecs.hashable -{-|-Derives 'Lift'.--Requires to have the @StandaloneDeriving@ and @DeriveLift@ compiler extensions enabled.--}+-- |+-- Derives 'Lift'.+--+-- Requires to have the @StandaloneDeriving@ and @DeriveLift@ compiler extensions enabled.+liftDeriver :: Deriver.Deriver 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./--}+-- |+-- Derives 'HasField' with unprefixed field names.+--+-- For each field of a product generates instances mapping to their values.+--+-- For each constructor of a sum maps to a 'Maybe' tuple of members of that constructor,+-- unless there\'s no members, in which case it maps to 'Bool'.+--+-- For each variant of an enum maps to 'Bool' signaling whether the value equals to it.+--+-- /Please notice that if you choose to generate unprefixed record field accessors, it will conflict with this deriver, since it\'s gonna generate duplicate instances./+hasFieldDeriver :: Deriver.Deriver hasFieldDeriver =   Deriver.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-@--}+-- |+-- Generates instances of 'IsLabel' for wrappers, enums and sums,+-- providing mappings from labels to constructors.+--+-- ==== __Sum Example__+--+-- Having the following schema:+--+-- @+-- Host:+--   sum:+--     ip: Ip+--     name: Text+-- @+--+-- The following instances will be generated:+--+-- @+-- instance a ~ Ip => IsLabel "ip" (a -> Host) where+--   fromLabel = IpHost+--+-- instance a ~ Text => IsLabel "name" (a -> Host) where+--   fromLabel = NameHost+-- @+--+-- In case you\'re wondering what this tilde (@~@) constraint business is about,+-- refer to the [Type Equality Constraint](#type-equality-constraint) section.+--+-- ==== __Enum Example__+--+-- Having the following schema:+--+-- @+-- TransportProtocol:+--   enum:+--     - tcp+--     - udp+-- @+--+-- The following instances will be generated:+--+-- @+-- instance IsLabel "tcp" TransportProtocol where+--   fromLabel = TcpTransportProtocol+--+-- instance IsLabel "udp" TransportProtocol where+--   fromLabel = UdpTransportProtocol+-- @+constructorIsLabelDeriver :: Deriver.Deriver constructorIsLabelDeriver =   Deriver.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.--}+-- |+-- Generates instances of 'IsLabel' for enums, sums and products,+-- providing accessors to their components.+--+-- ==== __Product Example__+--+-- Having the following schema:+--+-- @+-- NetworkAddress:+--   product:+--     protocol: TransportProtocol+--     host: Host+--     port: Word16+-- @+--+-- The following instances will be generated:+--+-- @+-- instance a ~ TransportProtocol => IsLabel "protocol" (NetworkAddress -> a) where+--   fromLabel (NetworkAddress a _ _) = a+--+-- instance a ~ Host => IsLabel "host" (NetworkAddress -> a) where+--   fromLabel (NetworkAddress _ b _) = b+--+-- instance a ~ Word16 => IsLabel "port" (NetworkAddress -> a) where+--   fromLabel (NetworkAddress _ _ c) = c+-- @+--+-- In case you\'re wondering what this tilde (@~@) constraint business is about,+-- refer to the [Type Equality Constraint](#type-equality-constraint) section.+--+-- ==== __Sum Example__+--+-- Having the following schema:+--+-- @+-- Host:+--   sum:+--     ip: Ip+--     name: Text+-- @+--+-- The following instances will be generated:+--+-- @+-- instance a ~ Maybe Ip => IsLabel "ip" (Host -> a) where+--   fromLabel (IpHost a) = Just a+--   fromLabel _ = Nothing+--+-- instance a ~ Maybe Text => IsLabel "name" (Host -> a) where+--   fromLabel (NameHost a) = Just a+--   fromLabel _ = Nothing+-- @+--+-- In case you\'re wondering what this tilde (@~@) constraint business is about,+-- refer to the [Type Equality Constraint](#type-equality-constraint) section.+--+-- ==== __Enum Example__+--+-- Having the following schema:+--+-- @+-- TransportProtocol:+--   enum:+--     - tcp+--     - udp+-- @+--+-- The following instances will be generated:+--+-- @+-- instance a ~ Bool => IsLabel "tcp" (TransportProtocol -> a) where+--   fromLabel TcpTransportProtocol = True+--   fromLabel _ = False+--+-- instance a ~ Bool => IsLabel "udp" (TransportProtocol -> a) where+--   fromLabel UdpTransportProtocol = True+--   fromLabel _ = False+-- @+--+-- In case you\'re wondering what this tilde (@~@) constraint business is about,+-- refer to the [Type Equality Constraint](#type-equality-constraint) section.+accessorIsLabelDeriver :: Deriver.Deriver accessorIsLabelDeriver =   Deriver.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.--}+-- |+-- Generates instances of 'IsLabel' for sums and products,+-- providing mappers over their components.+--+-- ==== __Product Example__+--+-- Having the following schema:+--+-- @+-- NetworkAddress:+--   product:+--     protocol: TransportProtocol+--     host: Host+--     port: Word16+-- @+--+-- The following instances will be generated:+--+-- @+-- instance+--   mapper ~ (TransportProtocol -> TransportProtocol) =>+--   IsLabel "protocol" (mapper -> NetworkAddress -> NetworkAddress)+--   where+--     fromLabel mapper (NetworkAddress a b c) =+--       NetworkAddress (mapper a) b c+--+-- instance+--   mapper ~ (Host -> Host) =>+--   IsLabel "host" (mapper -> NetworkAddress -> NetworkAddress)+--   where+--     fromLabel mapper (NetworkAddress a b c) =+--       NetworkAddress a (mapper b) c+--+-- instance+--   mapper ~ (Word16 -> Word16) =>+--   IsLabel "port" (mapper -> NetworkAddress -> NetworkAddress)+--   where+--     fromLabel mapper (NetworkAddress a b c) =+--       NetworkAddress a b (mapper c)+-- @+--+-- In case you\'re wondering what this tilde (@~@) constraint business is about,+-- refer to the [Type Equality Constraint](#type-equality-constraint) section.+--+-- ==== __Sum Example__+--+-- Having the following schema:+--+-- @+-- Host:+--   sum:+--     ip: Ip+--     name: Text+-- @+--+-- The following instances will be generated:+--+-- @+-- instance+--   mapper ~ (Ip -> Ip) =>+--   IsLabel "ip" (mapper -> Host -> Host)+--   where+--     fromLabel fn (IpHost a) = IpHost (fn a)+--     fromLabel _ a = a+--+-- instance+--   mapper ~ (Text -> Text) =>+--   IsLabel "name" (mapper -> Host -> Host)+--   where+--     fromLabel fn (NameHost a) = NameHost (fn a)+--     fromLabel _ a = a+-- @+--+-- In case you\'re wondering what this tilde (@~@) constraint business is about,+-- refer to the [Type Equality Constraint](#type-equality-constraint) section.+mapperIsLabelDeriver :: Deriver.Deriver mapperIsLabelDeriver =   Deriver.effectless InstanceDecs.mapperIsLabel
library/Domain/Attoparsec/General.hs view
@@ -1,20 +1,22 @@-module Domain.Attoparsec.General-where+module Domain.Attoparsec.General where -import Domain.Prelude hiding (takeWhile) import Data.Attoparsec.Text import qualified Data.Text as Text-+import Domain.Prelude hiding (takeWhile) +only :: Parser a -> Parser a only parser =   skipSpace *> parser <* skipSpace <* endOfInput +commaSeparated :: Parser a -> Parser [a] commaSeparated parser =   sepBy parser comma +comma :: Parser Char comma =   skipSpace *> char ',' <* skipSpace +inParens :: Parser b -> Parser b inParens parser =   do     char '('@@ -24,6 +26,7 @@     char ')'     return a +inSquareBrackets :: Parser b -> Parser b inSquareBrackets parser =   do     char '['@@ -33,17 +36,21 @@     char ']'     return a +skipSpace1 :: Parser () skipSpace1 =   space *> skipSpace +name :: (Char -> Bool) -> Parser Text name firstCharPred =   do     a <- satisfy firstCharPred-    b <- takeWhile (\ a -> isAlphaNum a || a == '\'' || a == '_')+    b <- takeWhile (\a -> isAlphaNum a || a == '\'' || a == '_')     return (Text.cons a b) +ucName :: Parser Text ucName =   name isUpper +lcName :: Parser Text lcName =-  name (\ a -> isLower a || a == '_')+  name (\a -> isLower a || a == '_')
library/Domain/Attoparsec/TypeString.hs view
@@ -1,27 +1,27 @@-module Domain.Attoparsec.TypeString-where+module Domain.Attoparsec.TypeString where -import Domain.Prelude hiding (takeWhile)-import Domain.Models.TypeString+import Control.Applicative.Combinators.NonEmpty import Data.Attoparsec.Text hiding (sepBy1) import Domain.Attoparsec.General-import Control.Applicative.Combinators.NonEmpty-+import Domain.Models.TypeString+import Domain.Prelude hiding (takeWhile) +commaSeq :: Parser [NonEmpty Unit] commaSeq =   commaSeparated appSeq +appSeq :: Parser (NonEmpty Unit) appSeq =   sepBy1 unit skipSpace1 +unit :: Parser Unit unit =-  asum [-    InSquareBracketsUnit <$> inSquareBrackets appSeq-    ,-    InParensUnit <$> inParens commaSeq-    ,-    RefUnit <$> typeRef+  asum+    [ InSquareBracketsUnit <$> inSquareBrackets appSeq,+      InParensUnit <$> inParens commaSeq,+      RefUnit <$> typeRef     ] +typeRef :: Parser (NonEmpty Text) typeRef =   sepBy1 ucName (char '.')
library/Domain/Docs.hs view
@@ -1,261 +1,269 @@ 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#-  {-|+  ( -- * How it works -  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.+    -- |+    --  \"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\". -  Here\'s an example of a schema declaration of a sum type:+    -- * Schema Syntax Reference #schemaSyntaxReference# -  > Host:-  >   sum:-  >     ip: Ip-  >     name: Text+    -- |+    --  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>. -  The following Haskell code will be generated from it:+    -- ** Product #product# -  > data Host =-  >   IpHost !Ip |-  >   NameHost !Text+    -- |+    --  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+    --  >   } -  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.+    -- *** Accessing fields #accessing-product-fields# -  E.g., here\'s how you\'ll be able to access the variants of the-  data-type:+    -- |+    --+    --  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" -  > getHostIp :: Host -> Maybe Ip-  > getHostIp = #ip+    -- ** Sum #sum# -  > ipHost :: Ip -> Host-  > ipHost = #ip+    -- |+    --+    --  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" -  > mapHostIp :: (Ip -> Ip) -> Host -> Host-  > mapHostIp = over #ip -- Using "domain-optics" and "optics"-  -  -}-  -- *** Multi-member sums #multi-member-sums#-  {-|+    -- *** 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.,+    -- |+    --+    --  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 -  > Error:-  >   sum:-  >     channel:-  >       - ChannelId-  >       - Text-  >     connectionLost:+    -- ** Enum #enum# -  This will generate the following declaration:+    -- |+    --  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 -  > data Error =-  >   ChannelError !ChannelId !Text |-  >   ConnectionLostError+    -- ** Notes #notes# -  Depending on the number of variant members the generated accessors will-  point to tuples or booleans:+    -- *** List Data-type #list-data-type# -  > 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.+    -- |+    --  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] -  Here\'s an example of a schema declaration of an enum type:+    -- *** Reserved Names -  > TransportProtocol:-  >   enum:-  >     - tcp-  >     - udp+    -- |+    --  You can use the otherwise banned field names like \"data\", \"type\",+    --  \"class\". -  This will generate the following Haskell data type:+    -- *** Newtypes -  > data TransportProtocol =-  >   TcpTransportProtocol |-  >   UdpTransportProtocol+    -- |+    --  Single-field products get represented as newtypes,+    --  so use them whenever you need to generate a newtype declaration. -  The following 'IsLabel' helpers will be available for it:+    -- *** Type Aliases -  > tcpTransportProtocol :: TransportProtocol-  > tcpTransportProtocol = #tcp-  >-  > getTransportProtocolTcp :: TransportProtocol -> Bool-  > getTransportProtocolTcp = #tcp+    -- |+    --  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. -  -}-  -- ** 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.,+    -- *** Polymorphic Types -  > 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.+    -- |+    --  Polymorphic types are not supported.+    --  Domain model is expected to consist of specific data structures,+    --  not abstractions. -  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.+    -- * Instance Derivation -  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.+    -- |+    --  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. -  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.+    -- ** Custom Derivers -  So far the following packages are available:+    -- |+    --  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. -  - ["domain-aeson"](http://hackage.haskell.org/package/domain-aeson) - provides-    integration with the ["aeson"](http://hackage.haskell.org/package/aeson) package.-  - ["domain-cereal"](http://hackage.haskell.org/package/domain-cereal) - provides-    integration with the ["cereal"](http://hackage.haskell.org/package/cereal) package.-  - ["domain-optics"](http://hackage.haskell.org/package/domain-optics) - provides-    integration with the ["optics"](http://hackage.haskell.org/package/optics) package.+    -- ** Deriver Extensions -  If you\'re looking to contribute,-  some likely needed candidates for extensions are \"QuickCheck\", \"binary\".-  -}-)+    -- |+    --  We expect the community to publish their general custom derivers as extensional+    --  packages.+    --+    --  So far the following packages are available:+    --+    --  - ["domain-aeson"](http://hackage.haskell.org/package/domain-aeson) - provides+    --    integration with the ["aeson"](http://hackage.haskell.org/package/aeson) package.+    --  - ["domain-cereal"](http://hackage.haskell.org/package/domain-cereal) - provides+    --    integration with the ["cereal"](http://hackage.haskell.org/package/cereal) package.+    --  - ["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\", \"binary\".+  ) where--import Domain.Prelude hiding (liftEither, readFile, lift)-import Domain
library/Domain/Models/TypeCentricDoc.hs view
@@ -1,20 +1,18 @@-module Domain.Models.TypeCentricDoc-where+module Domain.Models.TypeCentricDoc where -import Domain.Prelude hiding (Product, Sum, Enum) import qualified Domain.Models.TypeString as TypeString-+import Domain.Prelude hiding (Enum, Product, Sum)  type Doc =   [(Text, Structure)] -data Structure =-  ProductStructure [(Text, NestedTypeExpression)] |-  SumStructure [(Text, [NestedTypeExpression])] |-  EnumStructure [Text]+data Structure+  = ProductStructure [(Text, NestedTypeExpression)]+  | SumStructure [(Text, [NestedTypeExpression])]+  | EnumStructure [Text]   deriving (Show) -data NestedTypeExpression =-  AppSeqNestedTypeExpression TypeString.AppSeq |-  StructureNestedTypeExpression Structure+data NestedTypeExpression+  = AppSeqNestedTypeExpression TypeString.AppSeq+  | StructureNestedTypeExpression Structure   deriving (Show)
library/Domain/Models/TypeString.hs view
@@ -1,17 +1,15 @@-module Domain.Models.TypeString-where+module Domain.Models.TypeString where  import Domain.Prelude - type CommaSeq =   [AppSeq]  type AppSeq =   NonEmpty Unit -data Unit =-  InSquareBracketsUnit AppSeq |-  InParensUnit CommaSeq |-  RefUnit (NonEmpty Text)+data Unit+  = InSquareBracketsUnit AppSeq+  | InParensUnit CommaSeq+  | RefUnit (NonEmpty Text)   deriving (Show)
library/Domain/Prelude.hs view
@@ -1,25 +1,23 @@ module Domain.Prelude-( -  module Exports,-  showAsText,-)+  ( module Exports,+    showAsText,+  ) where --- base---------------------------import Control.Applicative as Exports hiding (WrappedArrow(..))+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 as Exports hiding (fail, forM, forM_, mapM, mapM_, msum, sequence, sequence_) import Control.Monad.Fail as Exports import Control.Monad.Fix as Exports hiding (fix)+import Control.Monad.IO.Class as Exports import Control.Monad.ST as Exports import Data.Bifunctor as Exports import Data.Bits as Exports import Data.Bool as Exports+import Data.ByteString as Exports (ByteString) import Data.Char as Exports import Data.Coerce as Exports import Data.Complex as Exports@@ -29,14 +27,15 @@ 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 as Exports hiding (unzip) import Data.Functor.Compose as Exports import Data.Functor.Contravariant as Exports-import Data.Int as Exports+import Data.Hashable as Exports (Hashable) import Data.IORef as Exports+import Data.Int 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.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons)+import Data.List.NonEmpty as Exports (NonEmpty (..)) import Data.Maybe as Exports import Data.Monoid as Exports hiding (Alt) import Data.Ord as Exports@@ -44,6 +43,7 @@ import Data.Ratio as Exports import Data.STRef as Exports import Data.String as Exports+import Data.Text as Exports (Text) import Data.Traversable as Exports import Data.Tuple as Exports import Data.Unique as Exports@@ -55,14 +55,14 @@ 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.Conc as Exports hiding (orElse, threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar)+import GHC.Exts as Exports (IsList (..), groupWith, inline, lazy, sortWith) import GHC.Generics as Exports (Generic) import GHC.IO.Exception as Exports import GHC.OverloadedLabels as Exports import GHC.Records as Exports+import Language.Haskell.TH.Syntax as Exports (Lift) 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)@@ -71,27 +71,10 @@ 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 Text.Printf as Exports (hPrintf, printf)+import Text.Read as Exports (Read (..), readEither, readMaybe) 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)+import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.)) -showAsText :: Show a => a -> Text+showAsText :: (Show a) => a -> Text showAsText = show >>> fromString
library/Domain/Resolvers/TypeCentricDoc.hs view
@@ -1,19 +1,17 @@-module Domain.Resolvers.TypeCentricDoc-where+module Domain.Resolvers.TypeCentricDoc where -import Domain.Prelude hiding (lookup)-import DomainCore.Model+import qualified Data.Text as Text import qualified Domain.Models.TypeCentricDoc as Doc import qualified Domain.Models.TypeString as TypeString-import qualified Data.Text as Text+import Domain.Prelude hiding (lookup) import qualified Domain.Text as Text-+import DomainCore.Model -eliminateDoc :: Applicative f => Doc.Doc -> f [TypeDec]+eliminateDoc :: (Applicative f) => Doc.Doc -> f [TypeDec] eliminateDoc =   traverse (uncurry (structureTypeDecs [])) >>> fmap join -structureTypeDecs :: Applicative f => [Text] -> Text -> Doc.Structure -> f [TypeDec]+structureTypeDecs :: (Applicative f) => [Text] -> Text -> Doc.Structure -> f [TypeDec] structureTypeDecs namespace name structure =   (:) <$> primary <*> structureGeneratedTypeDecs nextNamespace structure   where@@ -25,9 +23,9 @@     nextNamespace =       name : namespace -structureGeneratedTypeDecs :: Applicative f => [Text] -> Doc.Structure -> f [TypeDec]+structureGeneratedTypeDecs :: (Applicative f) => [Text] -> Doc.Structure -> f [TypeDec] structureGeneratedTypeDecs namespace =-  \ case+  \case     Doc.ProductStructure structure ->       traverse (uncurry (nestedTypeExpressionTypeDecs namespace . Text.ucFirst)) structure         & fmap join@@ -37,16 +35,17 @@     _ ->       pure [] +nestedTypeExpressionTypeDecs :: (Applicative f) => [Text] -> Text -> Doc.NestedTypeExpression -> f [TypeDec] nestedTypeExpressionTypeDecs namespace name =-  \ case+  \case     Doc.StructureNestedTypeExpression a ->       structureTypeDecs namespace name a     _ ->       pure [] -structureTypeDef :: Applicative f => [Text] -> Doc.Structure -> f TypeDef+structureTypeDef :: (Applicative f) => [Text] -> Doc.Structure -> f TypeDef structureTypeDef namespace =-  \ case+  \case     Doc.ProductStructure structure ->       ProductTypeDef <$> traverse (uncurry (eliminateProductStructureUnit namespace)) structure     Doc.SumStructure structure ->@@ -54,45 +53,48 @@     Doc.EnumStructure variants ->       pure (SumTypeDef (fmap (,[]) variants)) -eliminateProductStructureUnit :: Applicative f => [Text] -> Text -> Doc.NestedTypeExpression -> f (Text, Type)+eliminateProductStructureUnit :: (Applicative f) => [Text] -> Text -> Doc.NestedTypeExpression -> f (Text, Type) eliminateProductStructureUnit namespace name productTypeExpression =   (,) name <$> nestedTypeExpressionType namespace name productTypeExpression -eliminateSumStructureUnit :: Applicative f => [Text] -> Text -> [Doc.NestedTypeExpression] -> f (Text, [Type])+eliminateSumStructureUnit :: (Applicative f) => [Text] -> Text -> [Doc.NestedTypeExpression] -> f (Text, [Type]) eliminateSumStructureUnit namespace name sumTypeExpression =   (,) name <$> traverse (nestedTypeExpressionType namespace name) sumTypeExpression -nestedTypeExpressionType :: Applicative f => [Text] -> Text -> Doc.NestedTypeExpression -> f Type+nestedTypeExpressionType :: (Applicative f) => [Text] -> Text -> Doc.NestedTypeExpression -> f Type nestedTypeExpressionType namespace name =-  \ case+  \case     Doc.AppSeqNestedTypeExpression a ->       AppType <$> eliminateTypeStringAppSeq a     Doc.StructureNestedTypeExpression _ ->       pure (RefType (Text.concat (reverse (Text.ucFirst name : namespace)))) +eliminateTypeStringCommaSeq :: (Traversable t, Applicative f) => t (NonEmpty TypeString.Unit) -> f (t (NonEmpty Type)) eliminateTypeStringCommaSeq =   traverse eliminateTypeStringAppSeq -eliminateTypeStringAppSeq :: Applicative f => NonEmpty TypeString.Unit -> f (NonEmpty Type)+eliminateTypeStringAppSeq :: (Applicative f) => NonEmpty TypeString.Unit -> f (NonEmpty Type) eliminateTypeStringAppSeq =   traverse eliminateTypeStringUnit +eliminateTypeStringUnit :: (Applicative f) => TypeString.Unit -> f Type eliminateTypeStringUnit =-  \ case+  \case     TypeString.InSquareBracketsUnit appSeq ->-      eliminateTypeStringAppSeq appSeq &-        fmap (ListType . AppType)+      eliminateTypeStringAppSeq appSeq+        & fmap (ListType . AppType)     TypeString.InParensUnit commaSeq ->-      eliminateTypeStringCommaSeq commaSeq &-        fmap (tupleIfNotOne . fmap AppType)+      eliminateTypeStringCommaSeq commaSeq+        & fmap (tupleIfNotOne . fmap AppType)       where         tupleIfNotOne =-          \ case+          \case             [a] -> a             a -> TupleType a     TypeString.RefUnit typeRef ->-      eliminateTypeRef typeRef &-        fmap RefType+      eliminateTypeRef typeRef+        & fmap RefType +eliminateTypeRef :: (Applicative f) => NonEmpty Text -> f Text eliminateTypeRef =   pure . Text.intercalate "." . toList
library/Domain/TH/InstanceDec.hs view
@@ -1,19 +1,16 @@-{-|-Model-adapted instance declaration templates.--}-module Domain.TH.InstanceDec-where+-- |+-- 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 Language.Haskell.TH as TH import qualified THLego.Helpers as Helpers-+import qualified THLego.Instances as Instances  -- * HasField+ -------------------------  enumHasField :: Text -> Text -> TH.Dec@@ -30,10 +27,8 @@ 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+    then Instances.enumHasField thFieldLabel thOwnerType thConstructorName+    else Instances.sumHasField thFieldLabel thOwnerType thConstructorName thMemberTypes   where     thFieldLabel =       Helpers.textTyLit label@@ -46,8 +41,13 @@  productHasField :: Text -> Text -> Type -> Int -> Int -> TH.Dec productHasField typeName fieldName projectionType numMemberTypes offset =-  Instances.productHasField thFieldLabel thOwnerType thProjectionType-    thConstructorName numMemberTypes offset+  Instances.productHasField+    thFieldLabel+    thOwnerType+    thProjectionType+    thConstructorName+    numMemberTypes+    offset   where     thFieldLabel =       Helpers.textTyLit fieldName@@ -58,18 +58,23 @@     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+    thFieldLabel+    thOwnerType+    thProjectionType+    thConstructorName+    numMemberTypes+    offset   where     thFieldLabel =       Helpers.textTyLit fieldName@@ -85,10 +90,15 @@   if null memberTypes     then       Instances.enumAccessorIsLabel-        thFieldLabel thOwnerType thConstructorName+        thFieldLabel+        thOwnerType+        thConstructorName     else       Instances.sumAccessorIsLabel-        thFieldLabel thOwnerType thConstructorName thMemberTypes+        thFieldLabel+        thOwnerType+        thConstructorName+        thMemberTypes   where     thFieldLabel =       Helpers.textTyLit label@@ -102,7 +112,9 @@ enumAccessorIsLabel :: Text -> Text -> TH.Dec enumAccessorIsLabel typeName label =   Instances.enumAccessorIsLabel-    thFieldLabel thOwnerType thConstructorName+    thFieldLabel+    thOwnerType+    thConstructorName   where     thFieldLabel =       Helpers.textTyLit label@@ -112,12 +124,16 @@       CoreTH.sumConstructorName typeName label  -- ** Constructor+ -------------------------  curriedSumConstructorIsLabel :: Text -> Text -> [Type] -> TH.Dec curriedSumConstructorIsLabel typeName label memberTypes =   Instances.sumConstructorIsLabel-    thFieldLabel thOwnerType thConstructorName thMemberTypes+    thFieldLabel+    thOwnerType+    thConstructorName+    thMemberTypes   where     thFieldLabel =       Helpers.textTyLit label@@ -131,7 +147,10 @@ uncurriedSumConstructorIsLabel :: Text -> Text -> [Type] -> TH.Dec uncurriedSumConstructorIsLabel typeName label memberTypes =   Instances.tupleAdtConstructorIsLabel-    thFieldLabel thOwnerType thConstructorName thMemberTypes+    thFieldLabel+    thOwnerType+    thConstructorName+    thMemberTypes   where     thFieldLabel =       Helpers.textTyLit label@@ -145,7 +164,9 @@ enumConstructorIsLabel :: Text -> Text -> TH.Dec enumConstructorIsLabel typeName label =   Instances.enumConstructorIsLabel-    thFieldLabel thOwnerType thConstructorName+    thFieldLabel+    thOwnerType+    thConstructorName   where     thFieldLabel =       Helpers.textTyLit label@@ -157,7 +178,10 @@ wrapperConstructorIsLabel :: Text -> Type -> TH.Dec wrapperConstructorIsLabel typeName memberType =   Instances.newtypeConstructorIsLabel-    thFieldLabel thOwnerType thConstructorName thMemberType+    thFieldLabel+    thOwnerType+    thConstructorName+    thMemberType   where     thFieldLabel =       TH.StrTyLit "value"@@ -169,12 +193,18 @@       CoreTH.typeType memberType  -- ** Mapper+ -------------------------  wrapperMapperIsLabel :: Text -> Type -> TH.Dec wrapperMapperIsLabel typeName memberType =   Instances.productMapperIsLabel-    thFieldLabel thOwnerType thMemberType thConstructorName 1 0+    thFieldLabel+    thOwnerType+    thMemberType+    thConstructorName+    1+    0   where     thFieldLabel =       TH.StrTyLit "value"@@ -188,8 +218,12 @@ productMapperIsLabel :: Text -> Text -> Type -> Int -> Int -> TH.Dec productMapperIsLabel typeName fieldName projectionType numMemberTypes offset =   Instances.productMapperIsLabel-    thFieldLabel thOwnerType thProjectionType thConstructorName-    numMemberTypes offset+    thFieldLabel+    thOwnerType+    thProjectionType+    thConstructorName+    numMemberTypes+    offset   where     thFieldLabel =       Helpers.textTyLit fieldName@@ -203,7 +237,10 @@ sumMapperIsLabel :: Text -> Text -> [Type] -> TH.Dec sumMapperIsLabel typeName label memberTypes =   Instances.sumMapperIsLabel-    thFieldLabel thOwnerType thConstructorName thMemberTypes+    thFieldLabel+    thOwnerType+    thConstructorName+    thMemberTypes   where     thFieldLabel =       Helpers.textTyLit label@@ -214,8 +251,6 @@     thMemberTypes =       fmap CoreTH.typeType memberTypes ---- * -------------------------  deriving_ :: TH.Name -> Text -> TH.Dec
library/Domain/TH/InstanceDecs.hs view
@@ -1,11 +1,9 @@-module Domain.TH.InstanceDecs-where+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)-+import DomainCore.Model+import qualified Language.Haskell.TH as TH (Dec)  hasField :: TypeDec -> [TH.Dec] hasField (TypeDec typeName typeDef) =@@ -34,10 +32,11 @@         zipper offset (fieldName, fieldType) =           InstanceDec.productAccessorIsLabel typeName fieldName fieldType numMembers offset     SumTypeDef variants ->-      variants &-      fmap (\ (variantName, memberTypes) ->-        InstanceDec.sumAccessorIsLabel typeName variantName memberTypes-        )+      variants+        & fmap+          ( \(variantName, memberTypes) ->+              InstanceDec.sumAccessorIsLabel typeName variantName memberTypes+          )  constructorIsLabel :: TypeDec -> [TH.Dec] constructorIsLabel (TypeDec typeName typeDef) =@@ -45,24 +44,25 @@     ProductTypeDef members ->       []     SumTypeDef variants ->-      variants &-      fmap (\ (variantName, memberTypes) ->-        InstanceDec.curriedSumConstructorIsLabel typeName variantName memberTypes)+      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]+  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) =@@ -81,8 +81,8 @@           then empty           else pure (InstanceDec.sumMapperIsLabel typeName variantName memberTypes) - -- * Deriving+ -------------------------  byNonAliasName :: (Text -> TH.Dec) -> TypeDec -> [TH.Dec]@@ -92,37 +92,48 @@ byEnumName :: (Text -> TH.Dec) -> TypeDec -> [TH.Dec] byEnumName cont (TypeDec name def) =   case def of-    SumTypeDef variants | all (null . snd) variants ->-      [cont name]+    SumTypeDef variants+      | all (null . snd) variants ->+          [cont name]     _ ->       [] +enum :: TypeDec -> [TH.Dec] enum =   byEnumName (InstanceDec.deriving_ ''Enum) +bounded :: TypeDec -> [TH.Dec] bounded =   byEnumName (InstanceDec.deriving_ ''Bounded) +show :: TypeDec -> [TH.Dec] show =   byNonAliasName (InstanceDec.deriving_ ''Show) +eq :: TypeDec -> [TH.Dec] eq =   byNonAliasName (InstanceDec.deriving_ ''Eq) +ord :: TypeDec -> [TH.Dec] ord =   byNonAliasName (InstanceDec.deriving_ ''Ord) +generic :: TypeDec -> [TH.Dec] generic =   byNonAliasName (InstanceDec.deriving_ ''Generic) +data_ :: TypeDec -> [TH.Dec] data_ =   byNonAliasName (InstanceDec.deriving_ ''Data) +typeable :: TypeDec -> [TH.Dec] typeable =   byNonAliasName (InstanceDec.deriving_ ''Typeable) +hashable :: TypeDec -> [TH.Dec] hashable =   byNonAliasName (InstanceDec.empty ''Hashable) +lift :: TypeDec -> [TH.Dec] lift =   byNonAliasName (InstanceDec.deriving_ ''Lift)
library/Domain/TH/TypeDec.hs view
@@ -1,13 +1,12 @@-module Domain.TH.TypeDec-where+module Domain.TH.TypeDec where  import Domain.Prelude import DomainCore.Model+import qualified DomainCore.TH as CoreTH import qualified Language.Haskell.TH as TH import qualified THLego.Helpers as TH-import qualified DomainCore.TH as CoreTH -+typeDec :: Maybe (Bool, Bool) -> TypeDec -> TH.Dec typeDec fieldNaming (TypeDec a b) =   case b of     SumTypeDef b ->
library/Domain/Text.hs view
@@ -1,17 +1,18 @@-module Domain.Text-where+module Domain.Text where -import Domain.Prelude-import Data.Text import qualified Data.Char as Char-+import Data.Text+import Domain.Prelude +mapFirstChar :: (Char -> Char) -> Text -> Text mapFirstChar fn =-  foldMap (\ (a, b) -> cons (fn a) b) .-  uncons+  foldMap (\(a, b) -> cons (fn a) b)+    . uncons +ucFirst :: Text -> Text ucFirst =   mapFirstChar Char.toUpper +lcFirst :: Text -> Text lcFirst =   mapFirstChar Char.toLower
library/Domain/YamlUnscrambler/TypeCentricDoc.hs view
@@ -1,15 +1,15 @@-module Domain.YamlUnscrambler.TypeCentricDoc-where+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-+import qualified Domain.Attoparsec.General as GeneralAttoparsec+import qualified Domain.Attoparsec.TypeString as TypeStringAttoparsec+import Domain.Models.TypeCentricDoc+import qualified Domain.Models.TypeString as TypeStringModel+import Domain.Prelude+import YamlUnscrambler +doc :: Value [(Text, Structure)] doc =   value onScalar (Just onMapping) Nothing   where@@ -19,24 +19,23 @@       foldMapping (,) Fold.list typeNameString structure       where         typeNameString =-          formattedString "type name" $ \ input ->+          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"+                    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 Structure structure =   value [] (Just structureMapping) Nothing +byFieldName :: Value val -> Value [(Text, val)] byFieldName onElement =   value onScalar (Just onMapping) Nothing   where@@ -45,22 +44,23 @@     onMapping =       foldMapping (,) Fold.list textString onElement +sumTypeExpression :: Value [NestedTypeExpression] sumTypeExpression =   value onScalar (Just onMapping) (Just onSequence)   where     onScalar =-      [-        nullScalar []-        ,-        fmap (fmap AppSeqNestedTypeExpression) $-        stringScalar $ attoparsedString "Type signature" $-        GeneralAttoparsec.only TypeStringAttoparsec.commaSeq-        ]+      [ nullScalar [],+        fmap (fmap AppSeqNestedTypeExpression)+          $ stringScalar+          $ attoparsedString "Type signature"+          $ GeneralAttoparsec.only TypeStringAttoparsec.commaSeq+      ]     onMapping =       pure . StructureNestedTypeExpression <$> structureMapping     onSequence =       foldSequence Fold.list nestedTypeExpression +nestedTypeExpression :: Value NestedTypeExpression nestedTypeExpression =   value [onScalar] (Just onMapping) Nothing   where@@ -69,25 +69,30 @@     onMapping =       StructureNestedTypeExpression <$> structureMapping +enumVariants :: Value [Text] enumVariants =   sequenceValue (foldSequence Fold.list variant)   where     variant =       scalarsValue [stringScalar textString] - -- * Scalar+ ------------------------- +appTypeStringScalar :: Scalar (NonEmpty TypeStringModel.Unit) appTypeStringScalar =-  stringScalar $ attoparsedString "Type signature" $-  GeneralAttoparsec.only TypeStringAttoparsec.appSeq+  stringScalar+    $ attoparsedString "Type signature"+    $ GeneralAttoparsec.only TypeStringAttoparsec.appSeq  -- * Mapping+ ------------------------- +structureMapping :: Mapping Structure structureMapping =-  byKeyMapping (CaseSensitive True) $-    atByKey "product" (ProductStructure <$> byFieldName nestedTypeExpression) <|>-    atByKey "sum" (SumStructure <$> byFieldName sumTypeExpression) <|>-    atByKey "enum" (EnumStructure <$> enumVariants)+  byKeyMapping (CaseSensitive True)+    $ atByKey "product" (ProductStructure <$> byFieldName nestedTypeExpression)+    <|> atByKey "sum" (SumStructure <$> byFieldName sumTypeExpression)+    <|> atByKey "enum" (EnumStructure <$> enumVariants)
loading-demo/Main.hs view
@@ -1,15 +1,19 @@-{-# LANGUAGE-  TemplateHaskell,-  StandaloneDeriving, DeriveGeneric, DeriveDataTypeable, DeriveLift,-  FlexibleInstances, MultiParamTypeClasses,-  DataKinds, TypeFamilies-  #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-type-equality-requires-operators #-}+ module Main where  import Data.Text (Text) import Data.Word (Word16, Word32, Word64) import Domain-  main :: IO () main =
test/Main.hs view
@@ -1,55 +1,53 @@ module Main where -import Prelude hiding (assert)+import qualified Domain+import qualified DomainCore.Model as Model import Language.Haskell.TH.Instances ()-import Test.QuickCheck.Instances+import qualified Language.Haskell.TH.Syntax as TH 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-+import Prelude hiding (assert)  main :: IO () main =-  defaultMain $ -  testGroup "All tests" [-    testCase "Should fail when wrong member of sum-type is supplied" $ let-      res :: Maybe [Model.TypeDec]-      res =-        [TH.maybeDecsQQ|+  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|+             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 ()-    ]+                  |]+                   )+                leafTypes =+                  foldMap THLeafTypes.fromDec decs+             in case elemIndex (TH.TupleT 1) leafTypes of+                  Just _ ->+                    assertFailure (show decs)+                  Nothing ->+                    return ()+      ]
test/Util/TH.hs view
@@ -1,22 +1,21 @@ 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-+import Language.Haskell.TH.Quote as TH+import Language.Haskell.TH.Syntax as TH+import Prelude  tryQuoteExp :: QuasiQuoter -> String -> Q Exp tryQuoteExp q =-  recover (pure (ConE 'Nothing)) .-  fmap (AppE (ConE 'Just)) .-  quoteExp 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))+  recover (pure (ConE 'Nothing))+    . fmap (AppE (ConE 'Just))  mapQQExpQ :: (Q Exp -> Q Exp) -> QuasiQuoter -> QuasiQuoter mapQQExpQ mapper (QuasiQuoter a b c d) =@@ -28,8 +27,10 @@   where     mapper =       AppE-        (AppE (VarE 'fmap) -          (SigE (VarE 'unsafeCoerce) sig))+        ( AppE+            (VarE 'fmap)+            (SigE (VarE 'unsafeCoerce) sig)+        )       where         sig =           AppT
test/Util/TH/LeafTypes.hs view
@@ -1,33 +1,40 @@ module Util.TH.LeafTypes where -import Prelude import Language.Haskell.TH.Syntax import TemplateHaskell.Compat.V0208-+import Prelude +fromDec :: Dec -> [Kind] fromDec =-  \ case+  \case     NewtypeD a _ b c d _ ->-      fromCxt a <>-      concatMap fromTyVarBndr b <>-      foldMap fromType c <>-      fromCon d+      fromCxt a+        <> concatMap fromTyVarBndr b+        <> foldMap fromType c+        <> fromCon d+    _ -> error "TODO" +fromTyVarBndr :: TyVarBndr flag -> [Kind] fromTyVarBndr =   maybeToList . tyVarBndrKind +fromCxt :: Cxt -> [Kind] fromCxt =   concatMap fromType +fromCon :: Con -> [Kind] fromCon =-  \ case+  \case     NormalC _ bangTypes -> concatMap fromBangType bangTypes+    _ -> error "TODO" +fromBangType :: (a, Type) -> [Kind] fromBangType (_, t) =   fromType t +fromType :: Type -> [Kind] fromType =-  \ case+  \case     ForallT a b c ->       concatMap fromTyVarBndr a <> fromCxt b <> fromType c     ForallVisT a b ->