diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for shakespeare +### 2.0.24.1 + +* Derive Lift instances wherever possible [#252](https://github.com/yesodweb/shakespeare/pull/252) + ### 2.0.24 * Fix build errors with GHC 8.10.1-alpha2 [#245](https://github.com/yesodweb/shakespeare/pull/245) diff --git a/Text/Hamlet/Parse.hs b/Text/Hamlet/Parse.hs --- a/Text/Hamlet/Parse.hs +++ b/Text/Hamlet/Parse.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveLift #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} @@ -30,7 +31,7 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Maybe (mapMaybe, fromMaybe, isNothing) -import Language.Haskell.TH.Syntax (Lift (..)) +import Language.Haskell.TH.Syntax hiding (Module) data Result v = Error String | Ok v deriving (Show, Eq, Read, Data, Typeable) @@ -614,24 +615,19 @@ -- | Mapping from short names in \"$doctype\" statements to full doctype. , hamletDoctypeNames :: [(String, String)] } + deriving Lift data NewlineStyle = NoNewlines -- ^ never add newlines | NewlinesText -- ^ add newlines between consecutive text lines | AlwaysNewlines -- ^ add newlines everywhere | DefaultNewlineStyle - deriving Show - -instance Lift NewlineStyle where - lift NoNewlines = [|NoNewlines|] - lift NewlinesText = [|NewlinesText|] - lift AlwaysNewlines = [|AlwaysNewlines|] - lift DefaultNewlineStyle = [|DefaultNewlineStyle|] + deriving (Show, Lift) instance Lift (String -> CloseStyle) where lift _ = [|\s -> htmlCloseStyle s|] - -instance Lift HamletSettings where - lift (HamletSettings a b c d) = [|HamletSettings $(lift a) $(lift b) $(lift c) $(lift d)|] +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped = unsafeTExpCoerce . lift +#endif -- See the html specification for a list of all void elements: diff --git a/Text/Internal/Css.hs b/Text/Internal/Css.hs --- a/Text/Internal/Css.hs +++ b/Text/Internal/Css.hs @@ -2,6 +2,8 @@ -- | This module is only being exposed to work around a GHC bug, its API is not stable {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -67,6 +69,7 @@ { mixinAttrs :: ![Attr Resolved] , mixinBlocks :: ![Block Resolved] } + deriving Lift instance Semigroup Mixin where Mixin a x <> Mixin b y = Mixin (a ++ b) (x ++ y) instance Monoid Mixin where @@ -94,7 +97,7 @@ | ContentUrl Deref | ContentUrlParam Deref | ContentMixin Deref - deriving (Show, Eq) + deriving (Show, Eq, Lift) type Contents = [Content] @@ -510,23 +513,19 @@ | haveWhiteSpace = fromString ";\n" | otherwise = singleton ';' -instance Lift Mixin where - lift (Mixin a b) = [|Mixin a b|] -instance Lift (Attr Unresolved) where - lift (Attr k v) = [|Attr k v :: Attr Unresolved |] +deriving instance Lift (Attr Unresolved) instance Lift (Attr Resolved) where lift (Attr k v) = [|Attr $(liftBuilder k) $(liftBuilder v) :: Attr Resolved |] +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped = unsafeTExpCoerce . lift +#endif liftBuilder :: Builder -> Q Exp liftBuilder b = [|fromText $ pack $(lift $ TL.unpack $ toLazyText b)|] -instance Lift Content where - lift (ContentRaw s) = [|ContentRaw s|] - lift (ContentVar d) = [|ContentVar d|] - lift (ContentUrl d) = [|ContentUrl d|] - lift (ContentUrlParam d) = [|ContentUrlParam d|] - lift (ContentMixin m) = [|ContentMixin m|] -instance Lift (Block Unresolved) where - lift (Block a b c d) = [|Block a b c d|] +deriving instance Lift (Block Unresolved) instance Lift (Block Resolved) where lift (Block a b () ()) = [|Block $(liftBuilder a) b () ()|] +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped = unsafeTExpCoerce . lift +#endif diff --git a/Text/Shakespeare.hs b/Text/Shakespeare.hs --- a/Text/Shakespeare.hs +++ b/Text/Shakespeare.hs @@ -6,6 +6,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- | NOTE: This module should be considered internal, and will be hidden in @@ -40,6 +41,7 @@ import Text.Parsec.Prim (modifyState, Parsec) import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH (appE) +import Language.Haskell.TH.Lift () -- Import orphan Lift Name instance import Language.Haskell.TH.Syntax import Data.Text.Lazy.Builder (Builder, fromText) #if !MIN_VERSION_base(4,11,0) @@ -97,6 +99,7 @@ , preEscapeIgnoreLine :: [Char] , wrapInsertion :: Maybe WrapInsertion } + deriving Lift data WrapInsertion = WrapInsertion { wrapInsertionIndent :: Maybe String @@ -106,10 +109,11 @@ , wrapInsertionEnd :: String , wrapInsertionAddParens :: Bool } + deriving Lift data PreConversion = ReadProcess String [String] | Id - + deriving Lift data ShakespeareSettings = ShakespeareSettings @@ -137,38 +141,20 @@ , modifyFinalValue = Nothing } -instance Lift PreConvert where - lift (PreConvert convert ignore comment wrapInsertion) = - [|PreConvert $(lift convert) $(lift ignore) $(lift comment) $(lift wrapInsertion)|] - -instance Lift WrapInsertion where - lift (WrapInsertion indent sb sep sc e wp) = - [|WrapInsertion $(lift indent) $(lift sb) $(lift sep) $(lift sc) $(lift e) $(lift wp)|] - -instance Lift PreConversion where - lift (ReadProcess command args) = - [|ReadProcess $(lift command) $(lift args)|] - lift Id = [|Id|] - instance Lift ShakespeareSettings where lift (ShakespeareSettings x1 x2 x3 x4 x5 x6 x7 x8 x9) = [|ShakespeareSettings $(lift x1) $(lift x2) $(lift x3) $(liftExp x4) $(liftExp x5) $(liftExp x6) $(lift x7) $(lift x8) $(liftMExp x9)|] where - liftExp (VarE n) = [|VarE $(liftName n)|] - liftExp (ConE n) = [|ConE $(liftName n)|] + liftExp (VarE n) = [|VarE $(lift n)|] + liftExp (ConE n) = [|ConE $(lift n)|] liftExp _ = error "liftExp only supports VarE and ConE" liftMExp Nothing = [|Nothing|] liftMExp (Just e) = [|Just|] `appE` liftExp e - liftName (Name (OccName a) b) = [|Name (OccName $(lift a)) $(liftFlavour b)|] - liftFlavour NameS = [|NameS|] - liftFlavour (NameQ (ModName a)) = [|NameQ (ModName $(lift a))|] - liftFlavour (NameU _) = error "liftFlavour NameU" -- [|NameU $(lift $ fromIntegral a)|] - liftFlavour (NameL _) = error "liftFlavour NameL" -- [|NameU $(lift $ fromIntegral a)|] - liftFlavour (NameG ns (PkgName p) (ModName m)) = [|NameG $(liftNS ns) (PkgName $(lift p)) (ModName $(lift m))|] - liftNS VarName = [|VarName|] - liftNS DataName = [|DataName|] +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped = unsafeTExpCoerce . lift +#endif type QueryParameters = [(TS.Text, TS.Text)] type RenderUrl url = (url -> QueryParameters -> TS.Text) @@ -195,7 +181,7 @@ compressContents (ContentRaw x:ContentRaw y:z) = compressContents $ ContentRaw (x ++ y) : z compressContents (x:y) = x : compressContents y - + parseContents :: ShakespeareSettings -> Parser Contents parseContents = many1 . parseContent where @@ -274,7 +260,7 @@ <> "(" <> mconcat (intersperse ", " vars) <> ");\n" - where + where removeTrailingSemiColon = reverse $ dropWhile (\c -> c == ';' || isSpace c) (reverse str) diff --git a/Text/Shakespeare/Base.hs b/Text/Shakespeare/Base.hs --- a/Text/Shakespeare/Base.hs +++ b/Text/Shakespeare/Base.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveLift #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-} -- | General parsers, functions and datatypes for all Shakespeare languages. @@ -41,7 +42,7 @@ import Control.Monad (when) newtype Ident = Ident String - deriving (Show, Eq, Read, Data, Typeable, Ord) + deriving (Show, Eq, Read, Data, Typeable, Ord, Lift) type Scope = [(Ident, Exp)] @@ -53,35 +54,7 @@ | DerefBranch Deref Deref | DerefList [Deref] | DerefTuple [Deref] - deriving (Show, Eq, Read, Data, Typeable, Ord) - -instance Lift Ident where - lift (Ident s) = [|Ident|] `appE` lift s -instance Lift Deref where - lift (DerefModulesIdent v s) = do - dl <- [|DerefModulesIdent|] - v' <- lift v - s' <- lift s - return $ dl `AppE` v' `AppE` s' - lift (DerefIdent s) = do - dl <- [|DerefIdent|] - s' <- lift s - return $ dl `AppE` s' - lift (DerefBranch x y) = do - x' <- lift x - y' <- lift y - db <- [|DerefBranch|] - return $ db `AppE` x' `AppE` y' - lift (DerefIntegral i) = [|DerefIntegral|] `appE` lift i - lift (DerefRational r) = do - n <- lift $ numerator r - d <- lift $ denominator r - per <- [|(%) :: Int -> Int -> Ratio Int|] - dr <- [|DerefRational|] - return $ dr `AppE` InfixE (Just n) per (Just d) - lift (DerefString s) = [|DerefString|] `appE` lift s - lift (DerefList x) = [|DerefList $(lift x)|] - lift (DerefTuple x) = [|DerefTuple $(lift x)|] + deriving (Show, Eq, Read, Data, Typeable, Ord, Lift) derefParens, derefCurlyBrackets :: UserParser a Deref derefParens = between (char '(') (char ')') parseDeref @@ -298,7 +271,7 @@ readUtf8File fp = do h <- SIO.openFile fp SIO.ReadMode SIO.hSetEncoding h SIO.utf8_bom - ret <- TIO.hGetContents h + ret <- TIO.hGetContents h return $ #ifdef WINDOWS TL.filter ('\r'/=) ret diff --git a/shakespeare.cabal b/shakespeare.cabal --- a/shakespeare.cabal +++ b/shakespeare.cabal @@ -1,5 +1,5 @@ name: shakespeare -version: 2.0.24 +version: 2.0.24.1 license: MIT license-file: LICENSE author: Michael Snoyman @@ -18,7 +18,7 @@ category: Web, Yesod stability: Stable -cabal-version: >= 1.8 +cabal-version: >= 1.10 build-type: Simple homepage: http://www.yesodweb.com/book/shakespearean-templates extra-source-files: @@ -34,6 +34,7 @@ ChangeLog.md library + default-language: Haskell2010 build-depends: base >= 4.9 && < 5 , time >= 1 , containers @@ -52,6 +53,7 @@ , vector , unordered-containers , scientific >= 0.3.0.0 + , th-lift exposed-modules: Text.Shakespeare.I18N Text.Shakespeare.Text @@ -103,6 +105,7 @@ default: False test-suite test + default-language: Haskell2010 hs-source-dirs: test main-is: Spec.hs other-modules: Text.Shakespeare.BaseSpec