Merge pull request haskell#346 from RyanGlScott/master

Revamp Template Haskell code for GHC 8.0
watashi · Jan 26, 2016 · 1e97747 · 1e97747
2 parents c67550d + 1bd2b05
commit 1e97747
Show file tree

Hide file tree

Showing 9 changed files with 474 additions and 113 deletions.
diff --git a/Data/Aeson/TH.hs b/Data/Aeson/TH.hs
diff --git a/tests/DataFamilies/Encoders.hs b/tests/DataFamilies/Encoders.hs
@@ -1,4 +1,5 @@
-{-# Language TemplateHaskell #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module DataFamilies.Encoders where
 
@@ -112,3 +113,26 @@ thApproxToEncodingDefault = $(mkToEncoding defaultOptions 'Approx)
 
 thApproxParseJSONDefault :: Value -> Parser (Approx String)
 thApproxParseJSONDefault = $(mkParseJSON defaultOptions 'Approx)
+
+--------------------------------------------------------------------------------
+-- GADT encoders/decoders
+--------------------------------------------------------------------------------
+
+thGADTToJSONUnwrap :: GADT String -> Value
+thGADTToJSONUnwrap = $(mkToJSON optsUnwrapUnaryRecords 'GADT)
+
+thGADTToEncodingUnwrap :: GADT String -> Encoding
+thGADTToEncodingUnwrap = $(mkToEncoding optsUnwrapUnaryRecords 'GADT)
+
+thGADTParseJSONUnwrap :: Value -> Parser (GADT String)
+thGADTParseJSONUnwrap = $(mkParseJSON optsUnwrapUnaryRecords 'GADT)
+
+
+thGADTToJSONDefault :: GADT String -> Value
+thGADTToJSONDefault = $(mkToJSON defaultOptions 'GADT)
+
+thGADTToEncodingDefault :: GADT String -> Encoding
+thGADTToEncodingDefault = $(mkToEncoding defaultOptions 'GADT)
+
+thGADTParseJSONDefault :: Value -> Parser (GADT String)
+thGADTParseJSONDefault = $(mkParseJSON defaultOptions 'GADT)
diff --git a/tests/DataFamilies/Instances.hs b/tests/DataFamilies/Instances.hs
@@ -1,10 +1,14 @@
-{-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module DataFamilies.Instances where
 
 import Control.Applicative
 import Data.Aeson.TH
+import Data.Aeson.Types (FromJSON(..))
 import DataFamilies.Types
 import Test.QuickCheck (Arbitrary(..), elements, oneof)
 import Prelude
@@ -22,6 +26,15 @@ instance Arbitrary a => Arbitrary (SomeType c () a) where
                       , Record  <$> arbitrary <*> arbitrary <*> arbitrary
                       ]
 
+instance Arbitrary (GADT String) where
+    arbitrary = GADT <$> arbitrary
+
 deriveJSON defaultOptions 'C1
 deriveJSON defaultOptions 'Nullary
 deriveJSON defaultOptions 'Approx
+
+deriveToJSON defaultOptions 'GADT
+-- We must write the FromJSON instance head ourselves
+-- due to the refined GADT return type
+instance FromJSON (GADT String) where
+    parseJSON = $(mkParseJSON defaultOptions 'GADT)
diff --git a/tests/DataFamilies/Properties.hs b/tests/DataFamilies/Properties.hs
@@ -36,12 +36,20 @@ tests = testGroup "data families" [
           , testProperty "TaggedObject" (toParseJSON thSomeTypeParseJSONTaggedObject thSomeTypeToJSONTaggedObject)
           , testProperty "ObjectWithSingleField" (toParseJSON thSomeTypeParseJSONObjectWithSingleField thSomeTypeToJSONObjectWithSingleField)
           ]
-       , testGroup "Approx" [
-            testProperty "string"                (isString                . thApproxToJSONUnwrap)
-          , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thApproxToJSONDefault)
-          , testGroup "roundTrip" [
-                testProperty "string"                (toParseJSON thApproxParseJSONUnwrap  thApproxToJSONUnwrap)
-              , testProperty "ObjectWithSingleField" (toParseJSON thApproxParseJSONDefault thApproxToJSONDefault)
+      , testGroup "Approx" [
+           testProperty "string"                (isString                . thApproxToJSONUnwrap)
+         , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thApproxToJSONDefault)
+         , testGroup "roundTrip" [
+               testProperty "string"                (toParseJSON thApproxParseJSONUnwrap  thApproxToJSONUnwrap)
+             , testProperty "ObjectWithSingleField" (toParseJSON thApproxParseJSONDefault thApproxToJSONDefault)
+           ]
+         ]
+      , testGroup "GADT" [
+          testProperty "string"                (isString                . thGADTToJSONUnwrap)
+        , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thGADTToJSONDefault)
+        , testGroup "roundTrip" [
+              testProperty "string"                (toParseJSON thGADTParseJSONUnwrap  thGADTToJSONUnwrap)
+            , testProperty "ObjectWithSingleField" (toParseJSON thGADTParseJSONDefault thGADTToJSONDefault)
             ]
           ]
         ]

diff --git a/tests/DataFamilies/Types.hs b/tests/DataFamilies/Types.hs
@@ -1,4 +1,8 @@
-{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module DataFamilies.Types where
 
@@ -23,3 +27,10 @@ newtype instance Approx a = Approx { fromApprox :: a }
 
 instance (ApproxEq a) => Eq (Approx a) where
     Approx a == Approx b = a =~ b
+
+data family GADT a
+data instance GADT a where
+    GADT :: { gadt :: String } -> GADT String
+
+deriving instance Eq   (GADT a)
+deriving instance Show (GADT a)
diff --git a/tests/Encoders.hs b/tests/Encoders.hs
@@ -1,4 +1,5 @@
-{-# Language TemplateHaskell #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Encoders where
 
@@ -173,3 +174,26 @@ gApproxToJSONDefault = genericToJSON defaultOptions
 
 gApproxParseJSONDefault :: Value -> Parser (Approx String)
 gApproxParseJSONDefault = genericParseJSON defaultOptions
+
+--------------------------------------------------------------------------------
+-- GADT encoders/decoders
+--------------------------------------------------------------------------------
+
+thGADTToJSONUnwrap :: GADT String -> Value
+thGADTToJSONUnwrap = $(mkToJSON optsUnwrapUnaryRecords ''GADT)
+
+thGADTToEncodingUnwrap :: GADT String -> Encoding
+thGADTToEncodingUnwrap = $(mkToEncoding optsUnwrapUnaryRecords ''GADT)
+
+thGADTParseJSONUnwrap :: Value -> Parser (GADT String)
+thGADTParseJSONUnwrap = $(mkParseJSON optsUnwrapUnaryRecords ''GADT)
+
+
+thGADTToJSONDefault :: GADT String -> Value
+thGADTToJSONDefault = $(mkToJSON defaultOptions ''GADT)
+
+thGADTToEncodingDefault :: GADT String -> Encoding
+thGADTToEncodingDefault = $(mkToEncoding defaultOptions ''GADT)
+
+thGADTParseJSONDefault :: Value -> Parser (GADT String)
+thGADTParseJSONDefault = $(mkParseJSON defaultOptions ''GADT)
diff --git a/tests/Instances.hs b/tests/Instances.hs
@@ -1,4 +1,8 @@
-{-# Language OverloadedStrings, RecordWildCards, StandaloneDeriving, CPP #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Instances where
@@ -160,6 +164,9 @@ instance Arbitrary a => Arbitrary (SomeType a) where
                       , Record  <$> arbitrary <*> arbitrary <*> arbitrary
                       ]
 
+instance Arbitrary (GADT String) where
+    arbitrary = GADT <$> arbitrary
+
 instance ApproxEq Char where
     (=~) = (==)
 

diff --git a/tests/Properties.hs b/tests/Properties.hs
@@ -180,6 +180,14 @@ tests = testGroup "properties" [
               , testProperty "ObjectWithSingleField" (toParseJSON thApproxParseJSONDefault thApproxToJSONDefault)
             ]
           ]
+        , testGroup "GADT" [
+            testProperty "string"                (isString                . thGADTToJSONUnwrap)
+          , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thGADTToJSONDefault)
+          , testGroup "roundTrip" [
+                testProperty "string"                (toParseJSON thGADTParseJSONUnwrap  thGADTToJSONUnwrap)
+              , testProperty "ObjectWithSingleField" (toParseJSON thGADTParseJSONDefault thGADTToJSONDefault)
+            ]
+          ]
         ]
       ]
     , testGroup "toEncoding" [

diff --git a/tests/Types.hs b/tests/Types.hs
@@ -1,5 +1,9 @@
-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE DeriveGeneric, StandaloneDeriving #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
 
 module Types where
 
@@ -54,6 +58,14 @@ data SomeType a = Nullary
                          , testThree :: Maybe a
                          } deriving (Eq, Show)
 
+data GADT a where
+    GADT :: { gadt :: String } -> GADT String
+  deriving Typeable
+
+deriving instance Data (GADT String)
+deriving instance Eq   (GADT a)
+deriving instance Show (GADT a)
+
 deriving instance Generic Foo
 deriving instance Generic UFoo
 deriving instance Generic OneConstructor