Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Already on GitHub? Sign in to your account

deriveJSON's generated instances have awkward contexts #137

Closed
russetkoala opened this Issue Aug 9, 2013 · 7 comments

Comments

Projects
None yet
6 participants

Motivating example:

{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
import Data.Aeson

data Tagged s = Tagged { tag :: Tag s
                       }

class (FromJSON (Tag s), ToJSON (Tag s)) => C s where
    type Tag s
    fromTag :: Tag s -> Tagged s

instance C s => ToJSON (Tagged s) where
    toJSON = toJSON . tag

instance C s => FromJSON (Tagged s) where
    parseJSON = fmap fromTag . parseJSON

data Foo s = Spam (Tagged s) | Eggs

It would be nice to be able to use deriveJSON to generate ToJSON and FromJSON instances for Foo. However, attempting to do so produces instances that look like this:

instance ToJSON s => ToJSON (Foo s) where
    ...

but there's no need to have a ToJSON constraint on Foo's parameter: ToJSON (Tagged s) suffices.

For this example, it would be enough for deriveJSON to just not inspect the parameter to the constructor deeply: for an ADT data A p_1 p_2 ... = A a_1 a_2 ... | B b_1 ... | ..., the generated instances look like instance (ToJSON a_1, ToJSON a_2, ToJSON b_1, ...) => ToJSON (A p_1 p_2 ...). I -think- this will work for all ADTs, but I am not sure about GADTs. A general solution would be adding a field to Options to control how the instance constraints are generated, presumably of type [Name] -> [Cxt].

Owner

bos commented Sep 4, 2013

cc @basvandijk, I wash my hands of TH-related problems :-\

@bos bos closed this Sep 4, 2013

@bos bos reopened this Sep 4, 2013

Owner

bos commented Sep 4, 2013

Oops, didn't mean to close this, sorry.

Collaborator

basvandijk commented Sep 5, 2013

Yes this would be a nice generalization. Currently the TH deriver adds ToJSON or FromJSON constraints to all type variables regardless whether they're actually needed.

I'm not sure it's a good idea to add a field to the encoding Options which controls the constraints like: [Name] -> [Cxt] because it could be misused. Ideally the TH deriver detects which variables need constraints automatically.

I currently don't have time to implement that. So patches are warmly appreciated ;-)

spointy commented Oct 8, 2013

diff --git a/Data/Aeson/TH.hs b/Data/Aeson/TH.hs
index 4969271..4729eb2 100644
--- a/Data/Aeson/TH.hs
+++ b/Data/Aeson/TH.hs
@@ -90,7 +90,7 @@ import Data.Aeson.Types ( Value(..), Parser
 -- from base:
 import Control.Applicative ( pure, (<$>), (<*>) )
 import Control.Monad       ( return, mapM, liftM2, fail )
-import Data.Bool           ( Bool(False, True), otherwise, (&&) )
+import Data.Bool           ( Bool(False, True), otherwise, (&&), (||) )
 import Data.Eq             ( (==) )
 import Data.Function       ( ($), (.) )
 import Data.Functor        ( fmap )
@@ -98,9 +98,11 @@ import Data.Int            ( Int )
 import Data.Either         ( Either(Left, Right) )
 import Data.List           ( (++), foldl, foldl', intercalate
                            , length, map, zip, genericLength, all, partition
+                           , filter, nub
                            )
 import Data.Maybe          ( Maybe(Nothing, Just), catMaybes )
-import Prelude             ( String, (-), Integer, fromIntegral, error )
+import Prelude             ( String, (-), Integer, fromIntegral, error, flip
+                           , snd, (=<<) )
 import Text.Printf         ( printf )
 import Text.Show           ( show )
 #if __GLASGOW_HASKELL__ < 700
@@ -165,7 +167,7 @@ deriveToJSON opts name =
   where
     fromCons :: [TyVarBndr] -> [Con] -> Q Dec
     fromCons tvbs cons =
-        instanceD (return $ map (\t -> ClassP ''ToJSON [VarT t]) typeNames)
+        instanceD (return $ map (\t -> ClassP ''ToJSON [t]) neededInstances)
                   (classType `appT` instanceType)
                   [ funD 'toJSON
                          [ clause []
@@ -177,6 +179,10 @@ deriveToJSON opts name =
         classType = conT ''ToJSON
         typeNames = map tvbName tvbs
         instanceType = foldl' appT (conT name) $ map varT typeNames
+        neededInstances =
+          if clevererConstraints opts
+            then nub $ filter hasUnboundName $ getNecessaryInstances =<< cons
+            else map VarT typeNames

 -- | Generates a lambda expression which encodes the given data type as JSON.
 mkToJSON :: Options -- ^ Encoding options.
@@ -214,6 +220,27 @@ consToJSON opts cons = do
               ]
         | otherwise = [encodeArgs opts True con | con <- cons]

+-- | Which types a constructor is directly built from.
+getNecessaryInstances :: Con -> [Type]
+getNecessaryInstances (ForallC _ _ _) = error $ "Data,Aesib,TH.getNecessaryInstances: "
+                                               ++ "Oops, I don't know how to do quantified constructors."
+getNecessaryInstances (NormalC _ typs) = map snd typs
+getNecessaryInstances (RecC _ ntyps) = map (\ (_, _, t) -> t) ntyps
+getNecessaryInstances (InfixC a _ b) = [snd a, snd b]
+
+-- | Does the type have a free type variable appearing in it?
+hasUnboundName :: Type -> Bool
+hasUnboundName (ForallT _ _ _) = error $ "Data,Aesib,TH.hasUnboundName: "
+                                               ++ "Oops, I don't know how to do quantification."
+hasUnboundName (VarT _) = True
+hasUnboundName (ConT _) = False
+hasUnboundName (TupleT _) = False
+hasUnboundName (UnboxedTupleT _) = False
+hasUnboundName ArrowT = False
+hasUnboundName ListT = False
+hasUnboundName (AppT a b) = hasUnboundName a || hasUnboundName b
+hasUnboundName (SigT a _) = hasUnboundName a
+
 conStr :: Options -> Name -> Q Exp
 conStr opts = appE [|String|] . conTxt opts

@@ -372,7 +399,7 @@ deriveFromJSON opts name =
   where
     fromCons :: [TyVarBndr] -> [Con] -> Q Dec
     fromCons tvbs cons =
-        instanceD (return $ map (\t -> ClassP ''FromJSON [VarT t]) typeNames)
+        instanceD (return $ map (\t -> ClassP ''FromJSON [t]) neededInstances)
                   (classType `appT` instanceType)
                   [ funD 'parseJSON
                          [ clause []
@@ -384,6 +411,10 @@ deriveFromJSON opts name =
         classType = conT ''FromJSON
         typeNames = map tvbName tvbs
         instanceType = foldl' appT (conT name) $ map varT typeNames
+        neededInstances =
+          if clevererConstraints opts
+            then nub $ filter hasUnboundName $ getNecessaryInstances =<< cons
+            else map VarT typeNames

 -- | Generates a lambda expression which parses the JSON encoding of the given
 -- data type.
diff --git a/Data/Aeson/Types/Internal.hs b/Data/Aeson/Types/Internal.hs
index f1a6442..bc68031 100644
--- a/Data/Aeson/Types/Internal.hs
+++ b/Data/Aeson/Types/Internal.hs
@@ -268,6 +268,11 @@ data Options = Options
       -- object will include those fields mapping to @null@.
     , sumEncoding :: SumEncoding
       -- ^ Specifies how to encode constructors of a sum datatype.
+    , clevererConstraints :: Bool
+      -- ^ Generate constraints based on the structure of the type if
+      -- 'True'. If 'False', it will generate a constraint for each
+      -- parameter. Currently it doesn't know how to deal with constraints,
+      -- 'forall's or recursive types.
     }

 -- | Specifies how to encode constructors of a sum datatype.
@@ -313,6 +318,7 @@ defaultOptions = Options
                  , allNullaryToStringTag   = True
                  , omitNothingFields       = False
                  , sumEncoding             = defaultTaggedObject
+                 , clevererConstraints     = False
                  }

 -- | Default 'TaggedObject' 'SumEncoding' options:
diff --git a/aeson.cabal b/aeson.cabal
index 468cd70..ba16d56 100644
--- a/aeson.cabal
+++ b/aeson.cabal
@@ -178,6 +178,26 @@ test-suite tests
     vector,
     ghc-prim >= 0.2

+test-suite th-deriving-tests
+  type:           exitcode-stdio-1.0
+  hs-source-dirs: tests
+  main-is:        Deriving.hs
+  ghc-options:
+    -Wall -fno-warn-unused-binds -threaded -rtsopts
+
+  build-depends:
+    aeson,
+    attoparsec,
+    base,
+    containers,
+    bytestring,
+    template-haskell,
+    text,
+    time,
+    unordered-containers,
+    vector,
+    ghc-prim >= 0.2
+
 source-repository head
   type:     git
   location: git://github.com/bos/aeson.git
diff --git a/tests/Deriving.hs b/tests/Deriving.hs
index e69de29..a0b790e 100644
--- a/tests/Deriving.hs
+++ b/tests/Deriving.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE TemplateHaskell, FlexibleContexts, TypeFamilies, UndecidableInstances #-}
+import Data.Aeson
+import Data.Aeson.TH
+
+data Tagged s = Tagged { tag :: Tag s
+                       }
+
+class (FromJSON (Tag s), ToJSON (Tag s)) => C s where
+    type Tag s
+    fromTag :: Tag s -> Tagged s
+
+instance C s => ToJSON (Tagged s) where
+    toJSON = toJSON . tag
+
+instance C s => FromJSON (Tagged s) where
+    parseJSON = fmap fromTag . parseJSON
+
+data Foo s a p = Spam (Tagged s) | Eggs | Beans a Int | Bacon { streaky :: Bool } | Foo s a p :+ Foo s a p
+
+deriveToJSON defaultOptions { clevererConstraints = True } ''Foo
+deriveFromJSON defaultOptions { clevererConstraints = True } ''Foo
+
+--if we compile, we're golden!
+main :: IO ()
+main = return ()

Patch for a naive implementation, turn-on-able by an Option field and off by default.

Collaborator

bergmark commented May 9, 2016

Is there anything here that #346 did not resolve?

@bergmark bergmark added the info needed label May 9, 2016

Contributor

RyanGlScott commented May 9, 2016 edited

#346 wasn't aimed to fix this. The criterion it uses for determining whether a type variable should have a ToJSON/FromJSON context is quite naïve: it just checks if it has kind *. So the above example would still have a spurious ToJSON/FromJSON context (unless PolyKinds is enabled).

There are many more awkward corner cases to consider when deriving instance contexts, and I certainly don't want to write the code that mimics what GHC currently does, since it's quite complex. (See also mboes/th-lift#20 (comment))

Collaborator

bergmark commented May 9, 2016

Thanks for the clarification!

Let's just close this then, the issue has been open for 3 years so it does not seem like a high priority.

@bergmark bergmark closed this May 9, 2016

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment