Skip to content
Snippets Groups Projects
Commit 1dc4b0a6 authored by Ryan Scott's avatar Ryan Scott
Browse files

Migrate fclabels/shakespeare patches, remove old patches

parent 5128b784
No related branches found
No related tags found
1 merge request!72Migrate fclabels/shakespeare patches, remove old patches
Pipeline #15663 failed
diff --git a/Cheapskate/ParserCombinators.hs b/Cheapskate/ParserCombinators.hs
index d60699d..77efb09 100644
--- a/Cheapskate/ParserCombinators.hs
+++ b/Cheapskate/ParserCombinators.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
module Cheapskate.ParserCombinators (
Position(..)
, Parser
@@ -35,6 +36,7 @@ import Prelude hiding (takeWhile)
import Data.Text (Text)
import qualified Data.Text as T
import Control.Monad
+import qualified Control.Monad.Fail as Fail
import Control.Applicative
import qualified Data.Set as Set
@@ -109,7 +111,9 @@ instance Alternative Parser where
instance Monad Parser where
return x = Parser $ \st -> Right (st, x)
- fail e = Parser $ \st -> Left $ ParseError (position st) e
+#if !(MIN_VERSION_base(4,13,0))
+ fail = Fail.fail
+#endif
p >>= g = Parser $ \st ->
case evalParser p st of
Left e -> Left e
@@ -117,6 +121,9 @@ instance Monad Parser where
{-# INLINE return #-}
{-# INLINE (>>=) #-}
+instance Fail.MonadFail Parser where
+ fail e = Parser $ \st -> Left $ ParseError (position st) e
+
instance MonadPlus Parser where
mzero = Parser $ \st -> Left $ ParseError (position st) "(mzero)"
mplus p1 p2 = Parser $ \st ->
diff --git a/cheapskate.cabal b/cheapskate.cabal
index 682735c..d02bc96 100644
--- a/cheapskate.cabal
+++ b/cheapskate.cabal
@@ -1,5 +1,6 @@
name: cheapskate
version: 0.1.1.1
+x-revision: 1
synopsis: Experimental markdown processor.
description: This is an experimental Markdown processor in pure
Haskell. It aims to process Markdown efficiently and in
@@ -41,7 +42,7 @@ library
Cheapskate.Inlines
Cheapskate.ParserCombinators
Paths_cheapskate
- build-depends: base >=4.4 && <5,
+ build-depends: base >=4.6 && <5,
containers >=0.4 && <0.7,
mtl >=2.1 && <2.3,
text >= 0.9 && < 1.3,
diff --git a/fclabels.cabal b/fclabels.cabal
index 3128590..dd19260 100644
--- a/fclabels.cabal
+++ b/fclabels.cabal
@@ -1,5 +1,6 @@
Name: fclabels
Version: 2.0.3.3
+x-revision: 4
Author: Sebastiaan Visser, Erik Hesselink, Chris Eidhof, Sjoerd Visscher
with lots of help and feedback from others.
Synopsis: First class accessor labels implemented as lenses.
@@ -86,8 +87,8 @@ Library
GHC-Options: -Wall
Build-Depends:
- base >= 4.5 && < 4.12
- , template-haskell >= 2.2 && < 2.14
+ base >= 4.5 && < 4.14
+ , template-haskell >= 2.2 && < 2.16
, mtl >= 1.0 && < 2.3
, transformers >= 0.2 && < 0.6
@@ -103,9 +104,9 @@ Test-Suite suite
Build-Depends:
base < 5
, fclabels
- , template-haskell >= 2.2 && < 2.14
- , mtl >= 1.0 && < 2.3
- , transformers >= 0.2 && < 0.6
+ , template-haskell
+ , mtl
+ , transformers
, HUnit >= 1.2 && < 1.7
Benchmark benchmark
@@ -116,4 +117,4 @@ Benchmark benchmark
Build-Depends:
base < 5
, fclabels
- , criterion < 1.3
+ , criterion < 1.6
diff --git a/src/Data/Label/Derive.hs b/src/Data/Label/Derive.hs
index 0f3e716..4883688 100644
--- a/src/Data/Label/Derive.hs
+++ b/src/Data/Label/Derive.hs
@@ -129,9 +129,16 @@ getLabelWith sigs concrete failing name =
context = head $ map (\(LabelExpr _ c _ _) -> c) labels
vars = head $ map (\(LabelExpr v _ _ _) -> v) labels
if sigs
- then tupE bodies `sigE`
- forallT vars context (foldl appT (tupleT (length bodies)) types)
- else tupE bodies
+ then tupE' bodies `sigE`
+ forallT vars context (tupleT' types)
+ else tupE' bodies
+ where
+ tupE' es = case es of
+ [e] -> e
+ _ -> tupE es
+ tupleT' ts = case ts of
+ [t] -> t
+ _ -> foldl appT (tupleT (length ts)) ts
-- | Low level standalone label derivation function.
diff --git a/src/Data/Label/Point.hs b/src/Data/Label/Point.hs
index 210a715..30696a6 100644
--- a/src/Data/Label/Point.hs
+++ b/src/Data/Label/Point.hs
@@ -10,6 +10,7 @@ basis for vertical composition using the `Applicative` type class.
, FlexibleInstances
, MultiParamTypeClasses
, TypeSynonymInstances #-}
+{-# LANGUAGE CPP #-}
module Data.Label.Point
(
@@ -156,6 +157,7 @@ instance ArrowFail e (Failing e) where
-------------------------------------------------------------------------------
+#if __GLASGOW_HASKELL__ < 809
-- | Missing Functor instance for Kleisli.
instance Functor f => Functor (Kleisli f i) where
@@ -172,6 +174,7 @@ instance Applicative f => Applicative (Kleisli f i) where
instance Alternative f => Alternative (Kleisli f i) where
empty = Kleisli (const empty)
Kleisli a <|> Kleisli b = Kleisli ((<|>) <$> a <*> b)
+#endif
-------------------------------------------------------------------------------
-- Common operations experessed in a generalized form.
diff --git a/src/Data/Label/Derive.hs b/src/Data/Label/Derive.hs
index 0f3e716..4883688 100644
--- a/src/Data/Label/Derive.hs
+++ b/src/Data/Label/Derive.hs
@@ -129,9 +129,16 @@ getLabelWith sigs concrete failing name =
context = head $ map (\(LabelExpr _ c _ _) -> c) labels
vars = head $ map (\(LabelExpr v _ _ _) -> v) labels
if sigs
- then tupE bodies `sigE`
- forallT vars context (foldl appT (tupleT (length bodies)) types)
- else tupE bodies
+ then tupE' bodies `sigE`
+ forallT vars context (tupleT' types)
+ else tupE' bodies
+ where
+ tupE' es = case es of
+ [e] -> e
+ _ -> tupE es
+ tupleT' ts = case ts of
+ [t] -> t
+ _ -> foldl appT (tupleT (length ts)) ts
-- | Low level standalone label derivation function.
diff --git a/src/NAryFunctor.hs b/src/NAryFunctor.hs
index e2d12e6..bc1b2ed 100644
--- a/src/NAryFunctor.hs
+++ b/src/NAryFunctor.hs
@@ -65,7 +65,7 @@ newtype NMap1 k (f :: Type -> k) (f' :: Type -> k) = NMap1
{ (<#>) :: forall a b. (a -> b) -> NMap k (f a) (f' b)
}
-type family NMap k = (r :: k -> k -> Type) | r -> k where
+type family NMap (k :: Type) = (r :: k -> k -> Type) | r -> k where
NMap Type = (->)
NMap (Type -> k) = NMap1 k
diff --git a/Text/Hamlet.hs b/Text/Hamlet.hs
index c8e4e78..8d56a3f 100644
--- a/Text/Hamlet.hs
+++ b/Text/Hamlet.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
@@ -231,7 +232,11 @@ docToExp env hr scope (DocCond conds final) = do
go (d, docs) = do
let d' = derefToExp ((specialOrIdent, VarE 'or):scope) d
docs' <- docsToExp env hr scope docs
- return $ TupE [d', docs']
+ return $ TupE $
+#if MIN_VERSION_template_haskell(2,16,0)
+ map Just
+#endif
+ [d', docs']
docToExp env hr scope (DocCase deref cases) = do
let exp_ = derefToExp scope deref
matches <- mapM toMatch cases
@@ -538,7 +543,11 @@ hamletFileReloadWithSettings hrr settings fp = do
vtToExp (d, vt) = do
d' <- lift d
c' <- toExp vt
- return $ TupE [d', c' `AppE` derefToExp [] d]
+ return $ TupE $
+#if MIN_VERSION_template_haskell(2,16,0)
+ map Just
+#endif
+ [d', c' `AppE` derefToExp [] d]
where
toExp = c
where
diff --git a/Text/Internal/Css.hs b/Text/Internal/Css.hs
index a76e4a5..6b501c4 100644
index 66ed0b6..a9d31fe 100644
--- a/Text/Internal/Css.hs
+++ b/Text/Internal/Css.hs
@@ -1,6 +1,7 @@
{-# OPTIONS_HADDOCK hide #-}
-- | This module is only being exposed to work around a GHC bug, its API is not stable
+{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -266,7 +267,7 @@ cssRuntime toi2b parseBlocks fp cd render' = unsafePerformIO $ do
@@ -267,7 +267,7 @@ cssRuntime toi2b parseBlocks fp cd render' = unsafePerformIO $ do
where
cs = either error mconcat $ mapM (contentToBuilderRT cd render') cs'
goTop scope (TopBlock b:rest) =
......@@ -54,20 +11,7 @@ index a76e4a5..6b501c4 100644
goTop scope rest
goTop scope (TopAtBlock name s' b:rest) =
TopAtBlock name s (foldr (either error id . blockRuntime (addScope scope) render') [] b) :
@@ -281,7 +282,11 @@ vtToExp :: (Deref, VarType) -> Q Exp
vtToExp (d, vt) = do
d' <- lift d
c' <- c vt
- return $ TupE [d', c' `AppE` derefToExp [] d]
+ return $ TupE $
+#if MIN_VERSION_template_haskell(2,16,0)
+ map Just
+#endif
+ [d', c' `AppE` derefToExp [] d]
where
c :: VarType -> Q Exp
c VTPlain = [|CDPlain . toCss|]
@@ -512,7 +517,11 @@ instance Lift (Attr Unresolved) where
@@ -517,7 +517,11 @@ instance Lift (Attr Unresolved) where
instance Lift (Attr Resolved) where
lift (Attr k v) = [|Attr $(liftBuilder k) $(liftBuilder v) :: Attr Resolved |]
......@@ -92,37 +36,3 @@ index f814263..83d4e6a 100644
where
scope' = map goScope scope
diff --git a/Text/Shakespeare.hs b/Text/Shakespeare.hs
index 56ff289..460c1e2 100644
--- a/Text/Shakespeare.hs
+++ b/Text/Shakespeare.hs
@@ -429,7 +429,11 @@ shakespeareFileReload settings fp = do
vtToExp (d, vt) = do
d' <- lift d
c' <- c vt
- return $ TupE [d', c' `AppE` derefToExp [] d]
+ return $ TupE $
+#if MIN_VERSION_template_haskell(2,16,0)
+ map Just
+#endif
+ [d', c' `AppE` derefToExp [] d]
where
c :: VarType -> Q Exp
c VTPlain = [|EPlain . $(return $
diff --git a/Text/Shakespeare/Base.hs b/Text/Shakespeare/Base.hs
index 3379ed3..b106632 100644
--- a/Text/Shakespeare/Base.hs
+++ b/Text/Shakespeare/Base.hs
@@ -198,7 +198,11 @@ derefToExp _ (DerefIntegral i) = LitE $ IntegerL i
derefToExp _ (DerefRational r) = LitE $ RationalL r
derefToExp _ (DerefString s) = LitE $ StringL s
derefToExp s (DerefList ds) = ListE $ map (derefToExp s) ds
-derefToExp s (DerefTuple ds) = TupE $ map (derefToExp s) ds
+derefToExp s (DerefTuple ds) = TupE
+#if MIN_VERSION_template_haskell(2,16,0)
+ $ map Just
+#endif
+ $ map (derefToExp s) ds
-- FIXME shouldn't we use something besides a list here?
flattenDeref :: Deref -> Maybe [String]
diff --git a/src/Yesod/Routes/TH/RenderRoute.hs b/src/Yesod/Routes/TH/RenderRoute.hs
index 6424694..6058f15 100644
--- a/src/Yesod/Routes/TH/RenderRoute.hs
+++ b/src/Yesod/Routes/TH/RenderRoute.hs
@@ -84,7 +84,13 @@ mkRenderRouteClauses =
let cons y ys = InfixE (Just y) colon (Just ys)
let pieces' = foldr cons (VarE a) piecesSingle
- let body = LamE [TupP [VarP a, VarP b]] (TupE [pieces', VarE b]) `AppE` (rr `AppE` VarE child)
+ let body = LamE [TupP [VarP a, VarP b]]
+ (TupE $
+#if MIN_VERSION_template_haskell(2,16,0)
+ map Just
+#endif
+ [pieces', VarE b])
+ `AppE` (rr `AppE` VarE child)
return $ Clause [pat] (NormalB body) [FunD childRender childClauses]
@@ -119,11 +125,21 @@ mkRenderRouteClauses =
let cons y ys = InfixE (Just y) colon (Just ys)
let pieces = foldr cons (VarE a) piecesSingle
- return $ LamE [TupP [VarP a, VarP b]] (TupE [pieces, VarE b]) `AppE` (rr `AppE` VarE x)
+ return $ LamE [TupP [VarP a, VarP b]]
+ (TupE $
+#if MIN_VERSION_template_haskell(2,16,0)
+ map Just
+#endif
+ [pieces, VarE b])
+ `AppE` (rr `AppE` VarE x)
_ -> do
colon <- [|(:)|]
let cons a b = InfixE (Just a) colon (Just b)
- return $ TupE [foldr cons piecesMulti piecesSingle, ListE []]
+ return $ TupE $
+#if MIN_VERSION_template_haskell(2,16,0)
+ map Just
+#endif
+ [foldr cons piecesMulti piecesSingle, ListE []]
return $ Clause [pat] (NormalB body) []
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment