Fix description merging

make-pages/Info.hs

@@ -16,7 +16,7 @@ import Records
 
 import Control.Applicative
 import Control.Exception
-import Data.Foldable (find, foldl')
+import Data.Foldable (find)
 import Data.Hashable (Hashable)
 import Data.HashSet (HashSet)
 import qualified Data.HashSet as HashSet
@@ -149,15 +149,21 @@ instance Semigroup Desc where
   (TextDesc t1) <> (TextDesc t2) = TextDesc $ t1 <> t2
   (LongDesc m1) <> (TextDesc t2) = LongDesc $ m1 <> [DescField defDescKey t2]
   (TextDesc t1) <> (LongDesc m2) = LongDesc $ [DescField defDescKey t1] <> m2
-  (LongDesc m1) <> (LongDesc m2) = LongDesc $ mergeDesc m1 m2
+  (LongDesc m1) <> (LongDesc m2) = LongDesc $ merge m1 m2
 
-mergeDesc :: [DescField] -> [DescField] -> [DescField]
+merge :: [DescField] -> [DescField] -> [DescField]
-mergeDesc = foldl' $ flip add where
+merge fs1 fs2 = go fs1 [] fs2 where
-  add d2 = map \d1 ->
+  go first unused []     = first <> reverse unused
-    if #name d1 == #name d2 then
+  go first unused (x:xs) =
-      d1 {text = #text d1 <> #text d2}
+    case insert first x of
+      Just first' -> go first' unused     xs
+      Nothing     -> go first  (x:unused) xs
+  insert []     _ = Nothing
+  insert (x:xs) y =
+    if #name x == #name y then
+      Just $ x {text = #text x <> #text y} : xs
     else
-      d1
+      (x :) <$> insert xs y
 
 instance Monoid Desc where
   mempty = NoDesc