From 8eca3fa64763abf593cf852ad7fa0a1a5cfd89dc Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Wed, 16 May 2018 00:02:54 +0000 Subject: [PATCH] Upgrade to GHC 8 and LTS 10.10 --- INSTALL.md | 4 +- src/Data/ByteString/Local.hs | 11 +- .../Persist/Local/Class/PersistEntityGraph.hs | 6 +- .../Persist/Local/Class/PersistQueryForest.hs | 34 ++-- src/Database/Persist/Local/Sql.hs | 6 +- src/Vervis/Darcs.hs | 6 +- src/Vervis/Foundation.hs | 2 +- src/Vervis/Import.hs | 2 +- src/Vervis/Model.hs | 6 +- src/Vervis/Render.hs | 146 +++++++----------- src/Vervis/Settings.hs | 2 +- src/Yesod/Auth/Unverified.hs | 5 +- src/Yesod/SessionEntity.hs | 7 - stack.yaml | 21 +-- vervis.cabal | 5 +- 15 files changed, 101 insertions(+), 162 deletions(-) diff --git a/INSTALL.md b/INSTALL.md index b5d610f..eb8c565 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -78,9 +78,9 @@ As of May 14, 2018, what you need to do is as follows: $ darcs clone $HUB/hit-graph $ darcs clone $HUB/hit-harder $ darcs clone $HUB/hit-network - $ darcs clone $VERVIS/darcs-rev --to-hash 30ab5896e53321105c36a028e451b93c98e0345b + $ darcs clone $VERVIS/darcs-rev $ darcs clone $VERVIS/ssh - $ darcs clone $VERVIS/persistent-migration --to-hash 992e059a3b8cc039d555ad31622174133a0918bc + $ darcs clone $VERVIS/persistent-migration $ darcs clone $VERVIS/persistent-email-addres $ darcs clone $VERVIS/yesod-mail-send --to-hash 2800294a41daf57cd420710bc79c8c9b06c0d3dd diff --git a/src/Data/ByteString/Local.hs b/src/Data/ByteString/Local.hs index 781e7dd..3c63e50 100644 --- a/src/Data/ByteString/Local.hs +++ b/src/Data/ByteString/Local.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2018 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -17,7 +17,6 @@ module Data.ByteString.Local ( fromDecimal - , stripPrefix ) where @@ -41,11 +40,3 @@ fromDecimal s = if (not . B.null) s && B.all (\ b -> 48 <= b && b <= 57) s then Just $ B.foldl' (\ n b -> 10 * n + fromIntegral b - 48) 0 s else Nothing - -#if !(MIN_VERSION_bytestring(0,10,8)) -stripPrefix :: ByteString -> ByteString -> Maybe ByteString -stripPrefix p b = - if p `B.isPrefixOf` b - then Just $ B.drop (B.length p) b - else Nothing -#endif diff --git a/src/Database/Persist/Local/Class/PersistEntityGraph.hs b/src/Database/Persist/Local/Class/PersistEntityGraph.hs index 815d85b..28739a0 100644 --- a/src/Database/Persist/Local/Class/PersistEntityGraph.hs +++ b/src/Database/Persist/Local/Class/PersistEntityGraph.hs @@ -40,6 +40,6 @@ class (PersistEntityGraph n e, PersistField (PersistEntityGraphSelector n e)) :: Proxy (n, e) -> EntityField n (PersistEntityGraphSelector n e) class PersistEntityGraphSelect n e => PersistEntityGraphNumbered n e where - numberParam :: n -> Int - numberField :: EntityField n Int - uniqueNode :: PersistEntityGraphSelector n e -> Int -> Unique n + numberParam :: Proxy (n, e) -> n -> Int + numberField :: Proxy (n, e) -> EntityField n Int + uniqueNode :: Proxy (n, e) -> PersistEntityGraphSelector n e -> Int -> Unique n diff --git a/src/Database/Persist/Local/Class/PersistQueryForest.hs b/src/Database/Persist/Local/Class/PersistQueryForest.hs index c209391..01fa563 100644 --- a/src/Database/Persist/Local/Class/PersistQueryForest.hs +++ b/src/Database/Persist/Local/Class/PersistQueryForest.hs @@ -46,7 +46,7 @@ class PersistQuery backend => PersistQueryForest backend where -- | Update individual fields on any record in the transitive closure and -- matching the given criterion. updateForestWhere - :: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val) + :: (MonadIO m, PersistRecordBackend val backend) => RecursionDirection -> EntityField val (Maybe (Key val)) -> Key val @@ -57,7 +57,7 @@ class PersistQuery backend => PersistQueryForest backend where -- | Delete all records in the transitive closure which match the given -- criterion. deleteForestWhere - :: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val) + :: (MonadIO m, PersistRecordBackend val backend) => RecursionDirection -> EntityField val (Maybe (Key val)) -> Key val @@ -67,8 +67,7 @@ class PersistQuery backend => PersistQueryForest backend where -- | Get all records in the transitive closure, which match the given -- criterion, in the specified order. Returns also the identifiers. selectForestSourceRes - :: ( PersistEntity val - , PersistEntityBackend val ~ backend + :: ( PersistRecordBackend val backend , MonadIO m1 , MonadIO m2 ) @@ -82,8 +81,7 @@ class PersistQuery backend => PersistQueryForest backend where -- | Get the 'Key's of all records in the transitive closure, which match -- the given criterion. selectForestKeysRes - :: ( PersistEntity val - , PersistEntityBackend val ~ backend + :: ( PersistRecordBackend val backend , MonadIO m1 , MonadIO m2 ) @@ -97,7 +95,7 @@ class PersistQuery backend => PersistQueryForest backend where -- | The total number of records in the transitive closure which fulfill -- the given criterion. countForest - :: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val) + :: (MonadIO m, PersistRecordBackend val backend) => RecursionDirection -> EntityField val (Maybe (Key val)) -> Key val @@ -107,12 +105,12 @@ class PersistQuery backend => PersistQueryForest backend where -- | Get all records in the transitive closure, which match the given -- criterion, in the specified order. Returns also the identifiers. selectForestSource - :: ( PersistQueryForest backend + :: ( PersistQueryForest (BaseBackend backend) , MonadResource m , PersistEntity val - , PersistEntityBackend val ~ backend - , MonadReader env m - , HasPersistBackend env backend + , PersistEntityBackend val ~ BaseBackend (BaseBackend backend) + , MonadReader backend m + , HasPersistBackend backend ) => RecursionDirection -> EntityField val (Maybe (Key val)) @@ -130,12 +128,12 @@ selectForestSource dir field root filts opts = do -- | Get the 'Key's of all records in the transitive closure, which match the -- given criterion. selectForestKeys - :: ( PersistQueryForest backend + :: ( PersistQueryForest (BaseBackend backend) , MonadResource m , PersistEntity val - , backend ~ PersistEntityBackend val - , MonadReader env m - , HasPersistBackend env backend + , BaseBackend (BaseBackend backend) ~ PersistEntityBackend val + , MonadReader backend m + , HasPersistBackend backend ) => RecursionDirection -> EntityField val (Maybe (Key val)) @@ -153,8 +151,7 @@ selectForestKeys dir field root filts opts = do selectForestList :: ( PersistQueryForest backend , MonadIO m - , PersistEntity val - , PersistEntityBackend val ~ backend + , PersistRecordBackend val backend ) => RecursionDirection -> EntityField val (Maybe (Key val)) @@ -170,8 +167,7 @@ selectForestList dir field root filts opts = do selectForestKeysList :: ( PersistQueryForest backend , MonadIO m - , PersistEntity val - , PersistEntityBackend val ~ backend + , PersistRecordBackend val backend ) => RecursionDirection -> EntityField val (Maybe (Key val)) diff --git a/src/Database/Persist/Local/Sql.hs b/src/Database/Persist/Local/Sql.hs index f554728..6df4dce 100644 --- a/src/Database/Persist/Local/Sql.hs +++ b/src/Database/Persist/Local/Sql.hs @@ -224,9 +224,9 @@ sqlUEdge dbname filt tEdge bwd fwd = selectGraphNodesList :: ( MonadIO m , PersistEntityGraphSelect node edge - , backend ~ PersistEntityBackend node - , backend ~ PersistEntityBackend edge - , PersistQuery backend + , BaseBackend backend ~ PersistEntityBackend node + , BaseBackend backend ~ PersistEntityBackend edge + , PersistQueryRead backend ) => PersistEntityGraphSelector node edge -> [Filter node] diff --git a/src/Vervis/Darcs.hs b/src/Vervis/Darcs.hs index 8e861c6..9d11337 100644 --- a/src/Vervis/Darcs.hs +++ b/src/Vervis/Darcs.hs @@ -60,14 +60,14 @@ import Vervis.SourceTree import Vervis.Wiki (WikiView (..)) dirToAnchoredPath :: [EntryName] -> AnchoredPath -dirToAnchoredPath = AnchoredPath . map (Name . encodeUtf8) +dirToAnchoredPath = AnchoredPath . map (decodeWhiteName . encodeUtf8) matchType :: ItemType -> EntryType matchType TreeType = TypeTree matchType BlobType = TypeBlob nameToText :: Name -> Text -nameToText (Name b) = decodeUtf8With strictDecode b +nameToText = decodeUtf8With strictDecode . encodeWhiteName itemToEntry :: Name -> TreeItem IO -> DirEntry itemToEntry name item = DirEntry (matchType $ itemType item) (nameToText name) @@ -156,7 +156,7 @@ readWikiView isPage isMain path dir = do else ( init dir , maybe Nothing (Just . Just) . isPage lst - , Just $ Name $ encodeUtf8 lst + , Just $ decodeWhiteName $ encodeUtf8 lst ) where lst = last dir diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 90256ae..9dd9de3 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -43,7 +43,7 @@ import Data.Text as T (pack, intercalate, concat) --import qualified Data.Text.Encoding as TE import Text.Jasmine.Local (discardm) -import Vervis.Import.NoFoundation hiding (Day, last) +import Vervis.Import.NoFoundation hiding (Handler, Day, last, init) import Vervis.Model.Group import Vervis.Model.Ident import Vervis.Model.Role diff --git a/src/Vervis/Import.hs b/src/Vervis/Import.hs index 2fc4556..1c0f3fc 100644 --- a/src/Vervis/Import.hs +++ b/src/Vervis/Import.hs @@ -16,4 +16,4 @@ module Vervis.Import ( module Import ) where import Vervis.Foundation as Import -import Vervis.Import.NoFoundation as Import +import Vervis.Import.NoFoundation as Import hiding (Handler) diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs index fd277b1..a420f6b 100644 --- a/src/Vervis/Model.hs +++ b/src/Vervis/Model.hs @@ -86,6 +86,6 @@ instance PersistEntityGraphSelect Ticket TicketDependency where selectorField _ = TicketProject instance PersistEntityGraphNumbered Ticket TicketDependency where - numberParam = ticketNumber - numberField = TicketNumber - uniqueNode = UniqueTicket + numberParam _ = ticketNumber + numberField _ = TicketNumber + uniqueNode _ = UniqueTicket diff --git a/src/Vervis/Render.hs b/src/Vervis/Render.hs index 4a2f2ba..51539bf 100644 --- a/src/Vervis/Render.hs +++ b/src/Vervis/Render.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2018 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -44,17 +44,20 @@ where import Prelude +import Control.Monad.Catch (throwM) import Control.Monad.Logger (logDebug, logWarn) import Data.Foldable (for_) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) +import Data.Text (Text) --import Formatting hiding (format) import Text.Blaze.Html (preEscapedToMarkup) import Text.Blaze.Html.Renderer.Text (renderHtml) import Text.Highlighter (lexerFromFilename, runLexer, Lexer (lName)) import Text.Highlighter.Formatters.Html (format) -import Text.Highlighting.Kate.Styles (tango) +import Skylighting.Styles (tango) import Text.HTML.SanitizeXSS (sanitizeBalance) +import Text.Pandoc.Class (runPure) import Text.Pandoc.Definition (Pandoc) import Text.Pandoc.Options import Text.Pandoc.Readers.Markdown @@ -131,102 +134,79 @@ renderCode lexer contentTL contentB = readerOptions :: ReaderOptions readerOptions = def { readerExtensions = pandocExtensions - , readerSmart = True , readerStandalone = False - , readerParseRaw = True , readerColumns = 80 , readerTabStop = 4 --- , readerOldDashes = False --- , readerApplyMacros = True -- , readerIndentedCodeClasses = [] +-- , readerAbbreviations = defaultAbbrevs -- , readerDefaultImageExtension = "" - , readerTrace = -#if DEVELOPMENT - True -#else - False -#endif -- , readerTrackChanges = AcceptChanges --- , readerFileScope = False +-- , readerStripComments = False } writerOptions :: WriterOptions writerOptions = def - { writerStandalone = False --- , writerTemplate = "" --- , writerVariables = [] - , writerTabStop = 4 - , writerTableOfContents = True --- , writerSlideVariant = NoSlides --- , writerIncremental = False --- , writerHTMLMathMethod = PlainMath --- , writerIgnoreNotes = False --- , writerNumberSections = False --- , writerNumberOffset = [0,0,0,0,0,0] --- , writerSectionDivs = False - , writerExtensions = pandocExtensions --- , writerReferenceLinks = False --- , writerDpi = 96 - , writerWrapText = WrapAuto - , writerColumns = 79 - , writerEmailObfuscation = ReferenceObfuscation --- , writerIdentifierPrefix = "" --- , writerSourceURL = Nothing --- , writerUserDataDir = Nothing --- , writerCiteMethod = Citeproc - , writerHtml5 = True --- , writerHtmlQTags = False --- , writerBeamer = False --- , writerSlideLevel = Nothing --- , writerChapters = False --- , writerListings = False - , writerHighlight = True - , writerHighlightStyle = tango --- , writerSetextHeaders = True --- , writerTeXLigatures = True --- , writerEpubVersion = Nothing --- , writerEpubMetadata = "" --- , writerEpubStylesheet = Nothing --- , writerEpubFonts = [] --- , writerEpubChapterLevel = 1 --- , writerTOCDepth = 3 --- , writerReferenceODT = Nothing --- , writerReferenceDocx = Nothing --- , writerMediaBag = mempty - , writerVerbose = -#if DEVELOPMENT - True -#else - False -#endif --- , writerLaTeXArgs = [] + { +-- writerTemplate = Nothing +-- , writerVariables = [] + writerTabStop = 4 + , writerTableOfContents = True +-- , writerIncremental = False +-- , writerHTMLMathMethod = PlainMath +-- , writerNumberSections = False +-- , writerNumberOffset = [0,0,0,0,0,0] +-- , writerSectionDivs = False + , writerExtensions = pandocExtensions +-- , writerReferenceLinks = False +-- , writerDpi = 96 + , writerWrapText = WrapAuto + , writerColumns = 79 + , writerEmailObfuscation = ReferenceObfuscation +-- , writerIdentifierPrefix = "" +-- , writerCiteMethod = Citeproc +-- , writerHtmlQTags = False +-- , writerSlideLevel = Nothing +-- , writerTopLevelDivision = TopLevelDefault +-- , writerListings = False + , writerHighlightStyle = Just tango +-- , writerSetextHeaders = True +-- , writerEpubSubdirectory = "EPUB" +-- , writerEpubMetadata = Nothing +-- , writerEpubFonts = [] +-- , writerEpubChapterLevel = 1 +-- , writerTOCDepth = 3 +-- , writerReferenceDoc = Nothing +-- , writerReferenceLocation = EndOfDocument +-- , writerSyntaxMap = defaultSyntaxMap } renderPandoc :: Pandoc -> Widget -renderPandoc = - toWidget . - preEscapedToMarkup . - sanitizeBalance . - TL.toStrict . - renderHtml . - writeHtml writerOptions +renderPandoc + = either throwM toWidget + . fmap + ( preEscapedToMarkup + . sanitizeBalance + . TL.toStrict + . renderHtml + ) + . runPure + . writeHtml5 writerOptions -renderSourceT :: MediaType -> T.Text -> Widget +renderSourceT :: MediaType -> Text -> Widget renderSourceT mt contentT = let contentB = TE.encodeUtf8 contentT contentTL = TL.fromStrict contentT - contentS = T.unpack contentT - in renderSource mt contentB contentTL contentS + in renderSource mt contentB contentTL contentT renderSourceBL :: MediaType -> BL.ByteString -> Widget renderSourceBL mt contentBL = let contentB = BL.toStrict contentBL contentTL = TLE.decodeUtf8With TE.lenientDecode contentBL - contentS = TL.unpack contentTL - in renderSource mt contentB contentTL contentS + contentT = TL.toStrict contentTL + in renderSource mt contentB contentTL contentT -renderSource :: MediaType -> B.ByteString -> TL.Text -> String -> Widget -renderSource mt contentB contentTL contentS = +renderSource :: MediaType -> B.ByteString -> TL.Text -> Text -> Widget +renderSource mt contentB contentTL contentT = let mtName = T.pack $ show mt failed e = @@ -236,23 +216,15 @@ renderSource mt contentB contentTL contentS = plain = renderPlain contentTL -- Syntax highlighted source code with line numbers code l = renderCode l contentTL contentB - -- Rendered document from String source - docS r = - case r readerOptions contentS of + -- Rendered document from Text source + docT r = + case runPure $ r readerOptions contentT of Left err -> $logWarn (failed err) >> plain Right doc -> renderPandoc doc - -- Rendered document from String source, with warnings - docSW r = - case r readerOptions contentS of - Left err -> $logWarn (failed err) >> plain - Right (doc, warns) -> do - for_ warns $ \ warn -> - $logDebug $ mtName <> " reader warning: " <> T.pack warn - renderPandoc doc in case mt of -- * Documents PlainText -> plain - Markdown -> docSW readMarkdownWithWarnings + Markdown -> docT readMarkdown -- * Programming languages -- ** Haskell Haskell -> code L.Haskell.lexer diff --git a/src/Vervis/Settings.hs b/src/Vervis/Settings.hs index 5d06a4d..a523225 100644 --- a/src/Vervis/Settings.hs +++ b/src/Vervis/Settings.hs @@ -22,7 +22,7 @@ -- declared in the Foundation.hs file. module Vervis.Settings where -import ClassyPrelude.Conduit +import ClassyPrelude.Conduit hiding (throw) import Yesod hiding (Header, parseTime) import Yesod.Static import Data.Default (Default (..)) diff --git a/src/Yesod/Auth/Unverified.hs b/src/Yesod/Auth/Unverified.hs index 0b3b804..a046e90 100644 --- a/src/Yesod/Auth/Unverified.hs +++ b/src/Yesod/Auth/Unverified.hs @@ -188,10 +188,7 @@ maybeVerifiedAuth => HandlerT master IO (Maybe (Entity record)) maybeVerifiedAuth = maybeAuth -redirectToCurrent = const True - --- handleAuthLack :: (YesodAuth (HandlerSite m), MonadHandler m) => m a -handleAuthLack :: Yesod master => HandlerT master IO a +handleAuthLack :: (YesodAuth (HandlerSite m), MonadHandler m) => m a handleAuthLack = do aj <- acceptsJson if aj diff --git a/src/Yesod/SessionEntity.hs b/src/Yesod/SessionEntity.hs index acbf36b..a3621be 100644 --- a/src/Yesod/SessionEntity.hs +++ b/src/Yesod/SessionEntity.hs @@ -43,9 +43,6 @@ module Yesod.SessionEntity ( maybeKey , maybeEntity - -- * Remove later when we upgrade to GHC 8 - , PersistStoreRead - , PersistRecordBackend ) where @@ -61,10 +58,6 @@ import Yesod.Core (MonadHandler (..)) import Yesod.Core.Handler (cached, lookupSession) import Yesod.Persist.Core (YesodPersist (..)) -type PersistStoreRead = PersistStore - -type PersistRecordBackend record backend = (PersistEntity record, PersistEntityBackend record ~ backend) - cachedRecord :: ( MonadHandler m , HandlerSite m ~ master diff --git a/stack.yaml b/stack.yaml index 55e3bf2..3a15201 100644 --- a/stack.yaml +++ b/stack.yaml @@ -3,7 +3,7 @@ # Specifies the GHC version and set of packages available (e.g., lts-3.5, # nightly-2015-09-21, ghc-7.10.2) -resolver: lts-6.5 +resolver: lts-10.10 # Local packages, usually specified by relative directory name packages: @@ -25,26 +25,15 @@ packages: # Packages to be pulled from upstream that are not in the resolver (e.g., # acme-missiles-0.3) extra-deps: + - darcs-2.14.0 - data-default-instances-bytestring-0.0.1 - - diagrams-svg-1.4.0.2 - highlighter2-0.2.5 - - libravatar-0.4 - - monad-hash-0.1 - # for 'tuple' package, remove once I use lenses instead - - OneTuple-0.2.1 + - libravatar-0.4.0.2 + - monad-hash-0.1.0.2 - persistent-parser-0.1.0.2 - SimpleAES-0.4.2 - # for text drawing with 'diagrams' - - SVGFonts-1.5.0.1 - - tagged-0.8.5 - time-interval-0.1.1 - - transformers-0.4.3.0 - - transformers-compat-0.5.1.4 - # remove once I use lenses instead - - tuple-0.3.0.2 -# - ssh-0.3.2 - # Required for M.alter used in hit-graph - - unordered-containers-0.2.6.0 + - time-units-1.0.0 # Override default flag values for local packages and extra-deps flags: diff --git a/vervis.cabal b/vervis.cabal index 9e03306..3962c70 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -242,6 +242,7 @@ library , dlist , email-validate , esqueleto + , exceptions , fast-logger -- for building a message tree using DFS in -- Vervis.Discussion, possibly also used by some git @@ -253,8 +254,6 @@ library , hashable -- for source file highlighting , highlighter2 - -- for pandoc inline code highlighting - , highlighting-kate , hit , hit-graph >= 0.1 , hit-harder >= 0.1 @@ -288,6 +287,8 @@ library , resourcet , safe , shakespeare + -- for pandoc inline code highlighting + , skylighting , smtp-mail , ssh -- for rendering diagrams