[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