84 lines
2.6 KiB
Haskell
84 lines
2.6 KiB
Haskell
|
{- adjusted branch names
|
||
|
|
-
|
||
|
|
- Copyright 2016-2018 Joey Hess <id@joeyh.name>
|
||
|
|
-
|
||
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
||
|
|
-}
|
||
|
|
|
||
|
|
module Annex.AdjustedBranch.Name (
|
||
|
|
originalToAdjusted,
|
||
|
|
adjustedToOriginal,
|
||
|
|
AdjBranch(..),
|
||
|
|
OrigBranch,
|
||
|
|
) where
|
||
|
|
|
||
|
|
import Types.AdjustedBranch
|
||
|
|
import Git
|
||
|
|
import qualified Git.Ref
|
||
|
|
import Utility.Misc
|
||
|
|
|
||
|
|
import Control.Applicative
|
||
|
|
import Data.List
|
||
|
|
|
||
|
|
adjustedBranchPrefix :: String
|
||
|
|
adjustedBranchPrefix = "refs/heads/adjusted/"
|
||
|
|
|
||
|
|
class SerializeAdjustment t where
|
||
|
|
serializeAdjustment :: t -> String
|
||
|
|
deserializeAdjustment :: String -> Maybe t
|
||
|
|
|
||
|
|
instance SerializeAdjustment Adjustment where
|
||
|
|
serializeAdjustment (LinkAdjustment l) =
|
||
|
|
serializeAdjustment l
|
||
|
|
serializeAdjustment (PresenceAdjustment p Nothing) =
|
||
|
|
serializeAdjustment p
|
||
|
|
serializeAdjustment (PresenceAdjustment p (Just l)) =
|
||
|
|
serializeAdjustment p ++ "-" ++ serializeAdjustment l
|
||
|
|
deserializeAdjustment s =
|
||
|
|
(LinkAdjustment <$> deserializeAdjustment s)
|
||
|
|
<|>
|
||
|
|
(PresenceAdjustment <$> deserializeAdjustment s1 <*> pure (deserializeAdjustment s2))
|
||
|
|
<|>
|
||
|
|
(PresenceAdjustment <$> deserializeAdjustment s <*> pure Nothing)
|
||
|
|
where
|
||
|
|
(s1, s2) = separate (== '-') s
|
||
|
|
|
||
|
|
instance SerializeAdjustment LinkAdjustment where
|
||
|
|
serializeAdjustment UnlockAdjustment = "unlocked"
|
||
|
|
serializeAdjustment LockAdjustment = "locked"
|
||
|
|
serializeAdjustment FixAdjustment = "fixed"
|
||
|
|
serializeAdjustment UnFixAdjustment = "unfixed"
|
||
|
|
deserializeAdjustment "unlocked" = Just UnlockAdjustment
|
||
|
|
deserializeAdjustment "locked" = Just UnlockAdjustment
|
||
|
|
deserializeAdjustment "fixed" = Just FixAdjustment
|
||
|
|
deserializeAdjustment "unfixed" = Just UnFixAdjustment
|
||
|
|
deserializeAdjustment _ = Nothing
|
||
|
|
|
||
|
|
instance SerializeAdjustment PresenceAdjustment where
|
||
|
|
serializeAdjustment HideMissingAdjustment = "hidemissing"
|
||
|
|
serializeAdjustment ShowMissingAdjustment = "showmissing"
|
||
|
|
deserializeAdjustment "hidemissing" = Just HideMissingAdjustment
|
||
|
|
deserializeAdjustment "showmissing" = Just ShowMissingAdjustment
|
||
|
|
deserializeAdjustment _ = Nothing
|
||
|
|
|
||
|
|
newtype AdjBranch = AdjBranch { adjBranch :: Branch }
|
||
|
|
|
||
|
|
originalToAdjusted :: OrigBranch -> Adjustment -> AdjBranch
|
||
|
|
originalToAdjusted orig adj = AdjBranch $ Ref $
|
||
|
|
adjustedBranchPrefix ++ base ++ '(' : serializeAdjustment adj ++ ")"
|
||
|
|
where
|
||
|
|
base = fromRef (Git.Ref.base orig)
|
||
|
|
|
||
|
|
type OrigBranch = Branch
|
||
|
|
|
||
|
|
adjustedToOriginal :: Branch -> Maybe (Adjustment, OrigBranch)
|
||
|
|
adjustedToOriginal b
|
||
|
|
| adjustedBranchPrefix `isPrefixOf` bs = do
|
||
|
|
let (base, as) = separate (== '(') (drop prefixlen bs)
|
||
|
|
adj <- deserializeAdjustment (takeWhile (/= ')') as)
|
||
|
|
Just (adj, Git.Ref.branchRef (Ref base))
|
||
|
|
| otherwise = Nothing
|
||
|
|
where
|
||
|
|
bs = fromRef b
|
||
|
|
prefixlen = length adjustedBranchPrefix
|