rhi/gallery
1
0
Fork 0
Code Issues 5 Pull requests 1 Releases Wiki Activity

Fix description merging

Browse source
This commit is contained in:
Rhiannon Morris 2021-03-08 01:26:29 +01:00
parent 85199c1105
commit 5c90ba871f
1 changed files with 14 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

22
make-pages/Info.hs
View file

@ -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]
mergeDesc = foldl' $ flip add where
add d2 = map \d1 ->
if #name d1 == #name d2 then
d1 {text = #text d1 <> #text d2}
merge :: [DescField] -> [DescField] -> [DescField]
merge fs1 fs2 = go fs1 [] fs2 where
go first unused [] = first <> reverse unused
go first unused (x:xs) =
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