]> Git — Sourcephile - haskell/symantic-plaintext.git/commitdiff
wip main
authorJulien Moutinho <julm@sourcephile.fr>
Mon, 22 Aug 2022 21:20:10 +0000 (23:20 +0200)
committerJulien Moutinho <julm@sourcephile.fr>
Mon, 22 Aug 2022 21:20:10 +0000 (23:20 +0200)
src/Symantic/Plaintext/Output.hs
src/Symantic/Plaintext/Writer.hs
src/Symantic/Plaintext/Writer2.hs [new file with mode: 0644]
symantic-plaintext.cabal

index 3de457d3d319bfebd6dd70cd5008e4e0069f58d5..188bf2b559e3b10b4a4641eae0ffe6caa836432f 100644 (file)
@@ -21,7 +21,9 @@ import Data.Text.Lazy qualified as TL
 import Data.Text.Lazy.Builder qualified as TLB
 import Prelude (fromIntegral)
 
 import Data.Text.Lazy.Builder qualified as TLB
 import Prelude (fromIntegral)
 
+import Numeric.Natural (Natural)
 import Symantic.Plaintext.Classes
 import Symantic.Plaintext.Classes
+import Text.Show (Show)
 
 -- * Class 'Outputable'
 class
 
 -- * Class 'Outputable'
 class
@@ -68,6 +70,17 @@ instance Lengthable TL.Text where
   length = fromIntegral . TL.length
   isEmpty = TL.null
 
   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)
 -- * 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'
   break = TL.break
 
 -- ** Type 'Line'
-newtype Line o = Line {unLine :: o}
+newtype Line o = Line o
   deriving (Functor, Semigroup, Monoid, Lengthable, Splitable)
   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'
 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 (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
 words :: Splitable o => Line o -> [Word o]
 wordsNoEmpty :: Splitable o => Line o -> [Word o]
 words = (Word <$>) . splitOnChar (== ' ') . unLine
index cd4e413275596defe18240e88c5291d05fb5fdc2..14ec3001c3d600146cf3608ef6f228f9860c4cea 100644 (file)
@@ -693,7 +693,7 @@ padLineWriterChunkInits maxWidth (lineWidth, wordCount, line) =
   Line $
     if maxWidth <= lineWidth
       -- The gathered line reached or overreached the maxWidth,
   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
       || 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 (file)
index 0000000..c3b14ed
--- /dev/null
@@ -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
index c4dee557995f77712a3437b1e67cee2168905ee7..575370b5440f4a128f5c161bf31e6983fe237385 100644 (file)
@@ -22,11 +22,9 @@ extra-doc-files:
   ChangeLog.md
 extra-source-files:
   cabal.project
   ChangeLog.md
 extra-source-files:
   cabal.project
-  default.nix
   .envrc
   flake.lock
   flake.nix
   .envrc
   flake.lock
   flake.nix
-  shell.nix
 extra-tmp-files:
 
 source-repository head
 extra-tmp-files:
 
 source-repository head
@@ -40,11 +38,13 @@ library
     Symantic.Plaintext.Classes
     Symantic.Plaintext.Debug
     Symantic.Plaintext.Output
     Symantic.Plaintext.Classes
     Symantic.Plaintext.Debug
     Symantic.Plaintext.Output
+    Symantic.Plaintext.Writer2
     Symantic.Plaintext.Writer
   default-language: Haskell2010
   default-extensions:
     DataKinds
     DefaultSignatures
     Symantic.Plaintext.Writer
   default-language: Haskell2010
   default-extensions:
     DataKinds
     DefaultSignatures
+    DerivingVia
     FlexibleContexts
     FlexibleInstances
     ImportQualifiedPost
     FlexibleContexts
     FlexibleInstances
     ImportQualifiedPost