diff --git a/domain.cabal b/domain.cabal --- a/domain.cabal +++ b/domain.cabal @@ -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 -maintainer: Nikita Volkov -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 +maintainer: Nikita Volkov +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 diff --git a/inline-demo/Main.hs b/inline-demo/Main.hs --- a/inline-demo/Main.hs +++ b/inline-demo/Main.hs @@ -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 diff --git a/library/Domain.hs b/library/Domain.hs --- a/library/Domain.hs +++ b/library/Domain.hs @@ -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 diff --git a/library/Domain/Attoparsec/General.hs b/library/Domain/Attoparsec/General.hs --- a/library/Domain/Attoparsec/General.hs +++ b/library/Domain/Attoparsec/General.hs @@ -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 == '_') diff --git a/library/Domain/Attoparsec/TypeString.hs b/library/Domain/Attoparsec/TypeString.hs --- a/library/Domain/Attoparsec/TypeString.hs +++ b/library/Domain/Attoparsec/TypeString.hs @@ -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 '.') diff --git a/library/Domain/Docs.hs b/library/Domain/Docs.hs --- a/library/Domain/Docs.hs +++ b/library/Domain/Docs.hs @@ -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 - , - 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 - , - 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 + -- , + -- 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 + -- , + -- 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 diff --git a/library/Domain/Models/TypeCentricDoc.hs b/library/Domain/Models/TypeCentricDoc.hs --- a/library/Domain/Models/TypeCentricDoc.hs +++ b/library/Domain/Models/TypeCentricDoc.hs @@ -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) diff --git a/library/Domain/Models/TypeString.hs b/library/Domain/Models/TypeString.hs --- a/library/Domain/Models/TypeString.hs +++ b/library/Domain/Models/TypeString.hs @@ -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) diff --git a/library/Domain/Prelude.hs b/library/Domain/Prelude.hs --- a/library/Domain/Prelude.hs +++ b/library/Domain/Prelude.hs @@ -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 diff --git a/library/Domain/Resolvers/TypeCentricDoc.hs b/library/Domain/Resolvers/TypeCentricDoc.hs --- a/library/Domain/Resolvers/TypeCentricDoc.hs +++ b/library/Domain/Resolvers/TypeCentricDoc.hs @@ -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 diff --git a/library/Domain/TH/InstanceDec.hs b/library/Domain/TH/InstanceDec.hs --- a/library/Domain/TH/InstanceDec.hs +++ b/library/Domain/TH/InstanceDec.hs @@ -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 diff --git a/library/Domain/TH/InstanceDecs.hs b/library/Domain/TH/InstanceDecs.hs --- a/library/Domain/TH/InstanceDecs.hs +++ b/library/Domain/TH/InstanceDecs.hs @@ -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) diff --git a/library/Domain/TH/TypeDec.hs b/library/Domain/TH/TypeDec.hs --- a/library/Domain/TH/TypeDec.hs +++ b/library/Domain/TH/TypeDec.hs @@ -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 -> diff --git a/library/Domain/Text.hs b/library/Domain/Text.hs --- a/library/Domain/Text.hs +++ b/library/Domain/Text.hs @@ -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 diff --git a/library/Domain/YamlUnscrambler/TypeCentricDoc.hs b/library/Domain/YamlUnscrambler/TypeCentricDoc.hs --- a/library/Domain/YamlUnscrambler/TypeCentricDoc.hs +++ b/library/Domain/YamlUnscrambler/TypeCentricDoc.hs @@ -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) diff --git a/loading-demo/Main.hs b/loading-demo/Main.hs --- a/loading-demo/Main.hs +++ b/loading-demo/Main.hs @@ -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 = diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 () + ] diff --git a/test/Util/TH.hs b/test/Util/TH.hs --- a/test/Util/TH.hs +++ b/test/Util/TH.hs @@ -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 diff --git a/test/Util/TH/LeafTypes.hs b/test/Util/TH/LeafTypes.hs --- a/test/Util/TH/LeafTypes.hs +++ b/test/Util/TH/LeafTypes.hs @@ -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 ->