From 1b1e4b978db8a14db29e1b7bce5d0f8c74836148 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Wed, 18 May 2016 07:00:19 +0000 Subject: [PATCH] Much richer set of Darcs rev TH splices --- src/Data/Revision/Local.hs | 54 +++++++ src/Development/DarcsRev.hs | 311 +++++++++++++++++++++++++++++++----- vervis.cabal | 1 + 3 files changed, 322 insertions(+), 44 deletions(-) create mode 100644 src/Data/Revision/Local.hs diff --git a/src/Data/Revision/Local.hs b/src/Data/Revision/Local.hs new file mode 100644 index 0000000..7c414ee --- /dev/null +++ b/src/Data/Revision/Local.hs @@ -0,0 +1,54 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Data.Revision.Local + ( Change (..) + , Revision (..) + , Version (..) + ) +where + +import Prelude + +import Data.Text (Text) +import Data.Time.Clock (UTCTime) + +-- | A recorded patch or tag. +data Change = Change + { -- | When it was recorded. + cgTime :: UTCTime + -- | Lowercase hex representation of its SHA1 info hash. + , cgHash :: Text + -- | Single-line title. + , cgTitle :: Text + } + +-- | Given a non-empty repo, this refers to a point in its history. +data Revision + -- | The last change is a tag. + = RevTag Change + -- | The last change isn't a tag, but a tag exists earlier in the history. + -- Specifies details of the last tag, the number of patches after that tag, + -- and details of the last patch. + | RevTagPlus Change Int Change + -- | There are no recorded tags. Specifies the last patch. + | RevPatch Change + +data Version = Version + { verSharer :: Text + , verRepo :: Text + , verChanges :: Int + , verRevision :: Revision + } diff --git a/src/Development/DarcsRev.hs b/src/Development/DarcsRev.hs index cb0b24b..b11f008 100644 --- a/src/Development/DarcsRev.hs +++ b/src/Development/DarcsRev.hs @@ -16,18 +16,40 @@ {-# LANGUAGE CPP #-} module Development.DarcsRev - ( darcsLastPatchHash + ( -- * Simple literals + -- ** Last patch + darcsLastPatchHash + , darcsLastPatchHash_ , darcsLastPatchTime + , darcsLastPatchTime_ , darcsLastPatchTitle + , darcsLastPatchTitle_ , darcsLastPatchIsTag + , darcsLastPatchIsTag_ + -- ** Last tag + , darcsTagExists , darcsLastTagHash + , darcsLastTagHash_ , darcsLastTagTime + , darcsLastTagTime_ , darcsLastTagName + , darcsLastTagName_ + -- ** Other revision info , darcsPatchesSinceLastTag , darcsBranchSharer , darcsBranchRepo , darcsTotalPatches , darcsTreeDirty + -- * Records + -- ** Last patch + , darcsLastPatch + , darcsLastPatch_ + -- ** Last tag + , darcsLastTag + , darcsLastTag_ + -- ** Revision + , darcsRevision + , darcsRevision_ ) where @@ -35,6 +57,9 @@ import Prelude import Data.Fixed import Data.Foldable (find) +import Data.List (sortOn) +import Data.Maybe (listToMaybe) +import Data.Ord (Down (..)) import Data.Time import Language.Haskell.TH @@ -48,6 +73,7 @@ import Darcs.Local.Patch.Types import Darcs.Local.Inventory.Parser import Darcs.Local.Inventory.Read import Darcs.Local.Inventory.Types +import Data.Revision.Local -- TODO -- @@ -56,11 +82,15 @@ import Darcs.Local.Inventory.Types -- which "darcs branch" is being used -- * Whether there are unrecorded changes to tracked files +------------------------------------------------------------------------------- +-- Utils +------------------------------------------------------------------------------- + repoPath :: FilePath repoPath = "." -readLatestInv :: IO [(PatchInfo, PatchHash)] -readLatestInv = do +readLatestInv :: Q [(PatchInfo, PatchHash)] +readLatestInv = runIO $ do einv <- readLatestInventory repoPath latestInventoryAllP case einv of Left err -> error $ "Failed to parse Darcs inventory file: " ++ err @@ -69,28 +99,34 @@ readLatestInv = do Nothing -> liPatches inv Just (tag, h) -> (tagToPatch tag, h) : liPatches inv -readLastPatch :: IO (PatchInfo, PatchHash) -readLastPatch = do - pis <- readLatestInv - if null pis - then error "No patches found" - else return $ last pis +readLastPatch :: Q (Maybe (PatchInfo, PatchHash)) +readLastPatch = listToMaybe . sortOn (Down . piTime . fst) <$> readLatestInv -readLastTag :: IO (PatchInfo, PatchHash) -readLastTag = do - pis <- readLatestInv - if null pis - then error "No patches found" - else case find (piTag . fst) $ reverse pis of - Nothing -> error "No tags found" - Just tag -> return tag +readLastPatch_ :: Q (PatchInfo, PatchHash) +readLastPatch_ = do + mp <- readLastPatch + case mp of + Nothing -> fail "Couldn't read last patch, repo seems empty" + Just p -> return p -darcsHash :: IO PatchHash -> Q Exp -darcsHash readHash = runIO readHash >>= stringE . BC.unpack . encodePatchHash +readLastTag :: Q (Maybe (PatchInfo, PatchHash)) +readLastTag = + listToMaybe . sortOn (Down . piTime . fst) . filter (piTag . fst) <$> + readLatestInv -darcsTime :: IO PatchInfo -> Q Exp +readLastTag_ :: Q (PatchInfo, PatchHash) +readLastTag_ = do + mp <- readLastTag + case mp of + Nothing -> fail "Couldn't read last tag, repo seems to have no tags" + Just p -> return p + +darcsHash :: Q PatchHash -> Q Exp +darcsHash readHash = readHash >>= stringE . BC.unpack . encodePatchHash + +darcsTime :: Q PatchInfo -> Q Exp darcsTime readPI = do - pi <- runIO readPI + pi <- readPI let UTCTime (ModifiedJulianDay day) diff' = piTime pi #if MIN_VERSION_time(1,6,0) diff = diffTimeToPicoseconds diff' @@ -99,61 +135,182 @@ darcsTime readPI = do let MkFixed pico = realToFrac diff' :: Pico in pico #endif - return $ RecConE 'UTCTime - [ ( 'utctDay - , AppE (VarE 'ModifiedJulianDay) (LitE $ IntegerL day) - ) - , ( 'utctDayTime - , AppE (VarE 'picosecondsToDiffTime) (LitE $ IntegerL diff) - ) + recConE 'UTCTime + [ fieldExp + 'utctDay + (appE (conE 'ModifiedJulianDay) (litE $ integerL day)) + , fieldExp + 'utctDayTime + (appE (varE 'picosecondsToDiffTime) (litE $ integerL diff)) ] -darcsTitle :: IO PatchInfo -> Q Exp -darcsTitle readPI = runIO readPI >>= stringE . T.unpack . piTitle +darcsTitle :: Q PatchInfo -> Q Exp +darcsTitle readPI = readPI >>= stringE . T.unpack . piTitle -darcsIsTag :: IO PatchInfo -> Q Exp +darcsIsTag :: Q PatchInfo -> Q Exp darcsIsTag readPI = do - pi <- runIO readPI - return $ ConE $ if piTag pi then 'True else 'False + pi <- readPI + conE $ if piTag pi then 'True else 'False + +darcsPatch :: Q (PatchInfo, PatchHash) -> Q Exp +darcsPatch readPH = do + (pi, h) <- readPH + recConE 'Change + [ fieldExp 'cgTime (darcsTime $ return pi) + , fieldExp 'cgHash (darcsHash $ return h) + , fieldExp 'cgTitle (darcsTitle $ return pi) + ] + +darcsRev :: (PatchInfo, PatchHash) -> [(PatchInfo, PatchHash)] -> Q Exp +darcsRev piLast piRest = + case break (piTag . fst) (piLast : piRest) of + (_, []) -> appE (conE 'RevPatch) (darcsPatch $ return piLast) + ([], (tag:_)) -> appE (conE 'RevTag) (darcsPatch $ return tag) + (after, (tag:_)) -> + appsE + [ conE 'RevTagPlus + , darcsPatch $ return tag + , litE $ integerL $ toInteger $ length after + , darcsPatch $ return piLast + ] + +fmapMaybeTH :: (Q a -> Q Exp) -> Q (Maybe a) -> Q Exp +fmapMaybeTH f a = do + mr <- a + case mr of + Nothing -> conE 'Nothing + Just r -> appE (conE 'Just) (f $ return r) + +------------------------------------------------------------------------------- +-- Simple literals +------------------------------------------------------------------------------- + +------------------------------------------------------------------------------- +-- -- Last patch +------------------------------------------------------------------------------- -- | The ASCII lowercase hexadecimal representation of the hash of the last -- recorded patch, as a string literal. This the SHA256 patch hash, i.e. a hash -- of the patch info, not content. This is what @darcs log@ displays. +-- +-- If the repository is empty, this generates 'Nothing', otherwise 'Just' the +-- string literal. darcsLastPatchHash :: Q Exp -darcsLastPatchHash = darcsHash $ snd <$> readLastPatch +darcsLastPatchHash = fmapMaybeTH darcsHash $ fmap snd <$> readLastPatch + +-- | The ASCII lowercase hexadecimal representation of the hash of the last +-- recorded patch, as a string literal. This the SHA256 patch hash, i.e. a hash +-- of the patch info, not content. This is what @darcs log@ displays. +-- +-- If the repository is empty, this will fail during compilation. +darcsLastPatchHash_ :: Q Exp +darcsLastPatchHash_ = darcsHash $ snd <$> readLastPatch_ -- | The time of the last recorded patch, as a 'UTCTime' value. +-- +-- If the repository is empty, this generates 'Nothing', otherwise 'Just' the +-- 'UTCTime' value. darcsLastPatchTime :: Q Exp -darcsLastPatchTime = darcsTime $ fst <$> readLastPatch +darcsLastPatchTime = fmapMaybeTH darcsTime $ fmap fst <$> readLastPatch + +-- | The time of the last recorded patch, as a 'UTCTime' value. +-- +-- If the repository is empty, this will fail during compilation. +darcsLastPatchTime_ :: Q Exp +darcsLastPatchTime_ = darcsTime $ fst <$> readLastPatch_ -- | The title of the last recorded patch, as a string literal. +-- +-- If the repository is empty, this generates 'Nothing', otherwise 'Just' the +-- string literal. darcsLastPatchTitle :: Q Exp -darcsLastPatchTitle = darcsTitle $ fst <$> readLastPatch +darcsLastPatchTitle = fmapMaybeTH darcsTitle $ fmap fst <$> readLastPatch + +-- | The title of the last recorded patch, as a string literal. +-- +-- If the repository is empty, this will fail during compilation. +darcsLastPatchTitle_ :: Q Exp +darcsLastPatchTitle_ = darcsTitle $ fst <$> readLastPatch_ -- | A 'Bool' saying whether the last recorded patch is actually a tag. +-- +-- If the repository is empty, this generates 'Nothing', otherwise 'Just' the +-- 'Bool' value. darcsLastPatchIsTag :: Q Exp -darcsLastPatchIsTag = darcsIsTag $ fst <$> readLastPatch +darcsLastPatchIsTag = fmapMaybeTH darcsIsTag $ fmap fst <$> readLastPatch + +-- | A 'Bool' saying whether the last recorded patch is actually a tag. +-- +-- If the repository is empty, this will fail during compilation. +darcsLastPatchIsTag_ :: Q Exp +darcsLastPatchIsTag_ = darcsIsTag $ fst <$> readLastPatch_ + +------------------------------------------------------------------------------- +-- -- Last tag +------------------------------------------------------------------------------- + +-- | Whether the repo history contains any tags, as a 'Bool' value. +darcsTagExists :: Q Exp +darcsTagExists = do + pis <- readLatestInv + conE $ if any (piTag . fst) pis + then 'True + else 'False -- | The ASCII lowercase hexadecimal representation of the hash of the last -- recorded tag (i.e. the last patch that is a tag). +-- +-- If the repository has no tags, this generates 'Nothing', otherwise 'Just' +-- the string literal. darcsLastTagHash :: Q Exp -darcsLastTagHash = darcsHash $ snd <$> readLastTag +darcsLastTagHash = fmapMaybeTH darcsHash $ fmap snd <$> readLastTag + +-- | The ASCII lowercase hexadecimal representation of the hash of the last +-- recorded tag (i.e. the last patch that is a tag). +-- +-- If the repository has no tags, this will fail during compilation. +darcsLastTagHash_ :: Q Exp +darcsLastTagHash_ = darcsHash $ snd <$> readLastTag_ -- | The time of the last recorded tag, as a 'UTCTime' value. +-- +-- If the repository has no tags, this generates 'Nothing', otherwise 'Just' +-- the 'UTCTime' value. darcsLastTagTime :: Q Exp -darcsLastTagTime = darcsTime $ fst <$> readLastTag +darcsLastTagTime = fmapMaybeTH darcsTime $ fmap fst <$> readLastTag + +-- | The time of the last recorded tag, as a 'UTCTime' value. +-- +-- If the repository has no tags, this will fail during compilation. +darcsLastTagTime_ :: Q Exp +darcsLastTagTime_ = darcsTime $ fst <$> readLastTag_ -- | The name of the last recorded tag, as a string literal. This is a result -- of taking the title of the tag and dropping the @"TAG "@ prefix. +-- +-- If the repository has no tags, this generates 'Nothing', otherwise 'Just' +-- the string literal. darcsLastTagName :: Q Exp -darcsLastTagName = darcsTitle $ fst <$> readLastTag +darcsLastTagName = fmapMaybeTH darcsTitle $ fmap fst <$> readLastTag --- | Number of patches recorded after the last tag, as a number literal. +-- | The name of the last recorded tag, as a string literal. This is a result +-- of taking the title of the tag and dropping the @"TAG "@ prefix. +-- +-- If the repository has no tags, this will fail during compilation. +darcsLastTagName_ :: Q Exp +darcsLastTagName_ = darcsTitle $ fst <$> readLastTag_ + +------------------------------------------------------------------------------- +-- -- Other revision info +------------------------------------------------------------------------------- + +-- | Number of patches recorded after the last tag, as a number literal. If +-- there's no tag found, the number is (-1). darcsPatchesSinceLastTag :: Q Exp darcsPatchesSinceLastTag = do - pisAll <- runIO readLatestInv - case break (piTag . fst) $ reverse pisAll of - (_, []) -> fail "No tag found" + pisAll <- sortOn (Down . piTime . fst) <$> readLatestInv + case break (piTag . fst) pisAll of + (_, []) -> litE $ integerL (-1) (pisAfter, (_tag : _pisBefore)) -> litE $ integerL $ toInteger $ length pisAfter @@ -184,3 +341,69 @@ darcsTotalPatches = do -- | Not implemented yet darcsTreeDirty :: Q Exp darcsTreeDirty = undefined + +------------------------------------------------------------------------------- +-- Records +------------------------------------------------------------------------------- + +------------------------------------------------------------------------------- +-- -- Last patch +------------------------------------------------------------------------------- + +-- | The time, hash and title of the last patch, as a 'Change' value. +-- +-- If the repository is empty, this generates 'Nothing', otherwise 'Just' the +-- 'Change' value. +darcsLastPatch :: Q Exp +darcsLastPatch = fmapMaybeTH darcsPatch readLastPatch + +-- | The time, hash and title of the last patch, as a 'Change' value. +-- +-- If the repository is empty, this will fail during compilation. +darcsLastPatch_ :: Q Exp +darcsLastPatch_ = darcsPatch readLastPatch_ + +------------------------------------------------------------------------------- +-- -- Last tag +------------------------------------------------------------------------------- + +-- | The time, hash and title of the last tag, as a 'Change' value. +-- +-- If the repository has no tags, this generates 'Nothing', otherwise 'Just' +-- the 'Change' value. +darcsLastTag :: Q Exp +darcsLastTag = fmapMaybeTH darcsPatch readLastTag + +-- | The time, hash and title of the last tag, as a 'Change' value. +-- +-- If the repository has no tags, this will fail during compilation. +darcsLastTag_ :: Q Exp +darcsLastTag_ = darcsPatch readLastTag_ + +------------------------------------------------------------------------------- +-- -- Revision +------------------------------------------------------------------------------- + +-- | Representation of the current revision as a 'Revision' value. Generates +-- 'Nothing' if the repo is empty, otherwise 'Just' the value. +-- +-- * If there are no tags in the repo, it gives you the last patch details. +-- * If the last patch is a tag, it gives you its details. +-- * If there is a tag but it isn't the last patch, it gives you details of the +-- last lag, the last patch, and how many patches there are after the last +-- tag. +darcsRevision :: Q Exp +darcsRevision = do + pis <- sortOn (Down . piTime . fst) <$> readLatestInv + case pis of + [] -> conE 'Nothing + (l:r) -> appE (conE 'Just) $ darcsRev l r + +-- | Representation of the current revision as a 'Revision' value. If the +-- repo is empty, fails during compilation. +darcsRevision_ :: Q Exp +darcsRevision_ = do + pis <- sortOn (Down . piTime . fst) <$> readLatestInv + case pis of + [] -> fail "Repo has no patches, can't determine revision" + (l:r) -> darcsRev l r diff --git a/vervis.cabal b/vervis.cabal index f265390..0b6937e 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -55,6 +55,7 @@ library Data.Hourglass.Local Data.List.Local Data.Paginate.Local + Data.Revision.Local Data.Text.UTF8.Local Data.Text.Lazy.UTF8.Local Data.Time.Clock.Local