FreeText.hs

{-# LANGUAGE OverloadedStrings #-}

module CabalGild.FreeText
  ( fieldlinesToFreeText,
    showFreeText,
  )
where

import Data.List (foldl')
import qualified Data.List as List
import qualified Distribution.CabalSpecVersion as C
import qualified Distribution.Fields.Field as C
import qualified Distribution.Parsec as C
import qualified Distribution.Parsec.Position as C
import qualified Distribution.Pretty as C
import Distribution.Utils.Generic (fromUTF8BS)
import qualified Distribution.Utils.String as C (trim)
import qualified Text.PrettyPrint as PP

showFreeText :: C.CabalSpecVersion -> String -> PP.Doc
showFreeText v
  | v >= C.CabalSpecV3_0 =
      C.showFreeTextV3
  | otherwise =
      C.showFreeText

-- This should perfectly be exported from Cabal-syntax
fieldlinesToFreeText :: C.CabalSpecVersion -> C.Position -> [C.FieldLine C.Position] -> String
fieldlinesToFreeText v
  | v >= C.CabalSpecV3_0 =
      fieldlinesToFreeText3
  | otherwise =
      const fieldlinesToFreeText2

fieldlinesToFreeText2 :: [C.FieldLine C.Position] -> String
fieldlinesToFreeText2 [C.FieldLine _ "."] = "."
fieldlinesToFreeText2 fls = List.intercalate "\n" (map go fls)
  where
    go :: C.FieldLine ann -> String
    go (C.FieldLine _ bs)
      | s == "." = ""
      | otherwise = s
      where
        s = C.trim (fromUTF8BS bs)

fieldlinesToFreeText3 :: C.Position -> [C.FieldLine C.Position] -> String
fieldlinesToFreeText3 _ [] = ""
fieldlinesToFreeText3 _ [C.FieldLine _ bs] = fromUTF8BS bs
fieldlinesToFreeText3 pos (C.FieldLine pos1 bs1 : fls2@(C.FieldLine pos2 _ : _))
  -- if first line is on the same line with field name:
  -- the indentation level is either
  -- 1. the indentation of left most line in rest fields
  -- 2. the indentation of the first line
  -- whichever is leftmost
  | C.positionRow pos == C.positionRow pos1 =
      concat $
        fromUTF8BS bs1
          : mealy (mk mcol1) pos1 fls2
  -- otherwise, also indent the first line
  | otherwise =
      concat $
        replicate (C.positionCol pos1 - mcol2) ' '
          : fromUTF8BS bs1
          : mealy (mk mcol2) pos1 fls2
  where
    mcol1 = foldl' (\a b -> min a $ C.positionCol $ C.fieldLineAnn b) (min (C.positionCol pos1) (C.positionCol pos2)) fls2
    mcol2 = foldl' (\a b -> min a $ C.positionCol $ C.fieldLineAnn b) (C.positionCol pos1) fls2

    mk :: Int -> C.Position -> C.FieldLine C.Position -> (C.Position, String)
    mk col p (C.FieldLine q bs) =
      ( q,
        -- in Cabal-syntax there is no upper limit, i.e. no min
        -- we squash multiple empty lines to one
        replicate (min 2 newlines) '\n'
          ++ replicate indent ' '
          ++ fromUTF8BS bs
      )
      where
        newlines = C.positionRow q - C.positionRow p
        indent = C.positionCol q - col

mealy :: (s -> a -> (s, b)) -> s -> [a] -> [b]
mealy f = go
  where
    go _ [] = []
    go s (x : xs) = let ~(s', y) = f s x in y : go s' xs