remove uses of head/tail

make-pages/BuilderQQ.hs

@@ -19,6 +19,7 @@ import qualified Data.Text.Lazy as LText
 import Data.Text.Lazy (toStrict)
 import Data.Foldable
 import Data.Semigroup
+import Data.List.NonEmpty (NonEmpty)
 
 data ChunkType = Lit | Var VarType deriving Show
 data VarType =
@@ -188,3 +189,7 @@ deriving via ShowBuild Integer instance CanBuild Integer
 instance {-# OVERLAPPABLE #-} CanBuild a => CanBuild [a] where
   build = foldMap \x -> build x <> "\n"
   reindent n = fold . intersperse ("\n" <> replicateB n ' ') . map build
+
+instance CanBuild a => CanBuild (NonEmpty a) where
+  build      = build . toList
+  reindent n = reindent n . toList

make-pages/Depend.hs

@@ -9,6 +9,7 @@ import Info hiding (Text)
 
 import Data.Maybe (fromMaybe, mapMaybe)
 import Data.Text.Lazy (Text)
+import Data.Foldable
 import System.FilePath
 
 
@@ -27,7 +28,9 @@ dependSingle' :: FilePath -> FilePath -> Info -> FilePath -> FilePath -> Bool
 dependSingle' yamlDir indexFile info prefix build nsfw =
   [b|$page: $deps $indexFile $$(MAKEPAGES)|]
  where
-  images = #all if nsfw then #images info else #sfwImages info
+  images =
+    maybe [] (toList . #all) $
+    if nsfw then Just $ #images info else #sfwImages info
 
   paths  = map #path images
   dls    = mapMaybe #download images

make-pages/Info.hs

@@ -12,7 +12,7 @@ module Info
    readArtistFilter, matchArtist, readNsfwFilter, matchNsfw, matchFilters,
    NoThumb (..), getThumb, thumbFile, pageFile, bigFile,
    -- ** Reexports
-   Date (..), Day (..), Text)
+   Date (..), Day (..), Text, NonEmpty (..))
 where
 
 import Date
@@ -28,8 +28,9 @@ import qualified Data.HashSet as HashSet
 import qualified Data.Map.Strict as Map
 import Data.Set (Set, (\\))
 import qualified Data.Set as Set
-import Data.Maybe (isJust, isNothing, fromMaybe, mapMaybe)
+import Data.Maybe (isJust, isNothing, fromMaybe, mapMaybe, catMaybes)
 import Data.List (nub, sortBy)
+import Data.List.NonEmpty (NonEmpty (..), toList, nonEmpty)
 import Data.Ord (comparing)
 import Data.String (IsString)
 import Data.Text (Text)
@@ -38,6 +39,7 @@ import Data.YAML (FromYAML (..), (.:), (.:?), (.!=))
 import qualified Data.YAML as YAML
 import System.FilePath ((</>), takeBaseName, takeExtension, splitExtension)
 import Data.Bifunctor (second)
+import Data.Semigroup
 
 
 data Info =
@@ -98,8 +100,8 @@ data Image =
   deriving (Eq, Show)
 
 data Images' a =
-    Uncat [a]         -- ^ uncategorised
+    Uncat (NonEmpty a)         -- ^ uncategorised
-  | Cat [(Text, [a])] -- ^ categorised
+  | Cat (NonEmpty (Text, NonEmpty a)) -- ^ categorised
   deriving (Eq, Show, Functor, Foldable, Traversable)
 
 type Images = Images' Image
@@ -125,23 +127,29 @@ instance HasField "sfw" Image  Bool where getField = not . #nsfw
 instance HasField "sfw" Link   Bool where getField = not . #nsfw
 instance HasField "sfw" Update Bool where getField = not . #nsfw
 
-instance HasField "all" (Images' a) [a] where
+instance HasField "all" (Images' a) (NonEmpty a) where
   getField (Uncat is) = is
-  getField (Cat cats) = foldMap snd cats
+  getField (Cat cats) = sconcat $ fmap snd cats
 
-filterImages :: (a -> Bool) -> Images' a -> Images' a
+filterNE :: (a -> Bool) -> NonEmpty a -> Maybe (NonEmpty a)
-filterImages p (Uncat is) = Uncat $ filter p is
+filterNE p = nonEmpty . filter p . toList
+
+catMaybesNE :: NonEmpty (Maybe a) -> Maybe (NonEmpty a)
+catMaybesNE = nonEmpty . catMaybes . toList
+
+filterImages :: (a -> Bool) -> Images' a -> Maybe (Images' a)
+filterImages p (Uncat is) = Uncat <$> filterNE p is
 filterImages p (Cat cats) =
-  Cat $ filter (not . null . snd) $ map (second $ filter p) cats
+  fmap Cat $ catMaybesNE $ fmap (traverse $ filterNE p) cats
 
-instance HasField "sfwImages" Info Images where
+instance HasField "sfwImages" Info (Maybe Images) where
   getField = filterImages #sfw . #images
-instance HasField "nsfwImages" Info Images where
+instance HasField "nsfwImages" Info (Maybe Images) where
   getField = filterImages #nsfw . #images
-instance HasField "allNsfw" Info Bool where getField = null . #all . #sfwImages
+instance HasField "anySfw"  Info Bool where getField = isJust . #sfwImages
-instance HasField "allSfw" Info Bool where getField = null . #all . #nsfwImages
+instance HasField "anyNsfw" Info Bool where getField = isJust . #nsfwImages
-instance HasField "anySfw" Info Bool where getField = not . #allNsfw
+instance HasField "allNsfw" Info Bool where getField = not    . #anySfw
-instance HasField "anyNsfw" Info Bool where getField = not . #allSfw
+instance HasField "allSfw"  Info Bool where getField = not    . #anyNsfw
 
 instance HasField "sfwLinks" Info [Link] where
   getField = filter #sfw . #links
@@ -212,8 +220,8 @@ descFor nsfw (Info {desc, nsfwDesc}) = if nsfw then desc <> nsfwDesc else desc
 tagsFor :: Bool -> Info -> [Text]
 tagsFor nsfw i = if nsfw then nub (#tags i <> #nsfwTags i) else #tags i
 
-imagesFor :: Bool -> Info -> Images
+imagesFor :: Bool -> Info -> Maybe Images
-imagesFor nsfw = if nsfw then #images else #sfwImages
+imagesFor nsfw = if nsfw then Just . #images else #sfwImages
 
 linksFor :: Bool -> Info -> [Link]
 linksFor nsfw = if nsfw then #links else #sfwLinks
@@ -322,8 +330,14 @@ instance FromYAML Desc where
 
 instance FromYAML DescField where parseYAML = withPair DescField
 
-imageList :: YAML.Node YAML.Pos -> YAML.Parser [Image]
+parseYAMLNE :: FromYAML a => YAML.Node YAML.Pos -> YAML.Parser (NonEmpty a)
-imageList y = pure <$> unlabelledImage y <|> parseYAML y
+parseYAMLNE = YAML.withSeq "non-empty sequence" \ys ->
+  case nonEmpty ys of
+    Just ys' -> traverse YAML.parseYAML ys'
+    Nothing  -> fail "expected non-empty sequence"
+
+imageList :: YAML.Node YAML.Pos -> YAML.Parser (NonEmpty Image)
+imageList y = pure <$> unlabelledImage y <|> parseYAMLNE y
 
 instance FromYAML Image where
   parseYAML y = unlabelledImage y <|> labelled y where
@@ -353,7 +367,10 @@ unlabelledImage' label' y = asStr y <|> asObj y
 instance FromYAML Images where
   parseYAML y = Uncat <$> imageList y
             <|> Cat   <$> YAML.withSeq "list of categories" fromPairs y
-    where fromPairs = traverse $ withPairM \label -> fmap (label,) . imageList
+   where
+    fromPairs (nonEmpty -> Just xs) =
+      traverse (withPairM \label -> fmap (label,) . imageList) xs
+    fromPairs _ = YAML.typeMismatch "non-empty list" y
 
 instance FromYAML Link where
   parseYAML =

make-pages/SinglePage.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE PatternSynonyms #-}
 module SinglePage (make) where
 
 import Date
@@ -15,6 +16,7 @@ import qualified Data.Text.Lazy as Lazy
 import System.FilePath (joinPath, splitPath)
 import qualified Data.HashSet as Set
 import Data.Traversable
+import Data.Semigroup
 
 
 -- | e.g. only nsfw images are present for a non-nsfw page
@@ -41,7 +43,7 @@ make' :: Text -> Text -> FilePath -> Bool -> FilePath -> FilePath -> Info
       -> IO Builder
 make' root siteName prefix nsfw _dataDir dir
       info@(Info {date, title, artist, bg}) = do
-  let images = imagesFor nsfw info
+  images <- maybe (throw $ NoEligibleImages title) pure $ imagesFor nsfw info
 
   let undir = joinPath (replicate (length (splitPath dir)) "..")
 
@@ -49,9 +51,8 @@ make' root siteName prefix nsfw _dataDir dir
 
   let buttonBar = makeButtonBar title $ addIds images
 
-  let allImages = #all images
+  let image0 :| otherImages = #all images
-  let image0@(Image {path = path0, download = download0'}) = head allImages
+  let Image {path = path0, download = download0'} = image0
-  let otherImages = tail allImages
 
   let download0 = fromMaybe (bigFile path0) download0'
   let path0'    = pageFile path0
@@ -229,27 +230,44 @@ makeDesc (LongDesc fs) = [b|@0
       </div>
     |]
 
+
+data Inf a = a :> Inf a deriving Functor
+
+headI :: Inf a -> a
+headI (x :> _) = x
+
+suffixes :: Inf String
+suffixes = "" :> go 0 where
+  go :: Int -> Inf String
+  go i = show i :> go (i + 1)
+
+filterI :: (a -> Bool) -> Inf a -> Inf a
+filterI p (x :> xs) = if p x then x :> filterI p xs else filterI p xs
+
 addIds :: Traversable t => t Image -> t (Image, Text)
 addIds = snd . mapAccumL makeId Set.empty where
   makeId used img = (Set.insert newId used, (img, newId)) where
-    newId = head $ filter (\i -> not $ i `Set.member` used) ids
+    newId = headI $ filterI (\i -> not $ i `Set.member` used) ids
-    ids = [toStrictText [b|$label$i|] | i <- "" : map show [0::Int ..]]
+    ids   = fmap (\i -> toStrictText [b|$label$i|]) suffixes
     label = escId $ #label img
 
+
+pattern One :: a -> NonEmpty a
+pattern One x = x :| []
+
 makeButtonBar :: Strict.Text -> Images' (Image, Text) -> Builder
 makeButtonBar title images =
   case images of
-    Uncat []        -> throw $ NoEligibleImages title
+    Uncat (One _)          -> ""
-    Uncat [_]       -> ""
+    Cat   (One (_, One _)) -> ""
-    Cat   [(_,[_])] -> ""
+    Uncat imgs             -> makeNav "uncat" $ makeAlts imgs
-    Uncat imgs      -> makeNav "uncat" $ makeAlts imgs
     Cat   cats
-      | all ((<= 1) . length . snd) cats ->
+      | all ((== 1) . length . snd) cats ->
           makeButtonBar title $ Uncat $ flatten cats
       | [(_, imgs)] <- cats ->
           makeButtonBar title (Uncat imgs)
       | otherwise ->
-          makeNav "cat" $ map (uncurry makeCat) cats
+          makeNav "cat" $ fmap (uncurry makeCat) cats
  where
   makeNav :: CanBuild b => Text -> b -> Builder
   makeNav cls inner = [b|@0
@@ -267,7 +285,7 @@ makeButtonBar title images =
        <ul class="buttonbar bb-choice">
          $2.elems
        </ul> |]
-    where elems = map (uncurry altButton) imgs
+    where elems = fmap (uncurry altButton) imgs
   skipAll =
     if any (isJust . #warning . fst) images then
       [b|@0
@@ -278,9 +296,10 @@ makeButtonBar title images =
       |]
     else ""
 
-flatten :: [(Text, [(Image, a)])] -> [(Image, Text)]
+flatten :: NonEmpty (Text, NonEmpty (Image, a)) -> NonEmpty (Image, Text)
-flatten cats =
+flatten =
-  addIds [(img {label = cat}) | (cat, is) <- cats, (img, _) <- is]
+  addIds . sconcat .
+  fmap (\(t, is) -> fmap (\(i, _) -> i {label = t}) is)
 
 altButton :: Image -> Text -> Builder
 altButton img i = [b|@0