diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,22 @@ + +1.2.0.0 +======= + +- Hid the internals of the `Aliases` module in the main module. +- Various generic helpers. + +1.0.1.0 +======= + +- deprecated fieldAliases and branchAliases in favor of aliasListBegin. + +1.0.2.0 +======= + +- added a quasiquoter in a new public library + +1.1.0.0 +======= + +- removed deprecated functions fieldAliases and branchAliases +- renamed ForRubric to AliasType diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +BSD 3-Clause License + +Copyright (c) 2020, Daniel Díaz Carrete +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,34 @@ +# by-other-names + +Give aliases to record fields. + +When generically deriving [aeson](http://hackage.haskell.org/package/aeson)'s +`FromJSON` and `ToJSON` instances, field names are used as the keys for the +serialized JSON. If you don't want that, another option is to write the +instances manually. Problem is, you have to repeat the field names once for +`FromJSON` and once for `ToJSON`. + +I wanted an intermediate solution similar to what is provided by Go's [struct +tags](https://www.digitalocean.com/community/tutorials/how-to-use-struct-tags-in-go): +associate aliases with each field and use those aliases when +serializing/deserializing. There can be different sets of aliases for different +contexts (json, orm...). In this library, each of those possible contexts is +called a "rubric". + +## How to depend on this library? + +``` +build-depends: + by-other-names ^>= 1.2.0.0 +``` +## Other related packages + +- [generics-sop](https://hackage.haskell.org/package/generics-sop) + +- [barbies](https://hackage.haskell.org/package/barbies) + +- [higgledy](https://hackage.haskell.org/package/higgledy) + +- [generic-data-surgery](https://hackage.haskell.org/package/generic-data-surgery) + +- [one-liner](https://hackage.haskell.org/package/one-liner) diff --git a/by-other-names.cabal b/by-other-names.cabal new file mode 100644 --- /dev/null +++ b/by-other-names.cabal @@ -0,0 +1,60 @@ +cabal-version: 3.0 +name: by-other-names +version: 1.2.0.0 +synopsis: Give aliases to record fields. + +description: Give aliases to record fields. + +license: BSD-3-Clause +license-file: LICENSE +author: Daniel Diaz +maintainer: diaz_carrete@yahoo.com +category: Data +extra-source-files: CHANGELOG.md, + README.md +build-type: Simple + +source-repository head + type: git + location: https://github.com/danidiaz/by-other-names.git + +library + exposed-modules: ByOtherNames + ByOtherNames.Aeson + ByOtherNames.Constraint + ByOtherNames.TH + ByOtherNames.Internal + build-depends: base >= 4.10.0.0 && < 5, + aeson >= 2.1.0.0, + text >= 1.2.3.0, + template-haskell >= 2.16.0.0, + indexed-traversable >= 0.1.2 + hs-source-dirs: lib + -- https://downloads.haskell.org/ghc/latest/docs/html/users_guide/using-warnings.html + ghc-options: -W + default-language: Haskell2010 + +test-suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: tests.hs + build-depends: + base >= 4.10.0.0 && < 5, + tasty >= 0.10.1.1, + tasty-hunit >= 0.9.2, + aeson >= 1.5.2.0, + by-other-names, + default-language: Haskell2010 + +-- VERY IMPORTANT for doctests to work: https://stackoverflow.com/a/58027909/1364288 +-- http://hackage.haskell.org/package/cabal-doctest +test-suite doctests + ghc-options: -threaded + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: doctests.hs + build-depends: + base >= 4.10.0.0 && < 5, + doctest ^>= 0.20, + by-other-names, + default-language: Haskell2010 diff --git a/lib/ByOtherNames.hs b/lib/ByOtherNames.hs new file mode 100644 --- /dev/null +++ b/lib/ByOtherNames.hs @@ -0,0 +1,33 @@ +-- | This package provides the general mechanism for defining field and branch +-- aliases for algebraic datatypes. +-- +-- Aliases can be defined for multiple contexts (json serialization, orms...). +-- Each of those contexts is termed a 'Rubric', basically a marker datakind +-- used to namespace the aliases. +-- +-- This module should only be imported if you want to define your own adapter +-- package for some new `Rubric`. See "ByOtherNames.Aeson" for a concrete example. +module ByOtherNames + ( -- * Aliases + Aliases, + zipAliasesWith, + AliasList, + aliasListBegin, + alias, + aliasListEnd, + -- * Rubrics + Rubric (..), + Aliased (aliases), + -- * Generic helpers + GHasDatatypeName(..), + GHasFieldNames (..), + GRecord (..), + GHasBranchNames (..), + GSum (..), + Slots (..), + -- * Re-exports + Symbol, + ) +where + +import ByOtherNames.Internal diff --git a/lib/ByOtherNames/Aeson.hs b/lib/ByOtherNames/Aeson.hs new file mode 100644 --- /dev/null +++ b/lib/ByOtherNames/Aeson.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} + +-- | A 'Rubric' for JSON serialization using Aeson, along with some helper +-- newtypes and re-exports. +-- +-- Required extensions: +-- +-- - DataKinds +-- - DeriveGeneric +-- - DerivingVia +-- - FlexibleInstances +-- - MultiParamTypeClasses +-- - OverloadedStrings +-- - TypeApplications +-- - ScopedTypeVariables +-- +-- Example of use for a record type: +-- +-- >>> :{ +-- data Foo = Foo {aa :: Int, bb :: Bool, cc :: Char} +-- deriving (Read, Show, Eq, Generic) +-- deriving (FromJSON, ToJSON) via (JSONRecord "obj" Foo) +-- instance Aliased JSON Foo where +-- aliases = +-- aliasListBegin +-- $ alias @"aa" "aax" +-- $ alias @"bb" "bbx" +-- $ alias @"cc" "ccx" +-- $ aliasListEnd +-- :} +-- +-- Example of use for a sum type: +-- +-- >>> :{ +-- data Summy +-- = Aa Int +-- | Bb Bool +-- | Cc +-- deriving (Read, Show, Eq, Generic) +-- deriving (FromJSON, ToJSON) via (JSONSum "sum" Summy) +-- instance Aliased JSON Summy where +-- aliases = +-- aliasListBegin +-- $ alias @"Aa" "Aax" +-- $ alias @"Bb" "Bbx" +-- $ alias @"Cc" "Ccx" +-- $ aliasListEnd +-- :} +-- +-- Some limitations: +-- +-- - Fields in branches of sum types can't have selectors. When there is more than one field in a branch, they are parsed as a JSON Array. +-- +-- - For sum types, only the "object with a single key consisting in the branch tag" style of serialization is supported. +-- +module ByOtherNames.Aeson + ( -- * JSON helpers + JSONRubric (..), + JSONRecord (..), + JSONSum (..), + + -- * Re-exports from ByOtherNames + Aliased (aliases), + aliasListBegin, + alias, + aliasListEnd, + + -- * Re-exports from Data.Aeson + FromJSON, + ToJSON, + ) +where + +import ByOtherNames +import Control.Applicative +import Data.Aeson +import Data.Aeson.Types +import Data.Functor.Compose +import Data.Kind +import GHC.Generics +import GHC.TypeLits +import Data.Proxy +import Data.Foldable + +-- | Aliases for JSON serialization fall under this 'Rubric'. +-- The constructor 'JSON' is used as a type, with DataKinds. +data JSONRubric = JSON + +-- | The aliases will be of type "Data.Aeson.Key". +instance Rubric JSON where + type AliasType JSON = Key + +-- | Helper newtype for deriving 'FromJSON' and 'ToJSON' for record types, +-- using DerivingVia. +-- +-- The @objectName@ type parameter of kind 'Symbol' is used in parse error messages. +type JSONRecord :: Symbol -> Type -> Type +newtype JSONRecord objectName r = JSONRecord r + +-- | Helper newtype for deriving 'FromJSON' and 'ToJSON' for sum types, +-- using DerivingVia. +-- +-- The 'Symbol' type parameter is used in parse error messages. +type JSONSum :: Symbol -> Type -> Type +newtype JSONSum objectName r = JSONSum r + +-- +-- +instance (KnownSymbol objectName, Aliased JSON r, GSum FromJSON (Rep r)) => FromJSON (JSONSum objectName r) where + parseJSON v = + let parsers = gToSum @FromJSON (aliases @JSONRubric @JSON @r) + (\a -> \case + ZeroSlots v -> BranchParser \o -> do + Null :: Value <- o .: a + pure v + SingleSlot p -> BranchParser \o -> do + value <- o .: a + runProductInBranchParser1 p value + ManySlots p -> BranchParser \o -> do + valueList <- o .: a + (prod, _) <- runProductInBranchParser p valueList + pure prod + ) + (ProductInBranchParser1 parseJSON) + (ProductInBranchParser \case + [] -> parseFail "not enough field values for branch" + v : vs -> do + r <- parseJSON v + pure (r, vs)) + parserForObject o = asum $ fmap (($ o) . runBranchParser) parsers + in JSONSum . to <$> withObject (symbolVal (Proxy @objectName)) parserForObject v +newtype BranchParser v = BranchParser { runBranchParser :: Object -> Parser v} + deriving stock Functor + +newtype ProductInBranchParser1 v = ProductInBranchParser1 { runProductInBranchParser1 :: Value -> Parser v } + deriving stock Functor + deriving Applicative via (Compose ((->) Value) Parser) + +newtype ProductInBranchParser v = ProductInBranchParser { runProductInBranchParser :: [Value] -> Parser (v, [Value]) } + deriving stock Functor + +instance Applicative ProductInBranchParser where + pure v = ProductInBranchParser \vs -> pure (v, vs) + ProductInBranchParser left <*> ProductInBranchParser right = + ProductInBranchParser \vs0 -> do + (f, vs1) <- left vs0 + (x, vs2) <- right vs1 + pure (f x, vs2) + + +-- +-- +instance (KnownSymbol objectName, Aliased JSON r, GRecord FromJSON (Rep r)) => FromJSON (JSONRecord objectName r) where + parseJSON v = + let FieldParser parser = gToRecord @FromJSON (aliases @JSONRubric @JSON @r) + (\fieldName -> FieldParser (\o ->explicitParseField parseJSON o fieldName)) + objectName = symbolVal (Proxy @objectName) + in JSONRecord . to <$> withObject objectName parser v +newtype FieldParser a = FieldParser (Object -> Parser a) + deriving (Functor, Applicative) via ((->) Object `Compose` Parser) + + +-- +-- +instance (Aliased JSON r, GSum ToJSON (Rep r)) => ToJSON (JSONSum objectName r) where + toJSON (JSONSum o) = + let (key, slots) = gFromSum @ToJSON @(Rep r) @Key @Value @Value (aliases @JSONRubric @JSON @r) toJSON (from @r o) + in case slots of + [] -> object [(key, Null)] + [x] -> object [(key, toJSON x)] + xs -> object [(key, toJSON xs)] + +-- +-- +instance (Aliased JSON r, GRecord ToJSON (Rep r)) => ToJSON (JSONRecord objectName r) where + toJSON (JSONRecord o) = + object $ Data.Foldable.toList $ gFromRecord @ToJSON @(Rep r) @Key (aliases @JSONRubric @JSON @r) (\a v -> (a, toJSON v)) (from @r o) + +-- $setup +-- +-- >>> :set -XBlockArguments +-- >>> :set -XTypeApplications +-- >>> :set -XDerivingStrategies +-- >>> :set -XDerivingVia +-- >>> :set -XDataKinds +-- >>> :set -XMultiParamTypeClasses +-- >>> :set -XDeriveGeneric +-- >>> :set -XOverloadedStrings +-- >>> import ByOtherNames.Aeson +-- >>> import Data.Aeson +-- >>> import Data.Aeson.Types +-- >>> import GHC.Generics +-- >>> import GHC.TypeLits diff --git a/lib/ByOtherNames/Constraint.hs b/lib/ByOtherNames/Constraint.hs new file mode 100644 --- /dev/null +++ b/lib/ByOtherNames/Constraint.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE FlexibleInstances #-} +module ByOtherNames.Constraint (Top) where + +-- | A constraint that can always be satisfied. +-- +-- Copied from the @sop-core@ package. +-- +class Top x +instance Top x diff --git a/lib/ByOtherNames/Internal.hs b/lib/ByOtherNames/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/ByOtherNames/Internal.hs @@ -0,0 +1,445 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-missing-methods #-} + +-- | This package provides the general mechanism for defining field and branch +-- aliases for algebraic datatypes. +-- +-- Aliases can be defined for multiple contexts (json serialization, orms...). +-- Each of those contexts is termed a 'Rubric', basically a marker datakind +-- used to namespace the aliases. +-- +-- This module should only be imported if you want to define your own adapter +-- package for some new `Rubric`. +module ByOtherNames.Internal + ( Aliases (..), + zipAliasesWith, + AliasList, + aliasListBegin, + alias, + aliasListEnd, + Aliased (aliases), + Rubric (..), + + -- * Generic helpers + GHasDatatypeName(..), + GHasFieldNames (..), + GRecord (..), + GHasBranchNames (..), + GSum (..), + Slots (..), + -- * Re-exports + Symbol, + ) +where + +import Control.Applicative +import Data.Foldable.WithIndex +import Data.Functor.WithIndex +import Data.Kind +import Data.Proxy +import Data.Traversable.WithIndex +import GHC.Generics +import GHC.TypeLits + +-- | This datatype carries the field aliases and matches the structure of the +-- generic Rep' shape. +type Aliases :: (Type -> Type) -> Type -> Type +data Aliases rep a where + Field :: KnownSymbol fieldName => a -> Aliases (S1 ('MetaSel ('Just fieldName) unpackedness strictness laziness) v) a + Branch :: KnownSymbol branchName => a -> Aliases (C1 ('MetaCons branchName fixity sels) v) a + FieldTree :: + Aliases left a -> + Aliases right a -> + Aliases (left :*: right) a + BranchTree :: + Aliases left a -> + Aliases right a -> + Aliases (left :+: right) a + -- | We force the sum to contain at least two branches. + Sum :: + Aliases (left :+: right) a -> + Aliases (D1 x (left :+: right)) a + Record :: + Aliases fields a -> + Aliases (D1 x (C1 y fields)) a + +zipAliasesWith :: (a -> b -> c) -> Aliases rep a -> Aliases rep b -> Aliases rep c +zipAliasesWith f a1 a2 = case (a1, a2) of + (Field a, Field b) -> Field (f a b) + (Branch a, Branch b) -> Branch (f a b) + (FieldTree a1 a2, FieldTree b1 b2) -> FieldTree (zipAliasesWith f a1 b1) (zipAliasesWith f a2 b2) + (BranchTree a1 a2, BranchTree b1 b2) -> BranchTree (zipAliasesWith f a1 b1) (zipAliasesWith f a2 b2) + (Sum a, Sum b) -> Sum (zipAliasesWith f a b) + (Record a, Record b) -> Record (zipAliasesWith f a b) + +instance Functor (Aliases rep) where + fmap f as = case as of + Field a -> Field (f a) + Branch a -> Branch (f a) + FieldTree left right -> FieldTree (fmap f left) (fmap f right) + BranchTree left right -> BranchTree (fmap f left) (fmap f right) + Sum a -> Sum (fmap f a) + Record a -> Record (fmap f a) + +instance Foldable (Aliases rep) where + foldMap f as = case as of + Field a -> f a + Branch a -> f a + FieldTree left right -> foldMap f left <> foldMap f right + BranchTree left right -> foldMap f left <> foldMap f right + Sum a -> foldMap f a + Record a -> foldMap f a + +instance Traversable (Aliases rep) where + traverse f as = case as of + Field a -> Field <$> f a + Branch a -> Branch <$> f a + FieldTree left right -> FieldTree <$> traverse f left <*> traverse f right + BranchTree left right -> BranchTree <$> traverse f left <*> traverse f right + Sum a -> Sum <$> traverse f a + Record a -> Record <$> traverse f a + +-- | Indexed by the field or branch names. +deriving anyclass instance (FunctorWithIndex String (Aliases rep)) + +deriving anyclass instance (FoldableWithIndex String (Aliases rep)) + +instance TraversableWithIndex String (Aliases rep) where + itraverse f as = case as of + afield@(Field a) -> Field <$> traverseField f afield a + abranch@(Branch a) -> Branch <$> traverseBranch f abranch a + FieldTree left right -> FieldTree <$> itraverse f left <*> itraverse f right + BranchTree left right -> BranchTree <$> itraverse f left <*> itraverse f right + Sum a -> Sum <$> itraverse f a + Record a -> Record <$> itraverse f a + where + traverseField :: forall fieldName a m b v proxy unpackedness strictness laziness. KnownSymbol fieldName => (String -> a -> m b) -> proxy (S1 ('MetaSel ('Just fieldName) unpackedness strictness laziness) v) a -> a -> m b + traverseField f _ a = + let fieldName = symbolVal (Proxy @fieldName) + in f fieldName a + traverseBranch :: forall branchName a m b v proxy fixity sels. KnownSymbol branchName => (String -> a -> m b) -> proxy (C1 ('MetaCons branchName fixity sels) v) a -> a -> m b + traverseBranch f _ a = + let branchName = symbolVal (Proxy @branchName) + in f branchName a + +-- | An intermediate datatype for specifying the aliases. See +-- 'aliasListBegin', 'alias' and 'aliasListEnd'. +type AliasList :: [Symbol] -> Type -> Type +data AliasList names a where + Null :: AliasList '[] a + Cons :: Proxy name -> a -> AliasList names a -> AliasList (name : names) a + +-- | Add an alias to an `AliasList`. +-- +-- __/TYPE APPLICATION REQUIRED!/__ You must provide the field/branch name using a type application. +alias :: forall name a names. a -> AliasList names a -> AliasList (name : names) a +alias = Cons (Proxy @name) + +-- | Define the aliases for a type by listing them. +-- +-- See also 'alias' and 'aliasListEnd'. +aliasListBegin :: forall before a tree. (AliasTree before tree '[]) => AliasList before a -> Aliases tree a +aliasListBegin names = + let (aliases, Null) = parseAliasTree @before @tree names + in aliases + +-- | The empty `AliasList`. +aliasListEnd :: AliasList '[] a +aliasListEnd = Null + +type AssertNamesAreEqual :: Symbol -> Symbol -> Constraint +type family AssertNamesAreEqual given expected where + AssertNamesAreEqual expected expected = () + AssertNamesAreEqual given expected = + TypeError + ( Text "Expected field or constructor name \"" :<>: Text expected :<>: Text "\"," + :$$: Text "but instead found name \"" :<>: Text given :<>: Text "\"." + ) + +type MissingAlias :: Symbol -> Constraint +type family MissingAlias expected where + MissingAlias expected = + TypeError + (Text "No alias given for field or constructor name \"" :<>: Text expected :<>: Text "\".") + +-- type ExcessAliasError :: Symbol -> Constraint +-- type family ExcessAliasError name where +-- ExcessAliasError name = +-- TypeError +-- ( Text "Alias given for nonexistent field or constructor \"" :<>: Text name :<>: Text "\".") + +-- | This typeclass converts the list-representation of aliases `AliasList` to +-- the tree of aliases 'Aliases' that matches the generic Rep's shape. +-- +-- Also, quite importantly, it ensures that the field names in the list match +-- the field names in the Rep. +type AliasTree :: [Symbol] -> (Type -> Type) -> [Symbol] -> Constraint +-- Note that we could add the functional dependency "rep after -> before", but +-- we don't want that because it would allow us to omit the field name +-- annotation when giving the aliases. We *don't* want inference there! +class AliasTree before rep after | before rep -> after where + parseAliasTree :: AliasList before a -> (Aliases rep a, AliasList after a) + +-- +instance (AssertNamesAreEqual name name', KnownSymbol name') => AliasTree (name : names) (S1 ('MetaSel (Just name') x y z) v) names where + parseAliasTree (Cons _ a rest) = (Field a, rest) + +instance MissingAlias name' => AliasTree '[] (S1 ('MetaSel (Just name') x y z) v) '[] + +instance (AliasTree before left middle, AliasTree middle right end) => AliasTree before (left :*: right) end where + parseAliasTree as = + let (left, middle) = parseAliasTree @before as + (right, end) = parseAliasTree @middle middle + in (FieldTree left right, end) + +instance AliasTree before tree '[] => AliasTree before (D1 x (C1 y tree)) '[] where + parseAliasTree as = + let (aliases', as') = parseAliasTree as + in (Record aliases', as') + +-- doesn't work because of the functional dependency :( +-- instance ExcessAliasError name => AliasTree before (D1 x (C1 y tree)) (name : names) where + +-- +instance (AssertNamesAreEqual name name', KnownSymbol name') => AliasTree (name : names) (C1 ('MetaCons name' fixity False) slots) names where + parseAliasTree (Cons _ a rest) = (Branch a, rest) + +instance MissingAlias name' => AliasTree '[] (C1 ('MetaCons name' fixity False) slots) '[] + +instance (AliasTree before left middle, AliasTree middle right end) => AliasTree before (left :+: right) end where + parseAliasTree as = + let (left, middle) = parseAliasTree @before as + (right, end) = parseAliasTree @middle middle + in (BranchTree left right, end) + +instance AliasTree before (left :+: right) '[] => AliasTree before (D1 x (left :+: right)) '[] where + parseAliasTree as = + let (aliases', as') = parseAliasTree as + in (Sum aliases', as') + +-- doesn't work because of the functional dependency :( +-- instance ExcessAliasError name => AliasTree before (D1 x (left :+: right)) (name : names) where + +-- | Typeclass for datatypes @r@ that have aliases for some 'Rubric' @k@. +type Aliased :: k -> Type -> Constraint +class (Rubric k, Generic r) => Aliased k r where + aliases :: Aliases (Rep r) (AliasType k) + +-- | Typeclass for marker datakinds used as rubrics, for classifying aliases according to their use. +-- +-- The associated type family `AliasType` gives the type of the aliases. +-- +-- 'Rubric's are needed when defining helper newtypes for use with @-XDerivingVia@. Because +-- 'Aliases' are defined at the value level, we need a way to relate the aliases with +-- the datatype during deriving. + +-- If you are using 'Aliases' in standalone functions (possibly in combination with +-- 'GRecord' and 'GSum') you might not need to define a 'Rubric'. +type Rubric :: k -> Constraint +class Rubric k where + type AliasType k :: Type + +class GHasDatatypeName rep where + gGetDatatypeName :: String + +instance KnownSymbol datatypeName => GHasDatatypeName (D1 (MetaData datatypeName m p nt) (C1 y prod)) where + gGetDatatypeName = symbolVal (Proxy @datatypeName) + +class GHasFieldNames rep where + gGetFieldNames :: Aliases rep String + + +instance GHasFieldNames prod => GHasFieldNames (D1 x (C1 y prod)) where + gGetFieldNames = Record (gGetFieldNames @prod) + +instance KnownSymbol fieldName => GHasFieldNames (S1 ('MetaSel ('Just fieldName) unpackedness strictness laziness) (Rec0 v)) where + gGetFieldNames = Field (symbolVal (Proxy @fieldName)) + +instance + (GHasFieldNames left, GHasFieldNames right) => + GHasFieldNames (left :*: right) + where + gGetFieldNames = FieldTree (gGetFieldNames @left) (gGetFieldNames @right) + + +class GHasBranchNames rep where + gGetBranchNames :: Aliases rep String + +instance + (GHasBranchNames (left :+: right)) => + GHasBranchNames (D1 x (left :+: right)) + where + gGetBranchNames = Sum (gGetBranchNames @(left :+: right)) + +instance + ( GHasBranchNames left, + GHasBranchNames right + ) => + GHasBranchNames (left :+: right) + where + gGetBranchNames = BranchTree (gGetBranchNames @left) (gGetBranchNames @right) + +instance KnownSymbol branchName => GHasBranchNames (C1 ('MetaCons branchName fixity sels) y) where + gGetBranchNames = Branch (symbolVal (Proxy @branchName)) + +-- +-- +class GRecord (c :: Type -> Constraint) rep where + gToRecord :: + Applicative m => + Aliases rep a -> + (forall v. c v => a -> m v) -> + m (rep z) + gFromRecord :: + Aliases rep a -> + (forall v. c v => a -> v -> o) -> + rep z -> + Aliases rep o + gRecordEnum :: + Aliases rep a -> + (forall v. c v => Proxy v -> o) -> + Aliases rep (a, o) + +instance GRecord c prod => GRecord c (D1 x (C1 y prod)) where + gToRecord (Record as) parseField = + M1 . M1 <$> gToRecord @c as parseField + gFromRecord (Record as) renderField (M1 (M1 prod)) = + Record (gFromRecord @c as renderField prod) + gRecordEnum (Record as) renderField = Record (gRecordEnum @c @prod as renderField) + +instance c v => GRecord c (S1 x (Rec0 v)) where + gToRecord (Field a) parseField = + M1 . K1 <$> parseField a + gFromRecord (Field a) renderField (M1 (K1 v)) = Field ( renderField a v ) + gRecordEnum (Field a) renderField = Field (a, renderField (Proxy @v)) + +instance + (GRecord c left, GRecord c right) => + GRecord c (left :*: right) + where + gToRecord (FieldTree aleft aright) parseField = + (:*:) <$> gToRecord @c aleft parseField <*> gToRecord @c aright parseField + gFromRecord (FieldTree aleft aright) renderField (left :*: right) = + FieldTree (gFromRecord @c aleft renderField left) (gFromRecord @c aright renderField right) + gRecordEnum (FieldTree aleft aright) renderField = + FieldTree (gRecordEnum @c @left aleft renderField) (gRecordEnum @c @right aright renderField) + +-- +-- +data Slots m1 m2 v + = ZeroSlots v + | SingleSlot (m1 v) + | ManySlots (m2 v) + deriving stock (Show, Functor) + +class GSum (c :: Type -> Constraint) rep where + gToSum :: + (Functor n, Applicative m2) => + Aliases rep a -> + (forall b. a -> Slots m1 m2 b -> n b) -> + (forall v. c v => m1 v) -> + (forall v. c v => m2 v) -> + Aliases rep (n (rep z)) + gFromSum :: + Aliases rep a -> + (forall v. c v => v -> o) -> + rep z -> + (a, [o]) + gSumEnum :: + Aliases rep a -> + (forall v. c v => Proxy v -> o) -> + Aliases rep (a, [o]) + +instance + (GSum c (left :+: right)) => + GSum c (D1 x (left :+: right)) + where + gToSum (Sum s) parseBranch parseSlot1 parseSlot2 = Sum (fmap M1 <$> gToSum @c s parseBranch parseSlot1 parseSlot2) + gFromSum (Sum s) renderSlot (M1 srep) = gFromSum @c s renderSlot srep + gSumEnum (Sum s) renderSlot = Sum (gSumEnum @c @_ @_ @_ s renderSlot) + +instance + ( GSum c left, + GSum c right + ) => + GSum c (left :+: right) + where + gToSum (BranchTree aleft aright) parseBranch parseSlot1 parseSlot2 = + BranchTree (fmap L1 <$> gToSum @c @left aleft parseBranch parseSlot1 parseSlot2) (fmap R1 <$> gToSum @c @right aright parseBranch parseSlot1 parseSlot2) + gFromSum (BranchTree aleft aright) renderSlot = \case + L1 rleft -> gFromSum @c aleft renderSlot rleft + R1 rright -> gFromSum @c aright renderSlot rright + gSumEnum (BranchTree aleft aright) renderSlot = + BranchTree (gSumEnum @c aleft renderSlot) (gSumEnum @c aright renderSlot) + +instance GSum c (C1 x U1) where + gToSum (Branch fieldName) parseBranch parseSlot1 parseSlot2 = + Branch (parseBranch fieldName (ZeroSlots (M1 U1))) + gFromSum (Branch fieldName) renderSlot _ = + (fieldName, []) + gSumEnum (Branch fieldName) renderSlot = + Branch (fieldName, []) + +instance (c v) => GSum c (C1 x (S1 y (Rec0 v))) where + gToSum (Branch fieldName) parseBranch parseSlot1 parseSlot2 = + Branch (M1 . M1 . K1 <$> parseBranch fieldName (SingleSlot parseSlot1)) + gFromSum (Branch fieldName) renderSlot (M1 (M1 (K1 slots))) = + (fieldName, [renderSlot slots]) + gSumEnum (Branch fieldName) renderSlot = + Branch (fieldName, [renderSlot (Proxy @v)]) + +instance (GSumSlots c (left :*: right)) => GSum c (C1 x (left :*: right)) where + gToSum (Branch fieldName) parseBranch parseSlot1 parseSlot2 = + Branch (M1 <$> parseBranch fieldName (ManySlots (gToSumSlots @c parseSlot2))) + gFromSum (Branch fieldName) renderSlot (M1 slots) = + (fieldName, gFromSumSlots @c renderSlot slots) + gSumEnum (Branch fieldName) renderSlot = + Branch (fieldName, gSumEnumSlots @c @(left :*: right) renderSlot) + +class GSumSlots (c :: Type -> Constraint) rep where + gToSumSlots :: + Applicative m => + (forall v. c v => m v) -> + m (rep z) + gFromSumSlots :: (forall v. c v => v -> o) -> rep z -> [o] + gSumEnumSlots :: (forall v. c v => Proxy v -> o) -> [o] + +instance c v => GSumSlots c (S1 y (Rec0 v)) where + gToSumSlots parseSlot = M1 . K1 <$> parseSlot + gFromSumSlots renderSlot (M1 (K1 v)) = [renderSlot v] + gSumEnumSlots renderSlot = [renderSlot (Proxy @v)] + +instance + ( GSumSlots c left, + GSumSlots c right + ) => + GSumSlots c (left :*: right) + where + gToSumSlots parseSlot = + (:*:) <$> gToSumSlots @c @left parseSlot <*> gToSumSlots @c @right parseSlot + gFromSumSlots renderSlot (left :*: right) = + gFromSumSlots @c renderSlot left ++ gFromSumSlots @c renderSlot right + gSumEnumSlots renderSlot = + gSumEnumSlots @c @left renderSlot ++ gSumEnumSlots @c @right renderSlot diff --git a/lib/ByOtherNames/TH.hs b/lib/ByOtherNames/TH.hs new file mode 100644 --- /dev/null +++ b/lib/ByOtherNames/TH.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +-- | This module provides a quasiquoter which makes it a bit easier to define +-- lists of textual aliases. +-- +-- >>> :{ +-- data Foo = Foo {xa :: Int, xb :: Bool, xc :: Char, xd :: String, xe :: Int} +-- deriving stock (Read, Show, Eq, Generic) +-- deriving (FromJSON, ToJSON) via (JSONRecord "obj" Foo) +-- instance Aliased JSON Foo where +-- aliases = [aliasList| +-- xa = "aax", +-- xb = "bbx", +-- xc = "ccx", +-- xd = "ddx", +-- xe = "eex", +-- |] +-- :} +-- +-- +module ByOtherNames.TH (aliasList) where + +import Control.Applicative +import Control.Monad +import GHC.Read +import Language.Haskell.TH +import qualified Language.Haskell.TH as TH +import Language.Haskell.TH.Quote +import Text.ParserCombinators.ReadP +import Text.ParserCombinators.ReadPrec +import Text.Read.Lex (Lexeme (..)) + +-- if you are only interested in defining a quasiquoter to be used for +-- expressions, you would define a QuasiQuoter with only quoteExp, and leave +-- the other fields stubbed out with errors. +aliasList :: QuasiQuoter +aliasList = + QuasiQuoter + { quoteExp = quoteExp', + quotePat = error "can only be used as expression", + quoteType = error "can only be used as expression", + quoteDec = error "can only be used as expression" + } + +quoteExp' :: String -> Q Exp +quoteExp' input = do + let parsed = readPrec_to_S parseManyAlias 0 input + case parsed of + _ : _ : _ -> fail "ambiguous parse" + [] -> fail "couldn't parse" + (pairs, _) : _ -> + pure $ TH.AppE (VarE (mkName "aliasListBegin")) $ + foldr addAlias (VarE (mkName "aliasListEnd")) pairs + where + addAlias (fieldName, fieldAlias) = + TH.AppE $ + VarE (mkName "alias") `TH.AppTypeE` LitT (StrTyLit fieldName) `TH.AppE` LitE (StringL fieldAlias) + +parseManyAlias :: ReadPrec [(String, String)] +parseManyAlias = do + pairs <- + sepEndBy1 + parseAlias + ( do + Punc punc <- lexP + guard (punc == ",") + ) + lift skipSpaces + lift eof + return pairs + +parseAlias :: ReadPrec (String, String) +parseAlias = do + Ident name <- lexP + Punc punc <- lexP + guard (punc == "=") + String theAlias <- lexP + return (name, theAlias) + +-- how to use standard ReadP combinators here? +-- +-- https://hackage.haskell.org/package/parser-combinators + +-- | @'sepEndBy' p sep@ parses /zero/ or more occurrences of @p@, separated +-- and optionally ended by @sep@. Returns a list of values returned by @p@. +sepEndBy :: Alternative m => m a -> m sep -> m [a] +sepEndBy p sep = sepEndBy1 p sep <|> pure [] +{-# INLINE sepEndBy #-} + +-- | @'sepEndBy1' p sep@ parses /one/ or more occurrences of @p@, separated +-- and optionally ended by @sep@. Returns a list of values returned by @p@. +sepEndBy1 :: Alternative m => m a -> m sep -> m [a] +sepEndBy1 p sep = liftA2 (:) p ((sep *> sepEndBy p sep) <|> pure []) +{-# INLINEABLE sepEndBy1 #-} + +-- $setup +-- +-- >>> :set -XBlockArguments +-- >>> :set -XTypeApplications +-- >>> :set -XDerivingStrategies +-- >>> :set -XDerivingVia +-- >>> :set -XDataKinds +-- >>> :set -XMultiParamTypeClasses +-- >>> :set -XDeriveGeneric +-- >>> :set -XOverloadedStrings +-- >>> :set -XTemplateHaskell +-- >>> :set -XQuasiQuotes +-- >>> import ByOtherNames.Aeson +-- >>> import ByOtherNames.TH +-- >>> import Data.Aeson +-- >>> import Data.Aeson.Types +-- >>> import GHC.Generics +-- >>> import GHC.TypeLits diff --git a/tests/doctests.hs b/tests/doctests.hs new file mode 100644 --- /dev/null +++ b/tests/doctests.hs @@ -0,0 +1,9 @@ +module Main where +import Test.DocTest +main = doctest [ + "-ilib" + , "lib/ByOtherNames.hs" + , "lib/ByOtherNames/Aeson.hs" + , "lib/ByOtherNames/TH.hs" + , "lib/ByOtherNames/Constraint.hs" + ] diff --git a/tests/tests.hs b/tests/tests.hs new file mode 100644 --- /dev/null +++ b/tests/tests.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Main where + +import ByOtherNames +import ByOtherNames.Aeson + ( Aliased, + JSONRecord (..), + JSONRubric (JSON), + JSONSum (..), + alias, + aliasListBegin, + aliasListEnd, + aliases, + ) +import ByOtherNames.TH +import Control.Monad (forM) +import Data.Aeson +import Data.Aeson.Types +import Data.Foldable +import Data.Typeable +import GHC.Generics +import GHC.TypeLits +import Test.Tasty +import Test.Tasty.HUnit + +data Foo = Foo {aa :: Int, bb :: Bool, cc :: Char, dd :: String, ee :: Int} + deriving (Read, Show, Eq, Generic) + deriving (FromJSON, ToJSON) via (JSONRecord "obj" Foo) + +instance Aliased JSON Foo where + aliases = + aliasListBegin + . alias @"aa" "aax" + . alias @"bb" "bbx" + . alias @"cc" "ccx" + . alias @"dd" "ddx" + . alias @"ee" "eex" + $ aliasListEnd + +enumFoo :: [(Key, TypeRep)] +enumFoo = + Data.Foldable.toList $ + gRecordEnum @Typeable @(Rep Foo) + ( aliasListBegin + . alias @"aa" "aax" + . alias @"bb" "bbx" + . alias @"cc" "ccx" + . alias @"dd" "ddx" + . alias @"ee" "eex" + $ aliasListEnd + ) + typeRep + +expectedEnumFoo :: [(Key, TypeRep)] +expectedEnumFoo = + [ ("aax", typeRep (Proxy @Int)), + ("bbx", typeRep (Proxy @Bool)), + ("ccx", typeRep (Proxy @Char)), + ("ddx", typeRep (Proxy @String)), + ("eex", typeRep (Proxy @Int)) + ] + +data FooTH = FooTH {xa :: Int, xb :: Bool, xc :: Char, xd :: String, xe :: Int} + deriving (Read, Show, Eq, Generic) + deriving (FromJSON, ToJSON) via (JSONRecord "obj" FooTH) + +instance Aliased JSON FooTH where + aliases = + [aliasList| + xa = "aax", + xb = "bbx", + xc = "ccx", + xd = "ddx", + xe = "eex", + |] + +data Summy + = Aa Int + | Bb Bool + | Cc + | Dd Char Bool Int + | Ee Int + deriving (Read, Show, Eq, Generic) + deriving (FromJSON, ToJSON) via (JSONSum "sum" Summy) + +instance Aliased JSON Summy where + aliases = + aliasListBegin + . alias @"Aa" "Aax" + . alias @"Bb" "Bbx" + . alias @"Cc" "Ccx" + . alias @"Dd" "Ddx" + . alias @"Ee" "Eex" + $ aliasListEnd + +enumSummy :: [(Key, [TypeRep])] +enumSummy = + Data.Foldable.toList $ + gSumEnum @Typeable @(Rep Summy) + ( aliasListBegin + . alias @"Aa" "Aax" + . alias @"Bb" "Bbx" + . alias @"Cc" "Ccx" + . alias @"Dd" "Ddx" + . alias @"Ee" "Eex" + $ aliasListEnd + ) + typeRep + +expectedEnumSummy :: [(Key, [TypeRep])] +expectedEnumSummy = + [ ("Aax", [typeRep (Proxy @Int)]), + ("Bbx", [typeRep (Proxy @Bool)]), + ("Ccx", []), + ("Ddx", [typeRep (Proxy @Char), typeRep (Proxy @Bool), typeRep (Proxy @Int)]), + ("Eex", [typeRep (Proxy @Int)]) + ] + +-- >>> enumSummy + +roundtrip :: forall t. (Eq t, Show t, FromJSON t, ToJSON t) => t -> IO () +roundtrip t = + let reparsed = parseEither parseJSON (toJSON t) + in case reparsed of + Left err -> assertFailure err + Right t' -> assertEqual "" t t' + +data SingleField = SingleField {single :: Int} + deriving (Read, Show, Eq, Generic) + deriving (FromJSON, ToJSON) via (JSONRecord "sng" SingleField) + +instance Aliased JSON SingleField where + aliases = + aliasListBegin + . alias @"single" "Aa" + $ aliasListEnd + +-- data SingleBranch = SingleBranch Int +-- deriving (Read, Show, Eq, Generic) +-- deriving (FromJSON, ToJSON) via (JSONSum "sng" SingleBranch) + +-- instance Aliased JSON SingleBranch where +-- aliases = +-- branchAliases +-- $ alias (Proxy @"SingleBranch") "Aa" +-- $ aliasListEnd + +-- +-- +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = + testGroup + "All" + [ testCase "recordRoundtrip" $ roundtrip $ Foo 0 False 'f' "foo" 3, + testCase "recordRoundtripSingle" $ roundtrip $ SingleField 3, + testGroup + "sumRoundtrip" + [ testCase "a" $ roundtrip $ Aa 5, + testCase "b" $ roundtrip $ Bb False, + testCase "c" $ roundtrip $ Cc, + testCase "d" $ roundtrip $ Dd 'f' True 0, + testCase "e" $ roundtrip $ Ee 3 + ], + testGroup + "enums" + [ testCase "prod typeReps" $ assertEqual "prod typeReps match" expectedEnumFoo enumFoo, + testCase "sum typeReps" $ assertEqual "sum typeReps match" expectedEnumSummy enumSummy + ] + ]