From 4ffe2d06dbc6c50ca14977cc722a1e2a92869c28 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Mon, 22 Aug 2022 23:20:10 +0200 Subject: [PATCH] wip --- src/Symantic/Plaintext/Output.hs | 23 +- src/Symantic/Plaintext/Writer.hs | 2 +- src/Symantic/Plaintext/Writer2.hs | 961 ++++++++++++++++++++++++++++++ symantic-plaintext.cabal | 4 +- 4 files changed, 985 insertions(+), 5 deletions(-) create mode 100644 src/Symantic/Plaintext/Writer2.hs diff --git a/src/Symantic/Plaintext/Output.hs b/src/Symantic/Plaintext/Output.hs index 3de457d..188bf2b 100644 --- a/src/Symantic/Plaintext/Output.hs +++ b/src/Symantic/Plaintext/Output.hs @@ -21,7 +21,9 @@ import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Builder qualified as TLB import Prelude (fromIntegral) +import Numeric.Natural (Natural) import Symantic.Plaintext.Classes +import Text.Show (Show) -- * Class 'Outputable' class @@ -68,6 +70,17 @@ instance Lengthable TL.Text where length = fromIntegral . TL.length isEmpty = TL.null +-- * Class 'Dimensionable' +class Dimensionable a where + width :: a -> Natural + height :: a -> Natural +instance Dimensionable a => Dimensionable (Line a) where + width = width . unLine + height _ = 1 +instance Dimensionable a => Dimensionable (Word a) where + width _ = 1 + height _ = 1 + -- * Class 'Splitable' class (Lengthable o, Monoid o) => Splitable o where tail :: o -> Maybe (o) @@ -107,18 +120,24 @@ instance Splitable TL.Text where break = TL.break -- ** Type 'Line' -newtype Line o = Line {unLine :: o} +newtype Line o = Line o deriving (Functor, Semigroup, Monoid, Lengthable, Splitable) + deriving stock (Show) +unLine :: Line o -> o +unLine (Line x) = x lines :: Splitable o => o -> [Line o] linesNoEmpty :: Splitable o => o -> [Line o] lines = (Line <$>) . splitOnChar (== '\n') linesNoEmpty = (Line <$>) . splitOnCharNoEmpty (== '\n') -- ** Type 'Word' -newtype Word o = Word {unWord :: o} +newtype Word o = Word o deriving (Functor, Semigroup, Monoid, Lengthable, Splitable) + deriving stock (Show) +unWord :: Word o -> o +unWord (Word x) = x words :: Splitable o => Line o -> [Word o] wordsNoEmpty :: Splitable o => Line o -> [Word o] words = (Word <$>) . splitOnChar (== ' ') . unLine diff --git a/src/Symantic/Plaintext/Writer.hs b/src/Symantic/Plaintext/Writer.hs index cd4e413..14ec300 100644 --- a/src/Symantic/Plaintext/Writer.hs +++ b/src/Symantic/Plaintext/Writer.hs @@ -693,7 +693,7 @@ padLineWriterChunkInits maxWidth (lineWidth, wordCount, line) = Line $ if maxWidth <= lineWidth -- The gathered line reached or overreached the maxWidth, - -- hence no padding id needed. + -- hence no padding is needed. || wordCount <= 1 then -- The case maxWidth <= lineWidth && wordCount == 1 -- can happen if first word's length is < maxWidth diff --git a/src/Symantic/Plaintext/Writer2.hs b/src/Symantic/Plaintext/Writer2.hs new file mode 100644 index 0000000..c3b14ed --- /dev/null +++ b/src/Symantic/Plaintext/Writer2.hs @@ -0,0 +1,961 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Symantic.Plaintext.Writer2 where + +import Control.Applicative (Alternative (..), Applicative (..)) +import Data.Bool +import Data.Char (Char) +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import Data.Functor (Functor (..), (<$>)) +import Data.List qualified as List +import Data.Maybe (Maybe (..), fromMaybe) +import Data.Monoid (Monoid (..)) +import Data.Ord (Ord (..)) +import Data.Semigroup (Semigroup (..)) +import Data.String (IsString (..), String) +import Data.Traversable (Traversable (traverse)) +import GHC.Natural ( + minusNatural, + minusNaturalMaybe, + quotRemNatural, + ) +import Numeric.Natural (Natural) +import Text.Show ( + Show (..), + showParen, + showString, + ) +import Prelude ( + Num (..), + error, + fromIntegral, + undefined, + ) + +--import qualified Data.Text.Lazy.Builder as TLB +--import qualified Data.Text.Lazy.Builder as TLB + +import Control.Monad (Monad ((>>=))) +import Data.Functor.Identity (Identity (..)) +import Data.Text.Internal.Fusion.Types (RS (RS3)) +import Data.Tuple (fst, snd, swap) +import Debug.Trace (trace, traceShow) +import GHC.IO.Exception (IOErrorType (SystemError)) +import GHC.List (sum) +import GHC.Real (Integral (div)) +import Symantic.Plaintext.Classes () +import Symantic.Plaintext.Output + +data Measured o = Measured + { measuredHorizontal :: Natural + , measuredVertical :: Natural + , unMeasured :: o + } +instance Dimensionable (Measured o) where + width = measuredHorizontal + height = measuredVertical + +-- renderRect :: Outputable o => Measured (Rect o) -> [o] +-- renderRect Measured{..} = case unMeasured of +-- RectEmpty -> [] +-- RectChunk o -> [o] +-- Rects{..} -> case rectDirection of +-- DirectionHorizontal -> [] + +resize :: Measured [o] -> [o] +resize Measured{..} = undefined + +-- | Doc: https://personal.cis.strath.ac.uk/conor.mcbride/so-pigworker.pdf#section.4.9 +data PaddedList a = (:-) + { padded :: [a] + , padder :: a + } + deriving (Show, Eq) + +infixr 5 :- + +instance Functor PaddedList where + fmap = (<*>) . pure +instance Applicative PaddedList where + pure = ([] :-) + as :- ap <*> bs :- bp = go as bs :- ap bp + where + go [] xs = ap <$> xs + go fs [] = ($ bp) <$> fs + go (f : fs) (x : xs) = f x : go fs xs + +-- >>> "om":-' ' <*> "mane":-' ' + +-- >>> "om":-' ' <*> "mane":-' ' +-- Couldn't match type ‘Char’ with ‘Char -> b’ +-- Expected type: PaddedList (Char -> b) +-- Actual type: PaddedList Char + +-- >>> deggar ' ' ["om", "mane", "padme", "hum12345"] +-- (:-) {padded = ["omph","maau"," ndm"," em1"," e2"," 3"," 4"," 5"], padder = " "} +deggar pad = traverse (:- pad) + +lines0 = ["om", "mane", "padme", "hum12345"] +columns0 = [["om"], ["mane", "padme"], ["hum", "12345"]] +measureList :: Lengthable a => [a] -> (Natural, [(Natural, a)]) +measureList = + List.mapAccumL (\acc s -> let len = length s in (max len acc, (len, s))) 0 +measureVert :: Lengthable a => [a] -> (Natural, [(Natural, a)]) +measureVert ss = (fromIntegral $ List.length ss, (1,) <$> ss) + +-- >>> padList (\n -> List.replicate (fromIntegral n) ' ') (measureList lines0) +-- ["om ","mane ","padme ","hum12345"] +-- >>> (measureVert lines0) +-- (4,[(1,"om"),(1,"mane"),(1,"padme"),(1,"hum12345")]) +padList :: Semigroup o => (Natural -> o) -> (Natural, [(Natural, o)]) -> [o] +padList pad (inpLen, inp) = + fmap + ( \(itemLen, item) -> case inpLen `minusNaturalMaybe` itemLen of + Nothing -> item + Just padLen -> item <> pad padLen + ) + inp + +whites :: Integral a => a -> [Char] +whites n = List.replicate (fromIntegral n) ' ' +withLength :: Lengthable a => [a] -> (Natural, [a]) +withLength x = (sum $ length <$> x, x) + +text0 :: [Chunk (Line [Chunk (Word String)])] +text0 = convert @String "123 45\n67 89\n 10 11 12" + +{- | + >>> justi JustifyCenter text0 + [Item (Line [Spaces 1,Item (Word "123"),Spaces 1,Item (Word "45"),Spaces 1]),Item (Line [Spaces 1,Item (Word "67"),Spaces 1,Item (Word "89"),Spaces 2]),Item (Line [Spaces 0,Item (Word "10"),Spaces 1,Item (Word "11"),Spaces 1,Item (Word "12"),Spaces 0])] +-} + +-- >>> justi JustifyStart text0 +-- [Item (Line [Item (Word "123"),Spaces 1,Item (Word "45"),Spaces 2]),Item (Line [Item (Word "67"),Spaces 1,Item (Word "89"),Spaces 3]),Item (Line [Item (Word "10"),Spaces 1,Item (Word "11"),Spaces 1,Item (Word "12"),Spaces 0])] + +-- >>> justi JustifyEnd text0 +-- [Item (Line [Spaces 2,Item (Word "123"),Spaces 1,Item (Word "45")]),Item (Line [Spaces 3,Item (Word "67"),Spaces 1,Item (Word "89")]),Item (Line [Spaces 0,Item (Word "10"),Spaces 1,Item (Word "11"),Spaces 1,Item (Word "12")])] + +-- >>> justi JustifySpaceBetween text0 +-- [Item (Line [Item (Word "123"),Spaces 2,Item (Word "45")]),Item (Line [Item (Word "67"),Spaces 2,Item (Word "89")]),Item (Line [Item (Word "10"),Spaces 1,Item (Word "11"),Spaces 1,Item (Word "12")])] +{- +justi :: + Semigroup o => + Lengthable o => + Justify -> + [Chunk [Chunk o]] -> + [Chunk [Chunk o]] +justi jus ls = + (<$> ls) $ + \lineChunk -> + (<$> lineChunk) $ \li -> (<$> li) $ \l -> + justifyChunks jus minWitdh (length l, l) + where + --(maxCols, maxWidths, rows) = List.foldr go (0, List.repeat 0, []) ls + minWitdh :: Natural + minWitdh = + List.foldl' + ( \acc -> \case + ChunkInvisible{} -> acc + ChunkItem o -> length o + ChunkSpaces{} -> acc + ) + 0 + ls +-} +-- formatChunks :: +-- forall o. +-- Semigroup o => +-- Justify -> +-- Justify -> +-- {-vertLimit-} Natural -> +-- {-horizLimit-} Natural -> +-- [Chunk [Measured (Chunk o)]] -> +-- {-lines-} Measured [Chunk {-words-} (Measured [Chunk o])] +-- formatChunks vertJus horizJus vertLimit horizLimit vertChunks = +-- justifyChunks +-- DirectionHorizontal +-- vertJus +-- vertLimit +-- $ fmap (\(v,cs) -> Measured 0 v cs) +-- $ List.mapAccumL +-- ( \vertDim vertChunk -> +-- case vertChunk of +-- ChunkInvisible o -> (vertDim, ChunkInvisible o) +-- ChunkSpaces s -> (vertDim + s, ChunkSpaces s) +-- ChunkItem vertItem -> +-- ( vertDim + horizHeight +-- , ChunkItem $ +-- --Measured horizLimit horizHeight +-- justifyChunks +-- DirectionVertical +-- horizJus +-- horizLimit +-- vertItem +-- ) +-- where +-- horizHeight = maxOn' measuredHeight vertItem +-- ) +-- 0 +-- vertChunks + +{- | A strict version of 'sum', using a custom valuation function. + + > sumOn' read ["1", "2", "3"] == 6 +-} +sumOn' :: Num b => (a -> b) -> [a] -> b +sumOn' f = List.foldl' (\acc x -> acc + f x) 0 + +maxOn' :: (a -> Natural) -> [a] -> Natural +maxOn' f = List.foldl' (\acc x -> acc `max` f x) 0 + +{- | A version of 'maximum' where the comparison is done on some extracted value. + Raises an error if the list is empty. Only calls the function once per element. + + > maximumOn id [] == undefined + > maximumOn length ["test","extra","a"] == "extra" +-} +maximumOn :: Ord b => (a -> b) -> [a] -> a +maximumOn f [] = error "Data.List.Extra.maximumOn: empty list" +maximumOn f (x : xs) = g x (f x) xs + where + g v mv [] = v + g v mv (x : xs) + | mx > mv = g x mx xs + | otherwise = g v mv xs + where + mx = f x + +{- +>>> text0 +[Item (Line [Item (Word "123"),Spaces 1,Item (Word "45")]),Item (Line [Item (Word "67")]),Item (Line [Item (Word "89"),Spaces 1,Item (Word "10")])] + +>>> length text0 +3 + +>>> justifyChunks JustifyCenter 30 (length text0, text0) +[Spaces 13,Item (Line [Item (Word "123"),Spaces 1,Item (Word "45")]),Item (Line [Item (Word "67")]),Item (Line [Item (Word "89"),Spaces 1,Item (Word "10")]),Spaces 14] + +>>> justifyChunks JustifySpaceBetween 30 (length text0, text0) +[Item (Line [Item (Word "123"),Spaces 1,Item (Word "45")]),Item (Line [Item (Word "67")]),Item (Line [Item (Word "89"),Spaces 1,Item (Word "10")])] +-} +justifyChunks :: + Semigroup o => + Direction -> + Justify -> + Natural -> + [Measured (Chunk o)] -> + Measured [Chunk o] +justifyChunks dir jus limitDim measuredChunks = + let chunksDim = List.sum (mea <$> measuredChunks) + chunks = unMeasured <$> measuredChunks + mea = case dir of + DirectionHorizontal -> measuredVertical + DirectionVertical -> measuredHorizontal + in Measured + { measuredHorizontal = 0 + , measuredVertical = 0 + , unMeasured = case limitDim `minusNaturalMaybe` chunksDim of + Nothing -> chunks + Just padLen -> + case jus of + JustifyStart -> chunks <> [ChunkSpaces padLen] + JustifyEnd -> [ChunkSpaces padLen] <> chunks + JustifyCenter -> [ChunkSpaces halfPadLen] <> chunks <> [ChunkSpaces (padLen - halfPadLen)] + where + -- NOTE: may be 0 + halfPadLen = padLen `div` 2 + JustifySpaceBetween -> + if itemsCount > 0 + then spaceBetweenItems chunks padLens + else chunks <> [ChunkSpaces padLen] + where + itemsCount = countItems chunks + padLens = justifyPadding padLen itemsCount + spaceBetweenItems :: [Chunk o] -> [Natural] -> [Chunk o] + spaceBetweenItems (x : xs) pads@(p : ps) = + case x of + ChunkSpaces _w -> ChunkSpaces (p + 1) : spaceBetweenItems xs ps + _ -> x : spaceBetweenItems xs pads + spaceBetweenItems (w : ws) [] = w : spaceBetweenItems ws [] + spaceBetweenItems [] _os = mempty + } + +instance IsString (Rect String) where + fromString s = + Rects + { rectDirection = DirectionHorizontal + , rectJustify = JustifyStart + , rectWrap = False + , rectAxis = rectOfWords . wordsNoEmpty <$> lines s + } + where + rectOfWords :: [Word String] -> Rect String + rectOfWords ws = + Rects + { rectDirection = DirectionHorizontal + , rectJustify = JustifyStart + , rectWrap = False + , rectAxis = (\(Word x) -> Rect (fromIntegral (List.length x), [x])) <$> ws + } + +rect0 :: Rect String +rect0 = + Rects + { rectDirection = DirectionHorizontal + , rectJustify = JustifyStart + , rectWrap = False + , rectAxis = ["abc"] + } +rect1 :: Rect String +rect1 = + Rects + { rectDirection = DirectionHorizontal + , rectJustify = JustifyStart + , rectWrap = True + , rectAxis = ["abc", "abcd", "abc"] + } +rect2 :: Rect [Char] +rect2 = + Rects + { rectDirection = DirectionVertical + , rectJustify = JustifyStart + , rectWrap = False + , rectAxis = + [ Rects + { rectDirection = DirectionHorizontal + , rectJustify = JustifyStart + , rectWrap = True + , rectAxis = ["123", "4567", "890"] + } + , Rects + { rectDirection = DirectionHorizontal + , rectJustify = JustifyStart + , rectWrap = True + , rectAxis = ["abc", "defg", "hij"] + } + ] + } + +{- | @(measureRect limitH limitV rect)@ return the given @(rect)@ +with minimal 'rectMeasure's, trying to fit the given limits when 'rectWrap' is 'True'. + +>>> measureRect Nothing Nothing rectH3V1 +Rect {rectContent = "abc"} + +>>> measureRect Nothing Nothing rect1 +Rects {rectMeasure = (10,1), rectDirection = DirectionHorizontal, rectJustify = JustifyStart, rectWrap = False, rectAxis = [Rect {rectContent = "abc"},Rect {rectContent = "abcd"},Rect {rectContent = "abc"}]} + +>>> measureRect (Just 4) Nothing rect1{rectWrap=True} +Rects {rectMeasure = (4,3), rectDirection = DirectionHorizontal, rectJustify = JustifyStart, rectWrap = True, rectAxis = [Rect {rectContent = "abc"},Rect {rectContent = "abcd"},Rect {rectContent = "abc"}]} + +>>> measureRect (Just 2) Nothing rect1{rectWrap=True, rectDirection = DirectionVertical} +Rects {rectMeasure = (7,2), rectDirection = DirectionVertical, rectJustify = JustifyStart, rectWrap = True, rectAxis = [Rect {rectContent = "abc"},Rect {rectContent = "abcd"},Rect {rectContent = "abc"}]} +-} + +{- | + +>>> renderRect Nothing Nothing rect0 +((3,1),[["abc"]]) + +>>> renderRect Nothing Nothing rect1 +((10,1),[["abc","abcd","abc"]]) + +>>> renderRect Nothing Nothing rect2 +((10,2),[["123","4567","890","abc","defg","hij"]]) + +>>> renderRect (Just 4) Nothing rect2 +((4,6),[["123"," ","abc"," "],["4567","defg"],["890"," ","hij"," "]]) +-} +renderRect :: + forall o. + Semigroup o => + Show o => + Dimensionable o => + Padable o => + Maybe Natural -> + Maybe Natural -> + Rect o -> + ((Natural, Natural), [[o]]) +renderRect limitH limitV is = + traceShow ("renderRect" :: String, limitH, limitV, is, "res" :: String, res) res + where + res = + case is of + Rect (n, ws) -> ((n, 1), [ws]) + Rects{..} -> + let (_finalH, _finalV, maximalH, maximalV, renderedRects) = + List.foldl' + ( \(currH, currV, maxH, maxV, rectHV) rect -> + let (dim, rectRendered) = + renderRect + (limitH `minusOrZero` currH) + (limitV `minusOrZero` currV) + rect + newDim@(rectH, rectV) = + case rectDirection of + DirectionHorizontal -> dim + DirectionVertical -> swap dim + newH = currH + (if currH == 0 || rectDirection == DirectionVertical then 0 else 1) + rectH + in case limitH of + Just limH + -- Limit overflow, and wrapping + | limH < newH && rectWrap -> + traceShow ("overflow" :: String, limH, newH) $ + (rectH, maxV, maxH `max` rectH, maxV + rectV, newRectHV) + where + -- Word goes into a new line + newRectHV = [(newDim, rectRendered)] : rectHV + -- No limit, or no overflow, or no wrapping + _ -> (newH, currV, maxH + rectH, maxV `max` rectV, newRectHV) + where + -- Word goes into the same line + newRectHV = case rectHV of + [] -> [[(newDim, rectRendered)]] + r : rs -> ((newDim, rectRendered) : r) : rs + ) + (0, 0, 0, 0, []) + rectAxis + in ( case rectDirection of + DirectionHorizontal -> (maximalH, maximalV) + DirectionVertical -> (maximalV, maximalH) + , concatHV maximalH maximalV (List.reverse $ List.reverse <$> renderedRects) + -- (traceShow ("renderedRects" :: String, renderedRects) $ List.reverse renderedRects) + ) + -- concatRender :: [[o]] -> [[o]] -> [[o]] + -- concatRender = List.zipWith (<>) + -- Should probably change a wrapped H rect into a V rect containing H rects + -- Now reads rectAxis from the left to right, top to bottom + -- and make each line reach at least maximalH + -- case rectJustify of + -- JustifyStart -> + -- ((\line -> line <> replicate (maximalH - List.length line) ' ') <$> lines) + -- <> replicate (maximalV - List.length lines) (replicate maximalH ' ') + + minusOrZero :: Maybe Natural -> Natural -> Maybe Natural + minusOrZero Nothing _m = Nothing + minusOrZero (Just n) m = minusNaturalMaybe n m <|> Just 0 + +{- +@ + +>>> concatH 10 2 [((3,1), [["123"]])] +[["123"," "],[" "," "]] + +>>> concatH 10 2 [((3,2), [["123"], ["ab "]]), ((4,1), [["4567"]])] +[["123","4567"," "],["ab "," "," "]] + +>>> concatH 4 3 [((4,3),[["abc"," "],["defg"],["hij"," "]])] +[["abc"," "],["defg"],["hij"," "]] + +>>> concatH 8 3 [((4,3),[["123"," "],["4567"],["890"," "]]), ((4,3),[["abc"," "],["defg"],["hij"," "]])] +[["123"," ","abc"," "],["4567","defg"],["890"," ","hij"," "]] + +@ +-} +concatH :: Padable o => Show o => Natural -> Natural -> [((Natural, Natural), [[o]])] -> [[o]] +concatH maxH maxV rs = + traceShow + ("concatH" :: String, maxH, maxV, rs, "res" :: String, res) + res + where + (res, rsH) = + List.foldr + ( \((rH, rV), r) (acc, accH) -> + let rPlusVPad = case maxV `minusNaturalMaybe` rV of + Nothing -> error "concatH: given maxV is lower than the actual maximal V length" + Just dV -> r <> List.replicate (fromIntegral dV) [padding rH] + in (List.zipWith (<>) rPlusVPad acc, accH + rH) + ) + (List.replicate (fromIntegral maxV) [padding dH | dH /= 0], 0) + rs + dH = + fromMaybe (error "concatH: given maxH is lower than the actual maximal H length ") $ + maxH `minusNaturalMaybe` rsH + +{- +concatH maxH maxV [] = List.replicate (fromIntegral maxV) [padding maxH | maxH /= 0] +concatH maxH maxV (((rH, rV), r) : rs) = case maxH `minusNaturalMaybe` rH of + Nothing -> error "concatH: given maxH is lower than the actual maximal H length " + Just dH -> List.zipWith (<>) rPlusVPad (concatH dH maxV rs) + where + rPlusVPad = case maxV `minusNaturalMaybe` rV of + Nothing -> error "concatH: given maxV is lower than the actual maximal V length" + Just dV -> r <> List.replicate (fromIntegral dV) [padding rH] +-} +{- +@ + +>>> concatV 10 2 [((3,1), [["123"]])] +[["123"," "],[" "]] + +>>> concatV 4 3 [((3,2), [["123"], ["ab "]]), ((4,1), [["4567"]])] +[["123"," "],["ab "," "],["4567"]] + +>>> concatV 4 3 [((4,3),[["abc"," "],["defg"],["hij"," "]])] +[["abc"," "],["defg"],["hij"," "]] + +>>> concatV 4 6 [((4,3),[["123"," "],["4567"],["890"," "]]), ((4,3),[["abc"," "],["defg"],["hij"," "]])] +[["123"," "],["4567"],["890"," "],["abc"," "],["defg"],["hij"," "]] + +@ +-} +concatV :: Padable o => Show o => Natural -> Natural -> [((Natural, Natural), [[o]])] -> [[o]] +concatV maxH maxV [] = List.replicate (fromIntegral maxV) [padding maxH | maxH /= 0] +concatV maxH maxV (((rH, rV), r) : rs) = case maxV `minusNaturalMaybe` rV of + Nothing -> error "concatV: given maxH is lower than actual maximal H length" + Just dV -> rPlusHPad <> concatV maxH dV rs + where + rPlusHPad = case maxH `minusNaturalMaybe` rH of + Nothing -> error "concatV: given maxV is lower than actual maximal V length" + Just dH + | dH == 0 -> r + | otherwise -> List.zipWith (<>) r $ List.replicate (fromIntegral rV) [padding dH] + +{- | +@ +>>> concatHV 10 2 [[((3,2), [["123"], ["ab "]]), ((4,1), [["4567"]])]] +[["123","4567"," "],["ab "," "," "]] + +>>> concatHV 10 3 [[((3,2), [["123"], ["ab "]]), ((4,1), [["4567"]])]] +[["123","4567"," "],["ab "," "," "],[" "]] + +>>> concatHV 4 6 [ [((4,3),[["123"," "],["4567"],["890"," "]])], [((4,3),[["abc"," "],["defg"],["hij"," "]])] ] +[["123"," "],["4567"],["890"," "],["abc"," "],["defg"],["hij"," "]] +-} +concatHV :: Padable o => Show o => Natural -> Natural -> [[((Natural, Natural), [[o]])]] -> [[o]] +concatHV maxH maxV rs = concatV maxH maxV $ f <$> rs + where + f r = ((maxH, rV), concatH maxH rV r) + where + rV = List.maximum $ snd . fst <$> r + +{- +@ +>>> concatV 10 2 [[((3,2), [["123"], ["ab "]]), ((4,1), [["4567"]])]] +[["123","4567"," "],["ab "," "," "]] + +>>> concatV 10 3 [[((3,2), [["123"], ["ab "]]), ((4,1), [["4567"]])]] +[["123","4567"," "],["ab "," "," "],[" "]] + +>>> concatV3 4 6 [ [((4,3),[["123"," "],["4567"],["890"," "]])], [((4,3),[["abc"," "],["defg"],["hij"," "]])] ] +[["123"," "],["4567"],["890"," "],["abc"," "],["defg"],["hij"," "]] +concatV :: Padable o => Show o => Natural -> Natural -> [[((Natural, Natural), [[o]])]] -> [[o]] +concatV maxH maxV rs = + traceShow + ("concatV" :: String, maxH, maxV, rs, "res" :: String, res) + res + where + (res, rsV) = + List.foldr + ( \r (acc, accV) -> + let rV = List.maximum $ snd . fst <$> r + in (concatH maxH rV r <> acc, accV + rV) + ) + (List.replicate (fromIntegral $ maxV - rsV) [padding maxH], 0) + rs +-} + +{- +concatV maxH maxV [] + | maxV == 0 = [] + | otherwise = List.replicate (fromIntegral maxV) [padding maxH] +concatV maxH maxV (r : rs) = + List.zipWith (<>) (concatH maxH rV r) (concatV maxH (maxV - rV) rs) + where + rV = List.maximum $ snd . fst <$> r +-} +-- where +-- paddedR = case maxH `minusNaturalMaybe` rH of +-- Nothing -> r +-- Just p -> r <> List.replicate (fromIntegral p) [padding rH] + +{- | @('zipWithLongest xPadLen yPadLen xs ys')@ zips together the lists @(xs)@ and @(ys)@ + padding the @(xs)@ (resp. @(ys)@) elements with a 'padding' of @(xPadLen)@ (resp. @(yPadLen)@) + when it is shorter than the corresponding one in @(ys)@ (resp. @(xs)@). + +>>> zipWithLongest [] +-} +zipWithLongest :: Padable o => Natural -> Natural -> [[o]] -> [[o]] -> [[o]] +zipWithLongest _ _ [] [] = [] +zipWithLongest xP yP (x0 : xs) (y0 : ys) = x0 <> y0 : zipWithLongest xP yP xs ys +zipWithLongest _xP yP [] ys + | yP <= 0 = ys + | otherwise = List.map (padding yP :) ys +zipWithLongest xP _yP xs [] + | xP <= 0 = xs + | otherwise = List.map (<> [padding xP]) xs + +class Padable o where + padding :: Natural -> o +instance Padable String where + padding n = List.replicate (fromIntegral n) ' ' + +{- +>>> renderRect $ measureRect (Just 2) Nothing rect1{rectWrap=True, rectDirection = DirectionVertical} +["abc","abcd","abc"] +renderRect :: Dimensionable o => Rect (Natural, Natural) o -> [o] +renderRect = \case + Rect{..} -> [rectContent] + Rects{rectMeasure = (measureH, measureV), ..} -> + List.concat $ renderRect <$> rectAxis +-} + +-- fitRect :: Rect o -> Measured (Rect o) +-- fitRect r = case r of +-- Rect m -> m{unMeasured r} +-- Rects{..} -> +-- let rectsCount = fromIntegral $ max 0 $ List.length rectAxis - 1 in +-- case rectDirection of +-- DirectionHorizontal -> +-- Rects +-- { +-- rectAxis = +-- List.mapAccumL +-- (\r acc -> +-- let m = fitRect r in +-- case measuredHeight acc `compare` measuredHeight m of +-- LT -> undefined -- acc must be justified upto m +-- EQ -> acc{measureWidth = measuredWidth acc + measuredWidth m} +-- GT -> undefined -- m must be justified upto acc +-- ) rectAxis +-- } +-- renderRect :: Maybe Natural -> Maybe Natural -> Rect o -> [[o]] +-- renderRect horizLimit vertLimit = \case +-- Rect (Measured w h c) -> [[c]] +-- Rects{..} -> +-- renderRect rectAxis + +-- * Type 'Rect' +data Rect o + = Rect + { rectContent :: (Natural, [o]) + } + | Rects + { rectDirection :: Direction + , rectJustify :: Justify + , rectWrap :: Bool + , rectAxis :: [Rect o] + } + deriving (Show) + +{- +instance Dimensionable o => Dimensionable (Rect (Natural, Natural) o) where + width = \case + Rect{..} -> width rectContent + Rects{rectMeasure = (h, _)} -> h + height = \case + Rect{..} -> height rectContent + Rects{rectMeasure = (_, v)} -> v +-} +instance Dimensionable String where + width s = fromIntegral $ List.maximum $ List.length <$> splitOnChar (== '\n') s + height s = fromIntegral $ List.length $ splitOnChar (== '\n') s + +data Adjustment o + = AdjustmentVariable Natural + | AdjustmentFixed o + +-- ** Type 'Chunk' +data Chunk o + = ChunkItem !o + | -- | Whites preserved to be interleaved + -- correctly with 'ChunkInvisible'. + ChunkSpaces !Natural + | -- | Ignored by the justification but kept in place. + -- Used to put ANSI sequences. + ChunkInvisible !o + deriving (Functor) + +runChunk :: Outputable o => Chunk o -> o +runChunk = \case + ChunkInvisible o -> o + ChunkItem o -> o + ChunkSpaces s -> repeatedChar s ' ' + +instance Show o => Show (Chunk o) where + showsPrec p x = + showParen (p > 10) $ + case x of + ChunkInvisible o -> showString "Ignored" . showsPrec 11 o + ChunkItem o -> showString "Item " . showsPrec 11 o + ChunkSpaces w -> showString "Spaces " . showsPrec 11 w + +-- instance Lengthable o => Lengthable (Chunk (Line o)) where +-- length = \case +-- ChunkInvisible{} -> 0 +-- ChunkItem o +-- | isEmpty o -> 0 +-- | otherwise -> 1 +-- ChunkSpaces w -> w +-- isEmpty = \case +-- ChunkInvisible{} -> True +-- ChunkItem o -> isEmpty o +-- ChunkSpaces w -> w == 0 +-- instance Lengthable o => Lengthable (Chunk (Word o)) where +-- length = \case +-- ChunkInvisible{} -> 0 +-- ChunkItem o -> length o +-- ChunkSpaces w -> w +-- isEmpty = \case +-- ChunkInvisible{} -> True +-- ChunkItem o -> isEmpty o +-- ChunkSpaces w -> w == 0 +-- instance Lengthable (Chunk o) => Lengthable [Chunk o] where +-- length = List.foldl' (\acc out -> acc + length out) 0 +-- isEmpty = List.all isEmpty + +{- | @('wordsCount' ps)@ returns the number of words in @(ps)@ + clearly separated by spaces. +-} +countItems :: [Chunk o] -> Natural +countItems = go False 0 + where + go isAdjacentItem acc = \case + [] -> acc + ChunkInvisible{} : xs -> go isAdjacentItem acc xs + ChunkSpaces w : xs + | w == 0 -> go isAdjacentItem acc xs + | otherwise -> go False acc xs + ChunkItem{} : xs -> + if isAdjacentItem + then go isAdjacentItem acc xs + else go True (acc + 1) xs + +{- | @('justifyPadding' a b)@ returns the padding lengths +to reach @(a)@ in @(b)@ pads, +using the formula: @(a '==' m'*'(q '+' q'+'1) '+' ('r'-'m)'*'(q'+'1) '+' (b'-'r'-'m)'*'q)@ +where @(q+1)@ and @(q)@ are the two padding lengths used and @(m = min (b-r) r)@. + +A simple implementation of 'justifyPadding' could be: +@ +'justifyPadding' a b = + 'join' ('List.replicate' m [q,q'+'1]) + <> ('List.replicate' (r'-'m) (q'+'1) + <> ('List.replicate' ((b'-'r)'-'m) q + where + (q,r) = a`divMod`b + m = 'min' (b-r) r +@ + +>>> justifyPadding 30 7 +[4,5,4,5,4,4,4] +-} +justifyPadding :: Natural -> Natural -> [Natural] +justifyPadding a b = go r (b - r) -- NOTE: r >= 0 && b-r >= 0 due to 'divMod' + where + (q, r) = a `quotRemNatural` b + go 0 bmr = List.replicate (fromIntegral bmr) q -- when min (b-r) r == b-r + go rr 0 = List.replicate (fromIntegral rr) (q + 1) -- when min (b-r) r == r + go rr bmr = q : (q + 1) : go (rr `minusNatural` 1) (bmr `minusNatural` 1) + +takeExactly :: o -> Natural -> [o] -> [o] +takeExactly pad len inp = + if len <= 0 + then inp + else case inp of + [] -> List.replicate (fromIntegral len) pad + o : next -> o : takeExactly pad (len - 1) next + +-- https://codepen.io/enxaneta/full/adLPwv/ +-- https://github.com/jordwalke/flex/blob/master/src/lib/Layout.re +data Direction + = DirectionHorizontal + | DirectionVertical + deriving (Eq, Show) +data Justify + = JustifyStart + | JustifyEnd + | JustifyCenter + | JustifyStretch + | JustifySpaceBetween + | JustifySpaceAround + deriving (Show) + +{- +type ItemAlignSelf = Maybe Align + +data Container o = Container + { containerDirection :: Direction + , containerWrap :: Bool + , containerAlignItems :: Align + , containerJustifyContent :: Align + , containerAlignContent :: Align + , containerItems :: [Item o] + } +data Item o = Item + { itemAlignSelf :: Maybe Align + , itemFlexGrow :: Natural + , itemFlexShrink :: Natural + , itemFlexOrder :: Natural + , itemContent :: o + } + +2. Determine the available main and cross space for the flex items. +3. Determine the flex base size and hypothetical main size of each item: +4. Determine the main size of the flex container using the rules of the formatting context in which it participates. +5. Collect flex items into flex lines +6. Resolve the flexible lengths of all the flex items to find their used main size. +7. Determine the hypothetical cross size of each item by performing layout with the used main size and the available space, treating auto as fit-content. +8. Calculate the cross size of each flex line. +9. Handle 'align-content: stretch'. +10. Collapse visibility:collapse items. +11. Determine the used cross size of each flex item. +12. Distribute any remaining free space. +13. Resolve cross-axis auto margins. +14. Align all flex items along the cross-axis per align-self, if neither of the item’s cross-axis margins are auto. +15. Determine the flex container’s used cross size +16. Align all flex lines per align-content. + +Resolving Flexible Lengths +1. Determine the used flex factor. +2. Size inflexible items. +3. Calculate initial free space. +4. Loop: + 4.1 Check for flexible items. + 4.2 Calculate the remaining free space as for initial free space, above. + 4.3 Distribute free space proportional to the flex factors. + 4.4 Fix min/max violations. + 4.5 Freeze over-flexed items. + +-} + +-- * Type 'Writer' + +-- -- | Church encoded for performance concerns. +-- -- Kinda like 'ParsecT' in @megaparsec@ but a little bit different +-- -- due to the use of 'WriterFit' for implementing 'breakingSpace' correctly +-- -- when in the left hand side of ('<.>'). +-- -- Prepending is done using continuation, like in a difference list. +-- newtype Writer (o :: Type) a = Writer +-- { unWriter :: +-- a -> +-- {-curr-} WriterInh o -> +-- {-curr-} WriterState o -> +-- {-ok-} (({-prepend-} (o -> o {-new-}), WriterState o) -> WriterFit o) -> +-- WriterFit o +-- -- NOTE: equivalent to: +-- -- ReaderT WriterInh (StateT (WriterState o) (Cont (WriterFit o))) (o->o) +-- } +-- +-- runWriter :: Monoid o => Writer o a -> a -> o +-- runWriter x a = +-- unWriter +-- x +-- a +-- defWriterInh +-- defWriterState +-- {-k-} ( \(px, _sx) fits _overflow -> +-- -- NOTE: if px fits, then appending mempty fits +-- fits (px mempty) +-- ) +-- {-fits-} id +-- {-overflow-} id + +-- ** Type 'WriterFit' + +{- +-- | Double continuation to qualify the returned document +-- as fitting or overflowing the given 'plainInh_width'. +-- It's like @('Bool',o)@ in a normal style +-- (a non continuation-passing-style). +type WriterFit o = + {-fits-} (o -> o) -> + {-overflow-} (o -> o) -> + o + +-- ** Type 'WriterInh' +data WriterInh o = WriterInh + { plainInh_width :: !(Maybe Column) + , plainInh_justify :: !Bool + , plainInh_indent :: !Indent + , plainInh_indenting :: !(Writer o ()) + , plainInh_sgr :: ![SGR] + } + +defWriterInh :: Monoid o => WriterInh o +defWriterInh = + WriterInh + { plainInh_width = Nothing + , plainInh_justify = False + , plainInh_indent = 0 + , plainInh_indenting = empty + , plainInh_sgr = [] + } + +-- ** Type 'WriterState' +data WriterState o = WriterState + { plainState_buffer :: ![WriterChunk o] + , -- | The 'Column' from which the 'plainState_buffer' + -- must be written. + plainState_bufferStart :: !Column + , -- | The 'Width' of the 'plainState_buffer' so far. + plainState_bufferWidth :: !Width + , -- | The amount of 'Indent' added by 'breakspace' + -- that can be reached by breaking the 'space' + -- into a 'newlineJustifyingWriter'. + plainState_breakIndent :: !Indent + } + deriving (Show) + +defWriterState :: WriterState o +defWriterState = + WriterState + { plainState_buffer = mempty + , plainState_bufferStart = 0 + , plainState_bufferWidth = 0 + , plainState_breakIndent = 0 + } + +-- ** Type 'WriterChunk' +data WriterChunk o + = -- | Ignored by the justification but kept in place. + -- Used for instance to put ANSI sequences. + WriterChunk_Ignored !o + | WriterChunk_Word !(Word o) + | -- | 'spaces' preserved to be interleaved + -- correctly with 'WriterChunk_Ignored'. + WriterChunk_Spaces !Width +instance Show o => Show (WriterChunk o) where + showsPrec p x = + showParen (p > 10) $ + case x of + WriterChunk_Ignored o -> + showString "Z " + . showsPrec 11 o + WriterChunk_Word (Word o) -> + showString "W " + . showsPrec 11 o + WriterChunk_Spaces s -> + showString "S " + . showsPrec 11 s +instance Lengthable o => Lengthable (WriterChunk o) where + length = \case + WriterChunk_Ignored{} -> 0 + WriterChunk_Word o -> length o + WriterChunk_Spaces s -> s + isEmpty = \case + WriterChunk_Ignored{} -> True + WriterChunk_Word o -> isEmpty o + WriterChunk_Spaces s -> s == 0 + +--instance From [SGR] o => From [SGR] (WriterChunk o) where +-- from sgr = WriterChunk_Ignored (from sgr) + +instance Emptyable (Writer o) where + empty = Writer $ \_a _inh st k -> k (id, st) + +-} + +-- >>> wordsNoEmpty (Line (" a b c "::String)) +-- [Word {unWord = "a"},Word {unWord = "b"},Word {unWord = "c"}] +instance Convertible String o => Convertible String [Chunk (Line [Chunk (Word o)])] where + convert = + ( ChunkItem . Line + . List.intersperse (ChunkSpaces 1) + . (ChunkItem . convert <$>) + . wordsNoEmpty + <$> + ) + . lines diff --git a/symantic-plaintext.cabal b/symantic-plaintext.cabal index c4dee55..575370b 100644 --- a/symantic-plaintext.cabal +++ b/symantic-plaintext.cabal @@ -22,11 +22,9 @@ extra-doc-files: ChangeLog.md extra-source-files: cabal.project - default.nix .envrc flake.lock flake.nix - shell.nix extra-tmp-files: source-repository head @@ -40,11 +38,13 @@ library Symantic.Plaintext.Classes Symantic.Plaintext.Debug Symantic.Plaintext.Output + Symantic.Plaintext.Writer2 Symantic.Plaintext.Writer default-language: Haskell2010 default-extensions: DataKinds DefaultSignatures + DerivingVia FlexibleContexts FlexibleInstances ImportQualifiedPost -- 2.42.0