pure-sum (empty) → 0.1.0.0
raw patch · 5 files changed
+364/−0 lines, 5 filesdep +basedep +hspecdep +hspec-core
Dependencies added: base, hspec, hspec-core, hspec-discover, pure-sum, text, text-manipulate
Files
- LICENSE +15/−0
- pure-sum.cabal +89/−0
- src/Data/Sum/Pure.hs +199/−0
- test/Data/Sum/PureSpec.hs +60/−0
- test/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,15 @@+ISC License++Copyright (c) 2022 Gautier DI FOLCO++Permission to use, copy, modify, and/or distribute this software for any+purpose with or without fee is hereby granted, provided that the above+copyright notice and this permission notice appear in all copies.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH+REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY+AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,+INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM+LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR+OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR+PERFORMANCE OF THIS SOFTWARE.
+ pure-sum.cabal view
@@ -0,0 +1,89 @@+cabal-version: 3.0+name: pure-sum+version: 0.1.0.0+author: Gautier DI FOLCO+maintainer: gautier.difolco@gmail.com+category: Data+build-type: Simple+license: ISC+license-file: LICENSE+synopsis: Derive fromString/toString-like for pure sum types+description: Derive fromString/toString-like for pure sum types.+Homepage: http://github.com/blackheaven/pure-sum/pure-sum+tested-with: GHC==9.6.3, GHC==9.4.8, GHC==9.2.8, GHC==9.0.2, GHC==8.10.7++library+ default-language: Haskell2010+ build-depends:+ base == 4.*+ , text == 2.*+ , text-manipulate == 0.*+ hs-source-dirs: src+ exposed-modules:+ Data.Sum.Pure+ other-modules:+ Paths_pure_sum+ autogen-modules:+ Paths_pure_sum+ default-extensions:+ DataKinds+ DefaultSignatures+ DeriveAnyClass+ DeriveGeneric+ DerivingStrategies+ DerivingVia+ DuplicateRecordFields+ FlexibleContexts+ GADTs+ GeneralizedNewtypeDeriving+ KindSignatures+ LambdaCase+ OverloadedLists+ OverloadedStrings+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ TypeApplications+ TypeFamilies+ TypeOperators+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints++test-suite spec+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules:+ Data.Sum.PureSpec+ Paths_pure_sum+ autogen-modules:+ Paths_pure_sum+ default-extensions:+ DataKinds+ DefaultSignatures+ DeriveAnyClass+ DeriveGeneric+ DerivingStrategies+ DerivingVia+ DuplicateRecordFields+ FlexibleContexts+ GADTs+ GeneralizedNewtypeDeriving+ KindSignatures+ LambdaCase+ OverloadedLists+ OverloadedStrings+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ TypeApplications+ TypeFamilies+ TypeOperators+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints+ build-depends:+ base+ , pure-sum+ , hspec+ , hspec-core+ , hspec-discover+ , text+ default-language: Haskell2010
+ src/Data/Sum/Pure.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module : Data.Sum.Pure+-- Copyright : Gautier DI FOLCO+-- License : BSD2+--+-- Maintainer : Gautier DI FOLCO <gautier.difolco@gmail.com>+-- Stability : Unstable+-- Portability : GHC+--+-- Derive fromText/toText-like for pure sum types.+module Data.Sum.Pure+ ( -- * Base type+ PureSumWith (..),+ PureSum,++ -- * from/to Text converters+ ToSumText (..),+ FromSumText (..),++ -- * Transformations+ Transformation (..),+ type (<<<),+ DropPrefix,+ CamelCase,+ PascalCase,+ SnakeCase,+ SpinalCase,+ TitleCase,+ TrainCase,+ )+where++import Control.Applicative ((<|>))+import Control.Monad (guard)+import Data.Kind+import Data.Maybe (fromMaybe)+import Data.Proxy+import qualified Data.Text as T+import qualified Data.Text.Manipulate as Manipulation+import GHC.Generics+import GHC.TypeError+import GHC.TypeLits++-- * Base interface++-- | Wrapper for derivation.+-- @transformation@ is a @Transformation@ applied during derivations+newtype PureSumWith transformation a = PureSumWith {unPureSumWith :: a}+ deriving stock (Eq, Ord, Show)++-- | Basic sum derivation+type PureSum = PureSumWith IdTransformation++class ToSumText a where+ toSumText :: a -> T.Text++class FromSumText a where+ fromSumText :: T.Text -> Maybe a++-- * Text Functions++-- | Convert a type into a @Text -> Text@ function+class Transformation a where+ transform :: Proxy a -> T.Text -> T.Text++-- | Apply no transformation (like @id@)+data IdTransformation++instance Transformation IdTransformation where+ transform _ = id++-- | Compose two transformations (e.g. @f << g@ is equivalent to @f (g x)@)+data f <<< g++instance (Transformation f, Transformation g) => Transformation (f <<< g) where+ transform _ = transform (Proxy @f) . transform (Proxy @g)++-- | @DropPrefix prefix@ (e.g. @DropPrefix "A"@ on "ACase" gives "Case")+data DropPrefix (s :: Symbol)++instance (KnownSymbol s) => Transformation (DropPrefix s) where+ transform _ x = fromMaybe x $ T.stripPrefix (T.pack $ symbolVal @s Proxy) x++-- | Change case (e.g. "camelCasedPhrase")+data CamelCase++instance Transformation CamelCase where+ transform _ = Manipulation.toCamel++-- | Change case (e.g. "PascalCasedPhrase")+data PascalCase++instance Transformation PascalCase where+ transform _ = Manipulation.toPascal++-- | Change case (e.g. "snake_cased_phrase")+data SnakeCase++instance Transformation SnakeCase where+ transform _ = Manipulation.toSnake++-- | Change case (e.g. "spinal-cased-phrase")+data SpinalCase++instance Transformation SpinalCase where+ transform _ = Manipulation.toSpinal++-- | Change case (e.g. "Title Cased Phrase")+data TitleCase++instance Transformation TitleCase where+ transform _ = Manipulation.toTitle++-- | Change case (e.g. "Train-Cased-Phrase")+data TrainCase++instance Transformation TrainCase where+ transform _ = Manipulation.toTrain++-- * Generic derivation++-- * ToSumText++instance+ (Transformation transformation, Generic a, GToSumText (Rep a)) =>+ ToSumText (PureSumWith transformation a)+ where+ toSumText = gToSumText (transform $ Proxy @transformation) . from . unPureSumWith++class GToSumText f where+ gToSumText :: (T.Text -> T.Text) -> f a -> T.Text++instance (GToSumText a) => GToSumText (M1 D meta a) where -- base type+ gToSumText transformation (M1 x) = gToSumText transformation x++instance (KnownSymbol cntr, EnsureEmpty a) => GToSumText (M1 C ('MetaCons cntr p b) a) where -- constructor+ gToSumText transformation (M1 _) = transformation $ T.pack $ symbolVal $ Proxy @cntr++instance (GToSumText a, GToSumText b) => GToSumText (a :+: b) where -- sum type+ gToSumText transformation (R1 x) = gToSumText transformation x+ gToSumText transformation (L1 x) = gToSumText transformation x++instance (NonSumTypeError) => GToSumText V1 where+ gToSumText _ _ = error "impossible"++-- * FromSumText++instance+ (Transformation transformation, Generic a, GFromSumText (Rep a)) =>+ FromSumText (PureSumWith transformation a)+ where+ fromSumText x = PureSumWith . to <$> gFromSumText (transform $ Proxy @transformation) x++class GFromSumText f where+ gFromSumText :: (T.Text -> T.Text) -> T.Text -> Maybe (f a)++instance+ (GFromSumText a) =>+ GFromSumText (M1 D ('MetaData typeName c i b) a) -- base type+ where+ gFromSumText transformation x = M1 <$> gFromSumText transformation x++instance+ (GFromSumText a, KnownSymbol cntr) =>+ GFromSumText (M1 C ('MetaCons cntr p b) a) -- constructor+ where+ gFromSumText transformation v =+ M1 <$> do+ let cntrName = transformation $ T.pack $ symbolVal (Proxy @cntr)+ guard $ v == cntrName+ gFromSumText transformation v++instance (GFromSumText a, GFromSumText b) => GFromSumText (a :+: b) where -- sumtype+ gFromSumText transformation v =+ (L1 <$> gFromSumText transformation v)+ <|> (R1 <$> gFromSumText transformation v)++instance GFromSumText U1 where+ gFromSumText _ _ = return U1++instance (NonSumTypeError) => GFromSumText V1 where+ gFromSumText _ _ = error "impossible"++instance (NonSumTypeError) => GFromSumText (M1 S meta a) where+ gFromSumText _ _ = error "impossible"++-- * Utils++type family EnsureEmpty a :: Constraint where+ EnsureEmpty U1 = ()+ EnsureEmpty a = NonSumTypeError++type NonSumTypeError :: Constraint+type NonSumTypeError = TypeError (Text "Only pure sum types are supported (constructor(s) without values)")
+ test/Data/Sum/PureSpec.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE StandaloneDeriving #-}++module Data.Sum.PureSpec+ ( main,+ spec,+ )+where++import Data.Proxy+import Data.Sum.Pure+import GHC.Generics+import Test.Hspec++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ it "toSumText on unchanged derivation should be literal" $+ toSumText A1 `shouldBe` "A1"+ it "fromSumText on unchanged derivation should work" $+ fromSumText "A1" `shouldBe` Just A1+ it "toSumText on changed derivation should be changed (composition order matter)" $+ toSumText PfAlphaThing2 `shouldBe` "alpha-thing2"+ it "toSumText on changed derivation should be changed (composition order does not matter)" $+ toSumText BetaThing2 `shouldBe` "beta-thing2"+ it "fromSumText on changed derivation should work (composition order matter)" $+ fromSumText "alpha-thing2" `shouldBe` Just PfAlphaThing2+ it "fromSumText on second element of a changed derivation should work (composition order does matter)" $+ fromSumText "beta-thing2" `shouldBe` Just BetaThing2+ it "fromSumText not bamthing should be @Nothing@" $+ fromSumText @X2 "unknown" `shouldBe` Nothing++-- * sandbox++--+-- data X0+-- deriving stock (Generic)+--+-- deriving via (PureSum X0) instance ToSumText X0+--+-- deriving via (PureSum X0) instance FromSumText X0++data X1 = A1+ deriving stock (Eq, Show, Generic)++deriving via (PureSum X1) instance ToSumText X1++deriving via (PureSum X1) instance FromSumText X1++data X2 = PfAlphaThing2 | BetaThing2+ deriving stock (Eq, Show, Generic)+ deriving (ToSumText, FromSumText) via (PureSumWith (DropPrefix "pf-" <<< SpinalCase) X2)++-- data X3 = A3 () | B3+-- deriving stock (Generic)+--+-- deriving via (PureSum X3) instance ToSumText X3+--+-- deriving via (PureSum X3) instance FromSumText X3
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}