{-# LANGUAGE OverloadedStrings #-}

{- |
 Module      :  Text.PrettyPrint.Boxes
 Copyright   :  (c) Brent Yorgey 2009
 License     :  BSD-style (see LICENSE)
 Maintainer  :  David.Feuer@gmail.com
 Stability   :  experimental
 Portability :  portable

 A pretty-printing library for laying out text in two dimensions,
 using a simple box model.
-}
module Literate.Box where

import Control.Arrow (first, (***))
import Data.Foldable (toList)
import Data.List (foldl', intersperse)
import Data.String (IsString (..))
import Prelude hiding (Word, (<>))

-- Use the build from GHC.Exts because GHC has some rules that make it faster.
import GHC.Exts (build)

{- | The basic data type.  A box has a specified size and some sort of
   contents.
-}
data Box = Box
  { rows :: Int
  , cols :: Int
  , content :: Content
  }
  deriving (Show)

-- | Contents of a box.
data Content
  = -- | No content.
    Blank
  | -- | A raw string.
    Text String
  | -- | A row of sub-boxes.
    Row [Box]
  | -- | A column of sub-boxes.
    Col [Box]
  | -- | A sub-box with a specified alignment.
    SubBox Alignment Alignment Box
  deriving (Show)

instance IsString Box where
  fromString t = Box 1 (length t) (Text t)

-- | Data type for specifying the alignment of boxes.
data Alignment
  = -- | Align at the top/left.
    AlignTopLeft
  | -- | Centered, biased to the top/left.
    AlignTopLeftCenter
  | -- | Centered, biased to the bottom/right.
    AlignBottomRightCenter
  | -- | Align at the bottom/right.
    AlignBottomRight
  deriving (Eq, Read, Show)

{- | The null box, which has no content and no size.  It is quite
   useless.
-}
nullBox :: Box
nullBox = emptyBox 0 0

{- | @emptyBox r c@ is an empty box with @r@ rows and @c@ columns.
   Useful for effecting more fine-grained positioning of other
   boxes, by inserting empty boxes of the desired size in between
   them.
-}
emptyBox :: Int -> Int -> Box
emptyBox r c = Box r c Blank

-- | A @1x1@ box containing a single character.
char :: Char -> Box
char c = Box 1 1 (Text [c])

{- | Paste two boxes together horizontally, using a default (top)
   alignment.
-}
(<>) :: Box -> Box -> Box
l <> r = hcat AlignTopLeft [l, r]

{- | Paste two boxes together horizontally with a single intervening
   column of space, using a default (top) alignment.
-}
(<+>) :: Box -> Box -> Box
l <+> r = hcat AlignTopLeft [l, emptyBox 0 1, r]

{- | Paste two boxes together vertically, using a default (left)
   alignment.
-}
(//) :: Box -> Box -> Box
t // b = vcat AlignTopLeft [t, b]

{- | Paste two boxes together vertically with a single intervening row
   of space, using a default (left) alignment.
-}
(/+/) :: Box -> Box -> Box
t /+/ b = vcat AlignTopLeft [t, emptyBox 1 0, b]

-- | Glue a list of boxes together horizontally, with the given alignment.
hcat :: Foldable f => Alignment -> f Box -> Box
hcat a bs = Box h w (Row $ map (alignVert a h) bsl)
 where
  (w, h) = sumMax cols 0 rows bsl
  bsl = toList bs

{- | @hsep sep a bs@ lays out @bs@ horizontally with alignment @a@,
   with @sep@ amount of space in between each.
-}
hsep :: Foldable f => Int -> Alignment -> f Box -> Box
hsep sep a bs = punctuateH a (emptyBox 0 sep) bs

-- | Glue a list of boxes together vertically, with the given alignment.
vcat :: Foldable f => Alignment -> f Box -> Box
vcat a bs = Box h w (Col $ map (alignHoriz a w) bsl)
 where
  (h, w) = sumMax rows 0 cols bsl
  bsl = toList bs

-- Calculate a sum and a maximum over a list in one pass. If the list is
-- empty, the maximum is reported as the given default. This would
-- normally be done using the foldl library, but we don't want that
-- dependency.
sumMax :: (Num n, Ord b, Foldable f) => (a -> n) -> b -> (a -> b) -> f a -> (n, b)
sumMax f defaultMax g as = foldr go (,) as 0 defaultMax
 where
  go a r n b = (r $! f a + n) $! g a `max` b

{- | @vsep sep a bs@ lays out @bs@ vertically with alignment @a@,
   with @sep@ amount of space in between each.
-}
vsep :: Foldable f => Int -> Alignment -> f Box -> Box
vsep sep a bs = punctuateV a (emptyBox sep 0) (toList bs)

{- | @punctuateH a p bs@ horizontally lays out the boxes @bs@ with a
   copy of @p@ interspersed between each.
-}
punctuateH :: Foldable f => Alignment -> Box -> f Box -> Box
punctuateH a p bs = hcat a (intersperse p (toList bs))

-- | A vertical version of 'punctuateH'.
punctuateV :: Foldable f => Alignment -> Box -> f Box -> Box
punctuateV a p bs = vcat a (intersperse p (toList bs))

--------------------------------------------------------------------------------
--  Paragraph flowing  ---------------------------------------------------------
--------------------------------------------------------------------------------

{- | @para algn w t@ is a box of width @w@, containing text @t@,
   aligned according to @algn@, flowed to fit within the given
   width.
>>> para AlignTopLeft 10 "12 34 56 78 9 10 11 12"
Box {rows = 3, cols = 10, content = SubBox AlignTopLeft AlignTopLeft (Box {rows = 3, cols = 10, content = Col
[Box {rows = 1, cols = 10, content = SubBox AlignTopLeft AlignTopLeft (Box {rows = 1, cols = 8, content = Text "12 34 56"})}
,Box {rows = 1, cols = 10, content = SubBox AlignTopLeft AlignTopLeft (Box {rows = 1, cols = 10, content = Text "78 9 10 11"})}
,Box {rows = 1, cols = 10, content = SubBox AlignTopLeft AlignTopLeft (Box {rows = 1, cols = 2, content = Text "12"})}]})}
-}
para :: Alignment -> Int -> String -> Box
para a n t = (\ss -> mkParaBox a (length ss) ss) $ flow n t

{- | @columns w h t@ is a list of boxes, each of width @w@ and height
   at most @h@, containing text @t@ flowed into as many columns as
   necessary.
>>> error $ render $ hcat AlignTopLeft $ columns AlignTopLeft 10 5 "1 2 3 4 5 6 7 8 9 10 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29"
1 2 3 4 5 21 22 23
6 7 8 9 1024 25 26
12 13 14  27 28 29
15 16 17
18 19 20
-}
columns :: Alignment -> Int -> Int -> String -> [Box]
columns a w h t = map (mkParaBox a h) . chunksOf h $ flow w t

{- | @'chunksOf' n@ splits a list into length-n pieces.  The last
   piece will be shorter if @n@ does not evenly divide the length of
   the list.  If @n <= 0@, @'chunksOf' n l@ returns an infinite list
   of empty lists.  For example:

   Note that @'chunksOf' n []@ is @[]@, not @[[]]@.  This is
   intentional, and is consistent with a recursive definition of
   'chunksOf'; it satisfies the property that

   @chunksOf n xs ++ chunksOf n ys == chunksOf n (xs ++ ys)@

   whenever @n@ evenly divides the length of @xs@.
-}
chunksOf :: Int -> [e] -> [[e]]
chunksOf i ls = map (take i) (build (splitter ls))
 where
  splitter :: [e] -> ([e] -> a -> a) -> a -> a
  splitter [] _ n = n
  splitter l c n = l `c` splitter (drop i l) c n

{- | @mkParaBox a n s@ makes a box of height @n@ with the text @s@
   aligned according to @a@.
-}
mkParaBox :: Alignment -> Int -> [String] -> Box
mkParaBox a n = alignVert AlignTopLeft n . vcat a . map fromString

{- | Flow the given text into the given width.
>>> flow 10 "1234567890abc abcdefghijkl"
["1234567890","abcdefghij"]

>>> flow 10 "1234567890abcdefghij"
["1234567890"]
-}
flow :: Int -> String -> [String]
flow n t =
  (take n <$>) . getLines $
  foldl' addWordP (emptyPara n) (fromString <$> words t)

-- * Type 'Para'
data Para = Para
  { paraWidth :: Int
  , unPara :: ParaContent
  }
data ParaContent = ParaContent
  { paraLines :: [Line]
  , paraLastLine :: Line
  }

emptyPara :: Int -> Para
emptyPara pw = Para pw (ParaContent [] (Line 0 []))

getLines :: Para -> [String]
getLines (Para _ (ParaContent ls l))
  | lineLen l == 0 = process ls
  | otherwise = process (l : ls)
 where
  process = map (unwords . reverse . map unWord . unLine) . reverse
-- ** Type 'Line'
data Line = Line
  { lineLen :: Int
  , unLine :: [Word]
  }

mkLine :: [Word] -> Line
mkLine ws = Line (sum (map ((+ 1) . wordLen) ws) - 1) ws

startLine :: Word -> Line
startLine = mkLine . (: [])

-- ** Type 'Word
data Word = Word
  { wordLen :: Int
  , unWord :: String
  }

instance IsString Word where
  fromString w = Word (length w) w

addWordP :: Para -> Word -> Para
addWordP (Para pw (ParaContent fl l)) w
  | wordFits pw w l = Para pw (ParaContent fl (addWordL w l))
  | otherwise = Para pw (ParaContent (l : fl) (startLine w))

addWordL :: Word -> Line -> Line
addWordL w (Line len ws) = Line (len + wordLen w + 1) (w : ws)

wordFits :: Int -> Word -> Line -> Bool
wordFits pw w l = lineLen l == 0 || lineLen l + wordLen w + 1 <= pw

--------------------------------------------------------------------------------
--  Alignment  -----------------------------------------------------------------
--------------------------------------------------------------------------------

{- | @alignHoriz algn n bx@ creates a box of width @n@, with the
   contents and height of @bx@, horizontally aligned according to
   @algn@.
-}
alignHoriz :: Alignment -> Int -> Box -> Box
alignHoriz a c b = align a AlignTopLeft (rows b) c b

{- | @alignVert algn n bx@ creates a box of height @n@, with the
   contents and width of @bx@, vertically aligned according to
   @algn@.
>>> error $ render $ alignVert AlignTopLeft 4 "123"
123
   
   


>>> error $ render $ alignVert AlignBottomRight 4 "123"
   
   
   
123
   
-}
-- | >>> error $ render $ alignVert AlignBottomRightCenter 4 "123"
--    
--    
-- 123
--    
--    
--    
-- 123
--    
-- | >>> error $ render $ alignVert AlignTopLeftCenter 4 "123"
--    
-- 123
--    
--    

alignVert :: Alignment -> Int -> Box -> Box
alignVert a r b = align AlignTopLeft a r (cols b) b

{- | @align ah av r c bx@ creates an @r@ x @c@ box with the contents
   of @bx@, aligned horizontally according to @ah@ and vertically
   according to @av@.
-}
align :: Alignment -> Alignment -> Int -> Int -> Box -> Box
align ah av r c = Box r c . SubBox ah av

{- | Move a box \"up\" by putting it in a larger box with extra rows,
   aligned to the top.  See the disclaimer for 'moveLeft'.
-}
moveUp :: Int -> Box -> Box
moveUp n b = alignVert AlignTopLeft (rows b + n) b

{- | Move a box down by putting it in a larger box with extra rows,
   aligned to the bottom.  See the disclaimer for 'moveLeft'.
-}
moveDown :: Int -> Box -> Box
moveDown n b = alignVert AlignBottomRight (rows b + n) b

{- | Move a box left by putting it in a larger box with extra columns,
   aligned left.  Note that the name of this function is
   something of a white lie, as this will only result in the box
   being moved left by the specified amount if it is already in a
   larger right-aligned context.

>>> error $ render $ moveLeft 4 "123"
123    

>>> error $ render $ alignHoriz AlignBottomRight 20 $ moveLeft 15 "123"
  123

>>> error $ render $ alignHoriz AlignTopLeft 10 $ moveLeft 15 "123"
123

-}
moveLeft :: Int -> Box -> Box
moveLeft n b = alignHoriz AlignTopLeft (cols b + n) b

{- | Move a box right by putting it in a larger box with extra
   columns, aligned right.  See the disclaimer for 'moveLeft'.

>>> error $ render $ moveRight 4 "123"
    123
-}
moveRight :: Int -> Box -> Box
moveRight n b = alignHoriz AlignBottomRight (cols b + n) b

--------------------------------------------------------------------------------
--  Implementation  ------------------------------------------------------------
--------------------------------------------------------------------------------

{- | Render a 'Box' as a String, suitable for writing to the screen or
   a file.
-}
render :: Box -> String
render = unlines . renderBox

-- XXX make QC properties for takeExactly

{- | \"Padded take\": @takeExactly a n xs@ is the same as @take n xs@, if @n
   <= length xs@; otherwise it is @xs@ followed by enough copies of
   @a@ to make the length equal to @n@.
-}
takeExactly :: a -> Int -> [a] -> [a]
takeExactly _ n _ | n <= 0 = []
takeExactly pad n [] = replicate n pad
takeExactly pad n (x : xs) = x : takeExactly pad (n - 1) xs

{- | @takeExactlyAligned @ is like 'takeExactly', but with alignment.  That is, we
   imagine a copy of @xs@ extended infinitely on both sides with
   copies of @a@, and a window of size @n@ placed so that @xs@ has
   the specified alignment within the window; @takeExactlyAligned algn a n xs@
   returns the contents of this window.
>>> takeExactlyAligned AlignTopLeft ' ' 10 "12345"
"12345     "

>>> takeExactlyAligned AlignBottomRight ' ' 10 "12345"
"     12345"

>>> takeExactlyAligned AlignTopLeftCenter ' ' 10 "12345"
"  12345   "

>>> takeExactlyAligned AlignBottomRightCenter ' ' 10 "12345"
"   12345  "
-}
takeExactlyAligned :: Alignment -> a -> Int -> [a] -> [a]
takeExactlyAligned ali pad len l =
  reverse (takeExactly pad (leftLen ali len) (reverse leftList))
    ++ takeExactly pad (rightLen ali len) rightList
 where
  (leftList, rightList) = splitAt (leftLen ali (length l)) l

  rightLen AlignTopLeft n = n
  rightLen AlignTopLeftCenter n = n `div` 2
  rightLen AlignBottomRight _ = 0
  rightLen AlignBottomRightCenter n = (n + 1) `div` 2

  leftLen a n = n - rightLen a n

-- | Generate a string of spaces.
blanks :: Int -> String
blanks = flip replicate ' '

-- | Render a box as a list of lines.
renderBox :: Box -> [String]
renderBox (Box r c Blank) = resizeBox r c [""]
renderBox (Box r c (Text t)) = resizeBox r c [t]
renderBox (Box r c (Row bs)) =
  resizeBox r c $ merge $ (\b -> renderBox b{rows=r}) <$> bs
 where
  merge = foldr (zipWith (++)) (repeat [])
renderBox (Box r c (Col bs)) =
  resizeBox r c $ concatMap (\b -> renderBox b{cols=c}) bs
renderBox (Box r c (SubBox ha va b)) =
  takeExactlyAligned va (blanks c) r $
  takeExactlyAligned ha ' ' c <$> renderBox b

{- | Resize a rendered list of lines.
>>> resizeBox 5 4 ["1 2 3 4 5 6 7 8 9", "10 11 12 13 14 15 16 17 18 19"]
["1 2 ","10 1","    ","    ","    "]
-}
resizeBox :: Int -> Int -> [String] -> [String]
resizeBox rowLen colLen ls =
  takeExactly (blanks colLen) rowLen $
  takeExactly ' ' colLen <$> ls

-- | A convenience function for rendering a box to stdout.
printBox :: Box -> IO ()
printBox = putStr . render

{- >>> error $ render $ ("123" // "4") <+> ("toto" <+> "foo" // "titi") <+> "bar"
123 toto foo bar
4   titi        

-}

{-
-- | Align boxes along their tops.
top :: Alignment
top = AlignFirst

-- | Align boxes along their bottoms.
bottom :: Alignment
bottom = AlignBottomRight

-- | Align boxes to the left.
left :: Alignment
left = AlignFirst

-- | Align boxes to the right.
right :: Alignment
right = AlignBottomRight

{- | Align boxes centered, but biased to the left/top in case of
   unequal parities.
-}
center1 :: Alignment
center1 = AlignTopLeftCenter

{- | Align boxes centered, but biased to the right/bottom in case of
   unequal parities.
-}
center2 :: Alignment
center2 = AlignBottomRightCenter
-}