From 096379c8e42cef85f6874c769e98f716351c671f Mon Sep 17 00:00:00 2001 From: Jonathan Lorimer Date: Mon, 10 Jul 2023 19:03:17 -0400 Subject: [PATCH 1/4] initial work --- src/Language/PureScript/Bridge/SumType.hs | 58 ++++++++++++++++------- 1 file changed, 41 insertions(+), 17 deletions(-) diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs index ec2b00f5..ff5f8e29 100644 --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -6,14 +6,15 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} module Language.PureScript.Bridge.SumType ( SumType (..) , mkSumType + , mkSumTypeWith , equal - , order - , DataConstructor (..) + , order , DataConstructor (..) , RecordEntry (..) , Instance (..) , nootype @@ -65,6 +66,16 @@ mkSumType p = SumType (mkTypeInfo p) constructors (Encode : Decode : EncodeJson where constructors = gToConstructors (from (undefined :: t)) +mkSumTypeWith + :: forall t + . (Generic t, Typeable t, GDataConstructor (Rep t)) + => DataConstructorOpts + -> Proxy t + -> SumType 'Haskell +mkSumTypeWith opts p = SumType (mkTypeInfo p) constructors (Encode : Decode : EncodeJson : DecodeJson : Generic : maybeToList (nootype constructors)) + where + constructors = gToConstructorsWithOpts opts (from (undefined :: t)) + -- | Purescript typeclass instances that can be generated for your Haskell types. data Instance = Encode | EncodeJson | Decode | DecodeJson | Generic | Newtype | Eq | Ord deriving (Eq, Show) @@ -104,22 +115,33 @@ data RecordEntry (lang :: Language) = RecordEntry } deriving (Eq, Show) +newtype DataConstructorOpts = + DataConstructorOpts + { _recLabelModifier :: String -> String } + +defaultDataConstructorOpts :: DataConstructorOpts +defaultDataConstructorOpts = + DataConstructorOpts + { _recLabelModifier = id } + class GDataConstructor f where + gToConstructorsWithOpts :: DataConstructorOpts -> f a -> [DataConstructor 'Haskell] + gToConstructors :: f a -> [DataConstructor 'Haskell] + gToConstructors = gToConstructorsWithOpts defaultDataConstructorOpts class GRecordEntry f where - gToRecordEntries :: f a -> [RecordEntry 'Haskell] + gToRecordEntriesWithOpts :: DataConstructorOpts -> f a -> [RecordEntry 'Haskell] instance (Datatype a, GDataConstructor c) => GDataConstructor (D1 a c) where - gToConstructors (M1 c) = gToConstructors c + gToConstructorsWithOpts opts (M1 c) = gToConstructorsWithOpts opts c instance (GDataConstructor a, GDataConstructor b) => GDataConstructor (a :+: b) where - gToConstructors (_ :: (a :+: b) f) = - gToConstructors (undefined :: a f) - ++ gToConstructors (undefined :: b f) + gToConstructorsWithOpts opts (_ :: (a :+: b) f) = + gToConstructorsWithOpts opts (undefined :: a f) ++ gToConstructorsWithOpts opts (undefined :: b g) instance (Constructor a, GRecordEntry b) => GDataConstructor (C1 a b) where - gToConstructors c@(M1 r) = + gToConstructorsWithOpts opts c@(M1 r) = [ DataConstructor { _sigConstructor = constructor , _sigValues = values @@ -129,21 +151,21 @@ instance (Constructor a, GRecordEntry b) => GDataConstructor (C1 a b) where constructor = T.pack $ conName c values = if conIsRecord c - then Right $ gToRecordEntries r - else Left $ map _recValue $ gToRecordEntries r + then Right $ gToRecordEntriesWithOpts opts r + else Left $ map _recValue $ gToRecordEntriesWithOpts opts r instance (GRecordEntry a, GRecordEntry b) => GRecordEntry (a :*: b) where - gToRecordEntries (_ :: (a :*: b) f) = - gToRecordEntries (undefined :: a f) - ++ gToRecordEntries (undefined :: b f) + gToRecordEntriesWithOpts opts (_ :: (a :*: b) f) = + gToRecordEntriesWithOpts opts (undefined :: a f) + ++ gToRecordEntriesWithOpts opts (undefined :: b f) instance GRecordEntry U1 where - gToRecordEntries _ = [] + gToRecordEntriesWithOpts _ _ = [] instance (Selector a, Typeable t) => GRecordEntry (S1 a (K1 R t)) where - gToRecordEntries e = + gToRecordEntriesWithOpts opts e = [ RecordEntry - { _recLabel = T.pack (selName e) + { _recLabel = T.pack $ _recLabelModifier opts (selName e) , _recValue = mkTypeInfo (Proxy :: Proxy t) } ] @@ -165,3 +187,5 @@ constructorToTypes (DataConstructor _ (Right rs)) ts = -- Lenses: makeLenses ''DataConstructor makeLenses ''RecordEntry +makeLenses ''DataConstructorOpts + From 9d61dcd9aeef22fa348c700488d5f42dfa631e24 Mon Sep 17 00:00:00 2001 From: Jonathan Lorimer Date: Mon, 10 Jul 2023 19:06:25 -0400 Subject: [PATCH 2/4] get rid of spurious instances --- src/Language/PureScript/Bridge/SumType.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs index ff5f8e29..577c06c8 100644 --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -6,8 +6,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeApplications #-} module Language.PureScript.Bridge.SumType ( SumType (..) From 8345bba64155a84c69143eae5929f6511fa34c56 Mon Sep 17 00:00:00 2001 From: Jonathan Lorimer Date: Mon, 10 Jul 2023 19:12:54 -0400 Subject: [PATCH 3/4] export opts --- src/Language/PureScript/Bridge/SumType.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs index 577c06c8..7f5cbfc2 100644 --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -12,7 +12,10 @@ module Language.PureScript.Bridge.SumType , mkSumType , mkSumTypeWith , equal - , order , DataConstructor (..) + , order + , DataConstructor (..) + , DataConstructorOpts (..) + , defaultDataConstructorOpts , RecordEntry (..) , Instance (..) , nootype From 865e6a9fe55aded1536c103fb8935b8cb636928e Mon Sep 17 00:00:00 2001 From: Jonathan Lorimer Date: Mon, 10 Jul 2023 19:17:55 -0400 Subject: [PATCH 4/4] export lens --- src/Language/PureScript/Bridge/SumType.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs index 7f5cbfc2..f486b161 100644 --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -27,6 +27,7 @@ module Language.PureScript.Bridge.SumType , sumTypeConstructors , recLabel , recValue + , recLabelModifier ) where import Control.Lens hiding (from, to)