packages feed

domain-aeson (empty) → 0.1

raw patch · 7 files changed

+393/−0 lines, 7 filesdep +aesondep +basedep +domain

Dependencies added: aeson, base, domain, domain-aeson, domain-core, rerebase, template-haskell, template-haskell-compat-v0208, text, th-lego, unordered-containers, vector

Files

+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2022 Nikita Volkov++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.
+ demo/Main.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Main where++import Domain+import DomainAeson+import Prelude++main :: IO ()+main =+  return ()++declare+  Nothing+  toJsonDeriver+  [schema|++    ServiceAddress:+      sum:+        network: NetworkAddress+        local: FilePath++    NetworkAddress:+      product:+        protocol: TransportProtocol+        host: Host+        port: Word16++    TransportProtocol:+      enum:+        - tcp+        - udp++    Host:+      sum:+        ip: Ip+        name: Text++    Ip:+      sum:+        v4: Word32+        v6: Word128++    Word128:+      product:+        part1: Word64+        part2: Word64++    |]
+ domain-aeson.cabal view
@@ -0,0 +1,48 @@+cabal-version: 3.0++name: domain-aeson+version: 0.1+synopsis: Integration of domain with aeson+homepage: https://github.com/nikita-volkov/domain-aeson+bug-reports: https://github.com/nikita-volkov/domain-aeson/issues+author: Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer: Nikita Volkov <nikita.y.volkov@mail.ru>+copyright: (c) 2022 Nikita Volkov+license: MIT+license-file: LICENSE+build-type: Simple++source-repository head+  type: git+  location: git://github.com/nikita-volkov/domain-aeson.git++library+  hs-source-dirs: library+  default-extensions: BangPatterns, BlockArguments, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DerivingVia, 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, UnboxedTuples+  default-language: Haskell2010+  exposed-modules:+    DomainAeson+  other-modules:+    DomainAeson.InstanceDecs+    DomainAeson.Prelude+    DomainAeson.Util.AesonTH+  build-depends:+    aeson >=2 && <3,+    base >=4.12 && <5,+    domain-core >=0.1 && <0.2,+    text >=1 && <3,+    template-haskell >=2.14 && <3,+    template-haskell-compat-v0208 >=0.1.7 && <0.2,+    th-lego >=0.2.1 && <0.4,+    unordered-containers >=0.2.10 && <0.3,+    vector >=0.12 && <0.13,++test-suite demo+  type: exitcode-stdio-1.0+  hs-source-dirs: demo+  main-is: Main.hs+  default-language: Haskell2010+  build-depends:+    domain,+    domain-aeson,+    rerebase >=1.9 && <2,
+ library/DomainAeson.hs view
@@ -0,0 +1,9 @@+module DomainAeson where++import qualified DomainAeson.InstanceDecs as InstanceDecs+import DomainAeson.Prelude+import qualified DomainCore.Deriver as Deriver++toJsonDeriver :: Deriver.Deriver+toJsonDeriver =+  Deriver.effectless InstanceDecs.toJson
+ library/DomainAeson/InstanceDecs.hs view
@@ -0,0 +1,27 @@+module DomainAeson.InstanceDecs where++import DomainAeson.Prelude+import qualified DomainAeson.Util.AesonTH as AesonTH+import qualified DomainCore.Model as Model+import qualified DomainCore.TH as DomainTH+import Language.Haskell.TH.Syntax+import THLego.Helpers++toJson :: Model.TypeDec -> [Dec]+toJson (Model.TypeDec typeName typeDef) =+  pure $ case typeDef of+    Model.ProductTypeDef members ->+      AesonTH.productToJsonInstanceDec+        (ConT (textName typeName))+        (textName typeName)+        (fmap fst members)+    Model.SumTypeDef members ->+      AesonTH.sumToJsonInstanceDec+        (ConT (textName typeName))+        (fmap member members)+      where+        member (memberName, memberComponentTypes) =+          ( memberName,+            DomainTH.sumConstructorName typeName memberName,+            length memberComponentTypes+          )
+ library/DomainAeson/Prelude.hs view
@@ -0,0 +1,78 @@+module DomainAeson.Prelude+  ( module Exports,+    showAsText,+  )+where++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, 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.Char as Exports+import Data.Coerce as Exports+import Data.Complex as Exports+import Data.Data as Exports+import Data.Dynamic as Exports+import Data.Either as Exports+import Data.Fixed as Exports+import Data.Foldable as Exports hiding (toList)+import Data.Function as Exports hiding (id, (.))+import Data.Functor as Exports+import Data.Functor.Compose as Exports+import Data.Functor.Contravariant as Exports+import Data.IORef as Exports+import Data.Int as Exports+import Data.Ix as Exports+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+import Data.Proxy as Exports+import Data.Ratio as Exports hiding ((%))+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+import Data.Version as Exports+import Data.Void as Exports+import Data.Word as Exports+import Debug.Trace as Exports+import Foreign.ForeignPtr as Exports+import Foreign.Ptr as Exports+import Foreign.StablePtr as Exports+import Foreign.Storable as Exports+import GHC.Conc as Exports hiding (orElse, 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 Numeric as Exports+import System.Environment as Exports+import System.Exit as Exports+import System.IO as Exports (Handle, hClose)+import System.IO.Error as Exports+import System.IO.Unsafe as Exports+import System.Mem as Exports+import System.Mem.StableName as Exports+import System.Timeout as Exports+import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P)+import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readP_to_Prec, readPrec_to_P, readPrec_to_S, readS_to_Prec)+import Text.Printf as Exports (hPrintf, printf)+import Text.Read as Exports (Read (..), readEither, readMaybe)+import Unsafe.Coerce as Exports+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 >>> fromString
+ library/DomainAeson/Util/AesonTH.hs view
@@ -0,0 +1,154 @@+-- |+-- TH utils for aeson.+module DomainAeson.Util.AesonTH where++import qualified Data.Aeson as Ae+import qualified Data.Aeson.Key as AeKey+import qualified Data.Aeson.KeyMap as AeKeyMap+import qualified Data.Text as Text+import qualified Data.Vector as Vector+import DomainAeson.Prelude+import Language.Haskell.TH.Syntax+import THLego.Helpers+import qualified THLego.Lambdas as Lambdas+import qualified TemplateHaskell.Compat.V0208 as Compat++productParseJsonD :: Name -> [(Text, Bool)] -> Dec+productParseJsonD conName fields =+  FunD 'Ae.parseJSON [clause]+  where+    clause =+      Clause [] (NormalB exp) []+      where+        exp =+          multiAppE+            (VarE 'Ae.withObject)+            [ LitE (StringL (nameString conName)),+              productObjectParsingLamE conName fields+            ]++productObjectParsingLamE :: Name -> [(Text, Bool)] -> Exp+productObjectParsingLamE conName fields =+  LamE [VarP aName] (productObjectParserE (ConE aName) conName fields)++productObjectParserE :: Exp -> Name -> [(Text, Bool)] -> Exp+productObjectParserE objectE conName fields =+  applicativeChainE (ConE conName) (fmap fieldE fields)+  where+    fieldE (label, required) =+      InfixE (Just objectE) (VarE opName) (Just (textLitE label))+      where+        opName =+          if required+            then '(Ae..:)+            else '(Ae..:?)++-- *++toJsonInstanceDec :: Type -> Dec -> Dec+toJsonInstanceDec type_ toJsonFunDec =+  InstanceD Nothing [] headType [toJsonFunDec]+  where+    headType =+      AppT (ConT ''Ae.ToJSON) type_++productToJsonInstanceDec :: Type -> Name -> [Text] -> Dec+productToJsonInstanceDec type_ conName members =+  toJsonInstanceDec type_ $ productToJsonFunD conName members++sumToJsonInstanceDec :: Type -> [(Text, Name, Int)] -> Dec+sumToJsonInstanceDec type_ members =+  toJsonInstanceDec type_ $ sumToJsonFunD members++enumToJsonInstanceDec :: Type -> [(Text, Name)] -> Dec+enumToJsonInstanceDec type_ members =+  toJsonInstanceDec type_ $ enumToJsonFunD members++-- *++productToJsonFunD :: Name -> [Text] -> Dec+productToJsonFunD conName members =+  FunD 'Ae.toJSON [clause]+  where+    varNamesAndJsonNames =+      mapWithAlphabeticName (,) members+    clause =+      Clause [Compat.conp conName memberPats] body []+      where+        memberPats = fmap memberPat varNamesAndJsonNames+          where+            memberPat (varName, _) = VarP varName+        body = NormalB $ AppE (ConE 'Ae.Object) mapE+          where+            mapE =+              AppE (VarE 'AeKeyMap.fromList) (ListE (fmap memberPairE varNamesAndJsonNames))+            memberPairE (varName, jsonName) =+              appliedTupleE [textKeyE jsonName, toJsonE (VarE varName)]++sumToJsonFunD :: [(Text, Name, Int)] -> Dec+sumToJsonFunD members =+  FunD 'Ae.toJSON clauses+  where+    clauses = fmap memberClause members+      where+        memberClause (jsonName, conName, components) =+          case components of+            0 ->+              Clause [Compat.conp conName []] (NormalB bodyExp) []+              where+                bodyExp = stringJsonE jsonName+            1 ->+              Clause [Compat.conp conName [VarP varName]] (NormalB bodyExp) []+              where+                varName = mkName "a"+                bodyExp =+                  AppE+                    (ConE 'Ae.Object)+                    ( multiAppE+                        (VarE 'AeKeyMap.singleton)+                        [ textKeyE jsonName,+                          toJsonE (VarE varName)+                        ]+                    )+            _ ->+              Clause [Compat.conp conName (fmap VarP varNames)] (NormalB bodyExp) []+              where+                varNames = enumAlphabeticNames components+                bodyExp =+                  AppE+                    (ConE 'Ae.Object)+                    ( multiAppE+                        (VarE 'AeKeyMap.singleton)+                        [ textKeyE jsonName,+                          jsonArrayE (fmap (toJsonE . VarE) varNames)+                        ]+                    )++enumToJsonFunD :: [(Text, Name)] -> Dec+enumToJsonFunD members =+  FunD 'Ae.toJSON clauses+  where+    clauses = fmap memberClause members+      where+        memberClause (jsonName, conName) =+          Clause [Compat.conp conName []] (NormalB bodyExp) []+          where+            bodyExp = stringJsonE jsonName++-- *++jsonArrayE :: [Exp] -> Exp+jsonArrayE exps =+  AppE (ConE 'Ae.Array) (AppE (VarE 'Vector.fromList) (ListE exps))++stringJsonE :: Text -> Exp+stringJsonE =+  AppE (ConE 'Ae.String) . AppE (VarE 'fromString) . textLitE++textKeyE :: Text -> Exp+textKeyE text =+  AppE (VarE 'AeKey.fromString) (textLitE text)++toJsonE :: Exp -> Exp+toJsonE =+  AppE (VarE 'Ae.toJSON)