Much richer set of Darcs rev TH splices
This commit is contained in:
fr33domlover
parent
e76c1f7206
commit
1b1e4b978d
3 changed files with 322 additions and 44 deletions
54
src/Data/Revision/Local.hs
Normal file
54
src/Data/Revision/Local.hs
Normal file
|
|
@ -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
|
||||
}
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue