Much richer set of Darcs rev TH splices

src/Data/Revision/Local.hs

@@ -0,0 +1,54 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+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
+    }

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

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