{-# LANGUAGE OverloadedStrings #-}
module CabalFmt.FreeText (
    fieldlinesToFreeText,
    showFreeText,
) where

import Data.List (foldl')

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 qualified Distribution.Utils.String     as C (trim)
import qualified Text.PrettyPrint              as PP

import CabalFmt.Prelude

showFreeText :: C.CabalSpecVersion -> String -> PP.Doc
showFreeText :: CabalSpecVersion -> [Char] -> Doc
showFreeText CabalSpecVersion
v
    | CabalSpecVersion
v CabalSpecVersion -> CabalSpecVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= CabalSpecVersion
C.CabalSpecV3_0
    = [Char] -> Doc
C.showFreeTextV3

    | Bool
otherwise
    = [Char] -> Doc
C.showFreeText

-- This should perfectly be exported from Cabal-syntax
fieldlinesToFreeText :: C.CabalSpecVersion -> C.Position -> [C.FieldLine C.Position] -> String
fieldlinesToFreeText :: CabalSpecVersion -> Position -> [FieldLine Position] -> [Char]
fieldlinesToFreeText CabalSpecVersion
v
    | CabalSpecVersion
v CabalSpecVersion -> CabalSpecVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= CabalSpecVersion
C.CabalSpecV3_0
    = Position -> [FieldLine Position] -> [Char]
fieldlinesToFreeText3

    | Bool
otherwise
    = \Position
_ -> [FieldLine Position] -> [Char]
fieldlinesToFreeText2

fieldlinesToFreeText2 :: [C.FieldLine C.Position] -> String
fieldlinesToFreeText2 :: [FieldLine Position] -> [Char]
fieldlinesToFreeText2 [C.FieldLine Position
_ ByteString
"."] = [Char]
"."
fieldlinesToFreeText2 [FieldLine Position]
fls = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" ((FieldLine Position -> [Char]) -> [FieldLine Position] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map FieldLine Position -> [Char]
forall {ann}. FieldLine ann -> [Char]
go [FieldLine Position]
fls)
  where
    go :: FieldLine ann -> [Char]
go (C.FieldLine ann
_ ByteString
bs)
      | [Char]
s [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"." = [Char]
""
      | Bool
otherwise = [Char]
s
      where
        s :: [Char]
s = [Char] -> [Char]
C.trim (ByteString -> [Char]
fromUTF8BS ByteString
bs)

fieldlinesToFreeText3 :: C.Position -> [C.FieldLine C.Position] -> String
fieldlinesToFreeText3 :: Position -> [FieldLine Position] -> [Char]
fieldlinesToFreeText3 Position
_ [] = [Char]
""
fieldlinesToFreeText3 Position
_ [C.FieldLine Position
_ ByteString
bs] = ByteString -> [Char]
fromUTF8BS ByteString
bs
fieldlinesToFreeText3 Position
pos (C.FieldLine Position
pos1 ByteString
bs1 : fls2 :: [FieldLine Position]
fls2@(C.FieldLine Position
pos2 ByteString
_ : [FieldLine Position]
_))
  -- 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
  | Position -> Int
C.positionRow Position
pos Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Position -> Int
C.positionRow Position
pos1 =
      [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
        ByteString -> [Char]
fromUTF8BS ByteString
bs1
          [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: (Position -> FieldLine Position -> (Position, [Char]))
-> Position -> [FieldLine Position] -> [[Char]]
forall s a b. (s -> a -> (s, b)) -> s -> [a] -> [b]
mealy (Int -> Position -> FieldLine Position -> (Position, [Char])
mk Int
mcol1) Position
pos1 [FieldLine Position]
fls2
  -- otherwise, also indent the first line
  | Bool
otherwise =
      [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
        Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Position -> Int
C.positionCol Position
pos1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
mcol2) Char
' '
          [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: ByteString -> [Char]
fromUTF8BS ByteString
bs1
          [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: (Position -> FieldLine Position -> (Position, [Char]))
-> Position -> [FieldLine Position] -> [[Char]]
forall s a b. (s -> a -> (s, b)) -> s -> [a] -> [b]
mealy (Int -> Position -> FieldLine Position -> (Position, [Char])
mk Int
mcol2) Position
pos1 [FieldLine Position]
fls2
  where
    mcol1 :: Int
mcol1 = (Int -> FieldLine Position -> Int)
-> Int -> [FieldLine Position] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
a FieldLine Position
b -> Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
a (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Position -> Int
C.positionCol (Position -> Int) -> Position -> Int
forall a b. (a -> b) -> a -> b
$ FieldLine Position -> Position
forall ann. FieldLine ann -> ann
C.fieldLineAnn FieldLine Position
b) (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Position -> Int
C.positionCol Position
pos1) (Position -> Int
C.positionCol Position
pos2)) [FieldLine Position]
fls2
    mcol2 :: Int
mcol2 = (Int -> FieldLine Position -> Int)
-> Int -> [FieldLine Position] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
a FieldLine Position
b -> Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
a (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Position -> Int
C.positionCol (Position -> Int) -> Position -> Int
forall a b. (a -> b) -> a -> b
$ FieldLine Position -> Position
forall ann. FieldLine ann -> ann
C.fieldLineAnn FieldLine Position
b) (Position -> Int
C.positionCol Position
pos1) [FieldLine Position]
fls2

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

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