[darcs-devel] add get_slurp_context, get_slurp_context_maybe,
... [7 patches]
Tomasz Zielonka
tomasz.zielonka at gmail.com
Tue Dec 21 13:08:42 PST 2004
Hello!
I am working on removing code duplication in SlurpDirectory. At this point
it may result in a slighty worse efficiency. In the long run it should allow
us to easily switch to an implementation based on FiniteMaps or something
similar.
The first step is introducing get_slurp_context* functions, which allow
to split the slurpy into a subtree and the rest (context):
get_slurp_context :: FileName -> Slurpy -> Maybe (Slurpy -> Slurpy, Slurpy)
get_slurp_context_maybe :: FileName -> Slurpy -> Maybe (Maybe Slurpy -> Maybe Slurpy, Slurpy)
get_slurp_context_list :: FileName -> Slurpy -> Maybe ([Slurpy] -> [Slurpy], Slurpy)
You can modify the subtree for a given path and then apply the context
function to it to get the whole tree.
Any thoughts about it?
I hope I am not stepping on someone else's toes.
Best regards,
Tomasz
-------------- next part --------------
New patches:
[add get_slurp_context, get_slurp_context_maybe and get_slurp_context_list
Tomasz Zielonka <tomasz.zielonka at gmail.com>**20041221064941
These functions allow to split a slurpy to a subtree specified by a file path
and the rest of the tree (context). Hopefully this will allow to move most
of slurpy traversal code to one place.
] {
hunk ./SlurpDirectory.lhs 30
+ get_slurp_context, get_slurp_context_maybe,
+ get_slurp_context_list,
hunk ./SlurpDirectory.lhs 51
-import List ( sort )
+import List ( sort, tails )
hunk ./SlurpDirectory.lhs 66
-import Maybe ( catMaybes )
+import Maybe ( catMaybes, isJust, maybeToList )
hunk ./SlurpDirectory.lhs 257
+\begin{code}
+get_slurp_context_generic :: (Slurpy -> a) -> (a -> [Slurpy]) -> FileName -> Slurpy -> Maybe (a -> a, Slurpy)
+get_slurp_context_generic h1 h2 fn0 s0 =
+ let norm_fn0 = norm_path fn0 in
+ if norm_fn0 == empty
+ then Just (id, s0)
+ else slurp_context_private norm_fn0 id s0
+ where
+ slurp_context_private f ctx s@(SlurpFile f' _ _ _) =
+ if f == f' then Just (ctx, s)
+ else Nothing
+ slurp_context_private f ctx s@(SlurpDir d b c)
+ | f == d = Just (ctx, s)
+ | d == dot =
+ case break_on_dir f of
+ Just (dn,fn) | dn == dot ->
+ descend fn
+ _ ->
+ descend f
+ | otherwise =
+ case break_on_dir f of
+ Just (dn,fn) ->
+ if dn == d
+ then descend fn
+ else Nothing
+ _ -> Nothing
+ where
+ descend fname =
+ let l = [ slurp_context_private
+ fname
+ (\x -> ctx (h1 (SlurpDir d b (pre ++ h2 x ++ post))))
+ this
+ | (pre, this:post) <- zip (inits' c) (tails c)
+ ]
+ in
+ case filter isJust l of
+ [] -> Nothing
+ [msf] -> msf
+ _ -> impossible
+
+ -- a lazier implementation of inits
+ inits' l = [ take i l | i <- [0 .. length l] ]
+ dot = fp2fn "."
+ empty = fp2fn ""
+\end{code}
+
+\begin{code}
+get_slurp_context :: FileName -> Slurpy -> Maybe (Slurpy -> Slurpy, Slurpy)
+get_slurp_context = get_slurp_context_generic id return
+
+get_slurp_context_maybe :: FileName -> Slurpy -> Maybe (Maybe Slurpy -> Maybe Slurpy, Slurpy)
+get_slurp_context_maybe = get_slurp_context_generic Just maybeToList
+
+get_slurp_context_list :: FileName -> Slurpy -> Maybe ([Slurpy] -> [Slurpy], Slurpy)
+get_slurp_context_list = get_slurp_context_generic return id
+\end{code}
+
}
[simplify slurp_remove using get_slurp_context_maybe
Tomasz Zielonka <tomasz.zielonka at gmail.com>**20041221131818] {
hunk ./SlurpDirectory.lhs 318
-slurp_remove fname (SlurpDir dd pp cc) =
- Just $ SlurpDir dd pp $ catMaybes $ map (sr $! norm_path fname) cc
- where sr f s@(SlurpDir d p c) =
- if f == d then Nothing
- else case break_on_dir f of
- Just (dn,fn) -> if dn /= d then Just s
- else Just $ SlurpDir d p $ catMaybes $
- map (sr fn) c
- Nothing -> Just s
- sr f s@(SlurpFile f' _ _ _) | f == f' = Nothing
- | otherwise = Just s
+slurp_remove fname s@(SlurpDir _ _ _) =
+ case get_slurp_context_maybe fname s of
+ Just (ctx, _) -> ctx Nothing
+ Nothing -> Nothing
}
[simplify addslurp using get_slurp_context
Tomasz Zielonka <tomasz.zielonka at gmail.com>**20041221140040] {
hunk ./SlurpDirectory.lhs 389
- addslurp_private (fp2fn ".") (norm_path fname) s'
- where addslurp_private _ _ (SlurpFile a b m c) = SlurpFile a b m c
- addslurp_private d f (SlurpDir d' p c)
- | d /= d' = SlurpDir d' p c
- | otherwise =
- case break_on_dir f of
- Just (dn,fn) -> SlurpDir d p $
- map (addslurp_private dn fn) c
- Nothing -> SlurpDir d p (s:c)
+ case get_slurp_context (super_name fname) s' of
+ Just (ctx, SlurpDir d p c) -> ctx (SlurpDir d p (s:c))
+ _ -> s'
}
[implement get_slurp using get_slurp_context
Tomasz Zielonka <tomasz.zielonka at gmail.com>**20041221170352] {
hunk ./SlurpDirectory.lhs 394
-get_slurp f (SlurpFile f' b m c) =
- if f == f' then Just $ SlurpFile f b m c
- else Nothing
-get_slurp f (SlurpDir d b c)
- | f == d = Just $ SlurpDir d b c
- | fn2fp d == "."= case filter (/=Nothing) $ map (get_slurp $ norm_path f) c of
- [] -> Nothing
- [msf] -> msf
- _ -> impossible
- | otherwise =
- case break_on_dir f of
- Just (dn,fn) ->
- if dn == d
- then case filter (/=Nothing) $ map (get_slurp fn) c of
- [] -> Nothing
- [msf] -> msf
- _ -> impossible
- else Nothing
- _ -> Nothing
+get_slurp f s = fmap snd (get_slurp_context f s)
}
[simplify slurp_modfile using get_slurp_context
Tomasz Zielonka <tomasz.zielonka at gmail.com>**20041221175117] {
hunk ./SlurpDirectory.lhs 437
-slurp_modfile fname modify sl@(SlurpDir dd pp contents) =
- if not $ slurp_hasfile fname sl
- then Nothing
- else case sequence $ map (sm $ norm_path fname) contents of
- Nothing -> Nothing
- Just c' -> Just $ SlurpDir dd pp c'
- where sm :: FileName -> Slurpy -> Maybe Slurpy
- sm f s@(SlurpDir d p c) =
- case break_on_dir f of
- Nothing -> Just s
- Just (dn,fn) ->
- if dn == d
- then case sequence $ map (sm fn) c of
- Nothing -> Nothing
- Just c' -> Just $ SlurpDir d p c'
- else Just s
- sm f s@(SlurpFile ff _ _ c)
- | f == ff = case modify c of
- Nothing -> Nothing
- Just c' -> Just $ SlurpFile ff True undef_time_size c'
- | otherwise = Just s
-slurp_modfile f modify (SlurpFile f' _ _ c)
- | f == f' = case modify c of
+slurp_modfile fname modify sl =
+ case get_slurp_context fname sl of
+ Just (ctx, SlurpFile ff _ _ c) ->
+ case modify c of
hunk ./SlurpDirectory.lhs 442
- Just c' -> Just $ SlurpFile f True undef_time_size c'
-slurp_modfile _ _ s = Just s
+ Just c' -> Just (ctx (SlurpFile ff True undef_time_size c'))
+ _ ->
+ Nothing
}
[simplify slurp_hasfile using get_slurp
Tomasz Zielonka <tomasz.zielonka at gmail.com>**20041221182015] {
hunk ./SlurpDirectory.lhs 449
-slurp_hasfile f (SlurpFile f' _ _ _) = (norm_path f) == f'
-slurp_hasfile fname (SlurpDir _ _ contents) =
- seq normed_name $ or $ map (slurp_hasfile_private normed_name) contents
- where normed_name = norm_path fname
- slurp_hasfile_private f (SlurpFile f' _ _ _) = f == f'
- slurp_hasfile_private f (SlurpDir d _ c)
- | f == d = False
- | otherwise =
- case break_on_dir f of
- Just (dn,fn) ->
- if dn == d
- then or $ map (slurp_hasfile_private fn) c
- else False
- _ -> False
+slurp_hasfile f s =
+ case get_slurp f s of
+ Just s' | is_file s' -> True
+ _ -> False
}
[simplify slurp_has using get_slurp
Tomasz Zielonka <tomasz.zielonka at gmail.com>**20041221193648] {
hunk ./SlurpDirectory.lhs 455
-slurp_has fname (SlurpDir _ _ contents) =
- seq normed_name $ or $ map (has_private normed_name) contents
- where normed_name = norm_path $ fp2fn fname
- has_private f (SlurpFile f' _ _ _) = f == f'
- has_private f (SlurpDir d _ c)
- | f == d = True
- | otherwise =
- case break_on_dir f of
- Just (dn,fn)
- | dn == d -> or $ map (has_private fn) c
- | otherwise -> False
- _ -> False
-slurp_has f (SlurpFile f' _ _ _) = (norm_path $ fp2fn f) == f'
+slurp_has f s = isJust (get_slurp (fp2fn f) s)
}
Context:
[use fail when possible for errors.
David Roundy <droundy at abridgegame.org>**20041218153234]
[address #114 - provide a better error when you accidently try to pull from yourself
Mark Stosberg <mark at summersault.com>**20041218025451
This was my first real experiment with Haskell, so someone who knows better
will probably want to rewrite it. :)
Also, this only addresses the 'pull' case. It may be better put this logic in a
shared routine, so it be used by 'push' and elsewhere.
]
[remove trailing whitespace
simons at cryp.to**20041218004144]
[don't import type 'Patch' twice
simons at cryp.to**20041218004106]
[remove duplicate imports (error in ghc-6.3)
simons at cryp.to**20041218002402]
[avoid conflicts by importing only 'bug' from DarcsUtils
simons at cryp.to**20041218002301]
[Fix manual to state 'darcs get' has --tag, not --tag-name
zander at kde.org**20041217153547]
[strip trailing CR in pref files
Will <will at glozer.net>**20041216073907]
[fix typo in mingw reference
Lode Leroy <lode_leroy at hotmail.com>**20041202131840]
[fix bug that left junk equal to identity patch in pending.
David Roundy <droundy at abridgegame.org>**20041215134337]
[typo fix
Mark Stosberg <mark at summersault.com>**20041215023027]
[removing Amending patches from basic documentation
Mark Stosberg <mark at summersault.com>**20041106030942
I really like this clear description of what Amend record is actually doing.
I've submitted a patch to the stable repo to merge some of the wording here
into the (currently sparse) docs for admend-record.
Amend-record is a more advanced, dangerous command which doesn't belong in a
"Basics" section, so I removed it here.
]
[improve documentation clarity
Mark Stosberg <mark at summersault.com>**20041106030733]
[improve formatting of 'working' and 'current'
Mark Stosberg <mark at summersault.com>**20041106030657]
[documentation, basics on creating patches
Tommy Pettersson <ptp at lysator.liu.se>**20041103111151]
[update webpage to say 1.0.1 is latest stable source now.
David Roundy <droundy at abridgegame.org>**20041214134854]
[TAG 1.0.1
David Roundy <droundy at abridgegame.org>**20041214131758]
Patch bundle hash:
ad9309b1e65ce6ea760d910e4c73c49cdefcb896
More information about the darcs-devel
mailing list