1{- adjusted branch names 2 - 3 - Copyright 2016-2020 Joey Hess <id@joeyh.name> 4 - 5 - Licensed under the GNU AGPL version 3 or higher. 6 -} 7 8{-# LANGUAGE OverloadedStrings #-} 9 10module Annex.AdjustedBranch.Name ( 11 originalToAdjusted, 12 adjustedToOriginal, 13 AdjBranch(..), 14 OrigBranch, 15) where 16 17import Types.AdjustedBranch 18import Git 19import qualified Git.Ref 20import Utility.Misc 21 22import Control.Applicative 23import Data.Char 24import qualified Data.ByteString as S 25 26adjustedBranchPrefix :: S.ByteString 27adjustedBranchPrefix = "refs/heads/adjusted/" 28 29class SerializeAdjustment t where 30 serializeAdjustment :: t -> S.ByteString 31 deserializeAdjustment :: S.ByteString -> Maybe t 32 33instance SerializeAdjustment Adjustment where 34 serializeAdjustment (LinkAdjustment l) = 35 serializeAdjustment l 36 serializeAdjustment (PresenceAdjustment p Nothing) = 37 serializeAdjustment p 38 serializeAdjustment (PresenceAdjustment p (Just l)) = 39 serializeAdjustment p <> "-" <> serializeAdjustment l 40 serializeAdjustment (LinkPresentAdjustment l) = 41 serializeAdjustment l 42 deserializeAdjustment s = 43 (LinkAdjustment <$> deserializeAdjustment s) 44 <|> 45 (PresenceAdjustment <$> deserializeAdjustment s1 <*> pure (deserializeAdjustment s2)) 46 <|> 47 (PresenceAdjustment <$> deserializeAdjustment s <*> pure Nothing) 48 <|> 49 (LinkPresentAdjustment <$> deserializeAdjustment s) 50 where 51 (s1, s2) = separate' (== (fromIntegral (ord '-'))) s 52 53instance SerializeAdjustment LinkAdjustment where 54 serializeAdjustment UnlockAdjustment = "unlocked" 55 serializeAdjustment LockAdjustment = "locked" 56 serializeAdjustment FixAdjustment = "fixed" 57 serializeAdjustment UnFixAdjustment = "unfixed" 58 deserializeAdjustment "unlocked" = Just UnlockAdjustment 59 deserializeAdjustment "locked" = Just LockAdjustment 60 deserializeAdjustment "fixed" = Just FixAdjustment 61 deserializeAdjustment "unfixed" = Just UnFixAdjustment 62 deserializeAdjustment _ = Nothing 63 64instance SerializeAdjustment PresenceAdjustment where 65 serializeAdjustment HideMissingAdjustment = "hidemissing" 66 serializeAdjustment ShowMissingAdjustment = "showmissing" 67 deserializeAdjustment "hidemissing" = Just HideMissingAdjustment 68 deserializeAdjustment "showmissing" = Just ShowMissingAdjustment 69 deserializeAdjustment _ = Nothing 70 71instance SerializeAdjustment LinkPresentAdjustment where 72 serializeAdjustment UnlockPresentAdjustment = "unlockpresent" 73 serializeAdjustment LockPresentAdjustment = "lockpresent" 74 deserializeAdjustment "unlockpresent" = Just UnlockPresentAdjustment 75 deserializeAdjustment "lockpresent" = Just LockPresentAdjustment 76 deserializeAdjustment _ = Nothing 77 78newtype AdjBranch = AdjBranch { adjBranch :: Branch } 79 80originalToAdjusted :: OrigBranch -> Adjustment -> AdjBranch 81originalToAdjusted orig adj = AdjBranch $ Ref $ 82 adjustedBranchPrefix <> base <> "(" <> serializeAdjustment adj <> ")" 83 where 84 base = fromRef' (Git.Ref.base orig) 85 86type OrigBranch = Branch 87 88adjustedToOriginal :: Branch -> Maybe (Adjustment, OrigBranch) 89adjustedToOriginal b 90 | adjustedBranchPrefix `S.isPrefixOf` bs = do 91 let (base, as) = separate' (== openparen) (S.drop prefixlen bs) 92 adj <- deserializeAdjustment (S.takeWhile (/= closeparen) as) 93 Just (adj, Git.Ref.branchRef (Ref base)) 94 | otherwise = Nothing 95 where 96 bs = fromRef' b 97 prefixlen = S.length adjustedBranchPrefix 98 openparen = fromIntegral (ord '(') 99 closeparen = fromIntegral (ord ')') 100