Merge pull request #1664 from RyanGlScott/master

Use DeriveLift to generate yesod-core's Lift instances

yesod-core/ChangeLog.md

@@ -4,6 +4,11 @@
 
 * Add functions for setting description and OG meta [#1663](https://github.com/yesodweb/yesod/pull/1663)
 
+* Use `DeriveLift` to implement the `Lift` instances for `ResourceTree`,
+  `Resource`, `Piece`, and `Dispatch`. Among other benefits, this provides
+  implementations of `liftTyped` on `template-haskell-2.16` (GHC 8.10) or
+  later. [#1664](https://github.com/yesodweb/yesod/pull/1664)
+
 ## 1.6.17.3
 
 * Support for `unliftio-core` 0.2

yesod-core/src/Yesod/Routes/TH/Types.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveLift #-}
 -- | Warning! This module is considered internal and may have breaking changes
 module Yesod.Routes.TH.Types
     ( -- * Data types
@@ -21,7 +21,7 @@ import Language.Haskell.TH.Syntax
 data ResourceTree typ
     = ResourceLeaf (Resource typ)
     | ResourceParent String CheckOverlap [Piece typ] [ResourceTree typ]
-    deriving (Show, Functor)
+    deriving (Lift, Show, Functor)
 
 resourceTreePieces :: ResourceTree typ -> [Piece typ]
 resourceTreePieces (ResourceLeaf r) = resourcePieces r
@@ -31,35 +31,24 @@ resourceTreeName :: ResourceTree typ -> String
 resourceTreeName (ResourceLeaf r) = resourceName r
 resourceTreeName (ResourceParent x _ _ _) = x
 
-instance Lift t => Lift (ResourceTree t) where
-    lift (ResourceLeaf r) = [|ResourceLeaf $(lift r)|]
-    lift (ResourceParent a b c d) = [|ResourceParent $(lift a) $(lift b) $(lift c) $(lift d)|]
-
 data Resource typ = Resource
     { resourceName :: String
     , resourcePieces :: [Piece typ]
     , resourceDispatch :: Dispatch typ
     , resourceAttrs :: [String]
     , resourceCheck :: CheckOverlap
     }
-    deriving (Show, Functor)
+    deriving (Lift, Show, Functor)
 
 type CheckOverlap = Bool
 
-instance Lift t => Lift (Resource t) where
-    lift (Resource a b c d e) = [|Resource a b c d e|]
-
 data Piece typ = Static String | Dynamic typ
-    deriving Show
+    deriving (Lift, Show)
 
 instance Functor Piece where
     fmap _ (Static s)  = Static s
     fmap f (Dynamic t) = Dynamic (f t)
 
-instance Lift t => Lift (Piece t) where
-    lift (Static s)  = [|Static  $(lift s)|]
-    lift (Dynamic t) = [|Dynamic $(lift t)|]
-
 data Dispatch typ =
     Methods
         { methodsMulti :: Maybe typ -- ^ type of the multi piece at the end
@@ -69,17 +58,12 @@ data Dispatch typ =
         { subsiteType :: typ
         , subsiteFunc :: String
         }
-    deriving Show
+    deriving (Lift, Show)
 
 instance Functor Dispatch where
     fmap f (Methods a b) = Methods (fmap f a) b
     fmap f (Subsite a b) = Subsite (f a) b
 
-instance Lift t => Lift (Dispatch t) where
-    lift (Methods Nothing b) = [|Methods Nothing $(lift b)|]
-    lift (Methods (Just t) b) = [|Methods (Just $(lift t)) $(lift b)|]
-    lift (Subsite t b) = [|Subsite $(lift t) $(lift b)|]
-
 resourceMulti :: Resource typ -> Maybe typ
 resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t
 resourceMulti _ = Nothing