import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Data.Text (Text)
-import Data.Tuple (snd)
+import Data.Traversable (Traversable)
import Numeric.Natural (Natural)
import Prelude (Integer, fromIntegral, pred)
import System.Console.ANSI (SGR, setSGRCode)
unwords = intercalate space . (unWord <$>)
-- | Like 'unlines' but without the trailing 'newline'.
catLines :: Foldable f => Functor f => f (Line d) -> d
- catLines = intercalate newline . (unLine <$>)
+ catLines = catV . (unLine <$>)
-- | @x '<+>' y = x '<>' 'space' '<>' y@
(<+>) :: d -> d -> d
-- | @x '</>' y = x '<>' 'newline' '<>' y@
infixr 6 <+>
infixr 6 </>
instance Spaceable String where
- newline = "\n"
- space = " "
- spaces n = List.replicate (fromIntegral n) ' '
+ newline = "\n"
+ space = " "
+ spaces n = List.replicate (fromIntegral n) ' '
instance Spaceable Text where
- newline = "\n"
- space = " "
- spaces n = Text.replicate (fromIntegral n) " "
+ newline = "\n"
+ space = " "
+ spaces n = Text.replicate (fromIntegral n) " "
instance Spaceable TLB.Builder where
- newline = TLB.singleton '\n'
- space = TLB.singleton ' '
- spaces = TLB.fromText . spaces
+ newline = TLB.singleton '\n'
+ space = TLB.singleton ' '
+ spaces = TLB.fromText . spaces
intercalate :: (Foldable f, Monoid d) => d -> f d -> d
intercalate sep ds = if Fold.null ds then mempty else Fold.foldr1 (\x y -> x<>sep<>y) ds
setIndent = noTrans1 . setIndent
fill = noTrans1 . fill
breakfill = noTrans1 . breakfill
-
- ul ::
- From (Word Char) d =>
- Foldable f =>
- Functor f =>
- f d -> d
- ul ds =
- catV $
- (<$> ds) $ \d ->
- (from (Word '-')<>space) <> align d
-
- ol ::
- From Natural d =>
- From (Word Char) d =>
- From (Line String) d =>
- Foldable f =>
- Functor f =>
- f d -> d
- ol ds =
- catV $ snd $
- Fold.foldr
- (\d (i, acc) ->
- (pred i, (from i<>from (Word '.')<>space <> align d) : acc)
- ) (Fold.length ds, []) ds
+
+class Listable d where
+ ul :: Traversable f => f d -> d
+ ol :: Traversable f => f d -> d
+ default ul ::
+ Listable (UnTrans d) => Trans d =>
+ Traversable f => f d -> d
+ default ol ::
+ Listable (UnTrans d) => Trans d =>
+ Traversable f => f d -> d
+ ul ds = noTrans $ ul $ unTrans <$> ds
+ ol ds = noTrans $ ol $ unTrans <$> ds
-- * Class 'Wrappable'
class Wrappable d where
module Symantic.Document.AnsiText where
import Control.Applicative (Applicative(..), liftA2)
-import Control.Monad (Monad(..))
+import Control.Monad (Monad(..), sequence)
import Control.Monad.Trans.Reader
import Data.Bool
import Data.Char (Char)
import Data.String (String, IsString(..))
import Data.Text (Text)
import System.Console.ANSI
+import Text.Show (Show(..))
import qualified Data.List as List
import qualified Data.Text.Lazy as TL
-- * Type 'AnsiText'
newtype AnsiText d = AnsiText { unAnsiText :: Reader [SGR] d }
+instance Show d => Show (AnsiText d) where
+ show (AnsiText d) = show $ runReader d []
ansiText :: AnsiText d -> AnsiText d
ansiText = id
italic = ansiTextSGR $ SetItalicized True
instance Justifiable d => Justifiable (AnsiText d) where
justify (AnsiText d) = AnsiText $ justify <$> d
-instance (Indentable d, From Char d) => Indentable (AnsiText d) where
+instance Indentable d => Indentable (AnsiText d) where
setIndent i (AnsiText d) = AnsiText $ setIndent i <$> d
incrIndent i (AnsiText d) = AnsiText $ incrIndent i <$> d
fill w (AnsiText d) = AnsiText $ fill w <$> d
breakfill w (AnsiText d) = AnsiText $ breakfill w <$> d
align (AnsiText d) = AnsiText $ align <$> d
+instance Listable d => Listable (AnsiText d) where
+ ul ds = AnsiText $ (ul <$>) $ sequence $ unAnsiText <$> ds
+ ol ds = AnsiText $ (ol <$>) $ sequence $ unAnsiText <$> ds
instance Wrappable d => Wrappable (AnsiText d) where
setWidth w (AnsiText d) = AnsiText $ setWidth w <$> d
breakpoint = AnsiText $ return breakpoint
-- * Type 'PlainText'
-- | Drop 'Colorable16' and 'Decorable'.
newtype PlainText d = PlainText { unPlainText :: d }
+ deriving (Show)
plainText :: PlainText d -> PlainText d
plainText = id
fill w (PlainText d) = PlainText $ fill w d
breakfill w (PlainText d) = PlainText $ breakfill w d
align (PlainText d) = PlainText $ align d
+instance Listable d => Listable (PlainText d) where
+ ul ds = PlainText $ ul $ unPlainText <$> ds
+ ol ds = PlainText $ ol $ unPlainText <$> ds
instance Wrappable d => Wrappable (PlainText d) where
setWidth w (PlainText d) = PlainText $ setWidth w d
breakpoint = PlainText breakpoint
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE UndecidableInstances #-}
module Symantic.Document.Plain where
import Data.Bool
import Data.Char (Char)
import Data.Eq (Eq(..))
-import Data.Foldable (foldr)
import Data.Function (($), (.), id)
import Data.Functor ((<$>))
import Data.Maybe (Maybe(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Data.Text (Text)
+import Data.Tuple (snd)
import GHC.Natural (minusNatural,quotRemNatural)
import Numeric.Natural (Natural)
-import Prelude (fromIntegral, Num(..))
+import Prelude (fromIntegral, Num(..), pred)
import System.Console.ANSI
import Text.Show (Show(..), showString, showParen)
+import qualified Data.Foldable as Fold
import qualified Data.List as List
import qualified Data.Text.Lazy as TL
-- NOTE: equivalent to:
-- ReaderT PlainInh (StateT (PlainState d) (Cont (PlainFit d))) (d->d)
}
+instance (Show d, Monoid d) => Show (Plain d) where
+ show = show . runPlain
runPlain :: Monoid d => Plain d -> d
runPlain x =
words .
unLine
instance Spaceable d => Indentable (Plain d) where
- align p = Plain $ \inh st ->
+ align p = (flushLine <>) $ Plain $ \inh st ->
let currInd = plainState_bufferStart st + plainState_bufferWidth st in
unPlain p inh{plainInh_indent=currInd} st
incrIndent i p = Plain $ \inh ->
inh1 st1
in
unPlain (p <> p1) inh0 st0
+instance (Spaceable d, From (Word Char) d, From (Word String) d) => Listable (Plain d) where
+ ul ds =
+ catV $
+ (<$> ds) $ \d ->
+ from (Word '-')<>space<>flushLine<>align d<>flushLine
+ ol ds =
+ catV $ snd $
+ Fold.foldr
+ (\d (i, acc) ->
+ (pred i, (from i<>from (Word '.')<>space<>flushLine<>align d<>flushLine) : acc)
+ ) (Fold.length ds, []) ds
instance Spaceable d => Justifiable (Plain d) where
justify p = (\x -> flushLine <> x <> flushLine) $ Plain $ \inh ->
unPlain p inh{plainInh_justify=True}
- where
- flushLine :: Plain d
- flushLine = Plain $ \_inh st@PlainState{..} ok ->
- ok
- ( (joinPlainLine (collapseSpaces <$> List.reverse plainState_buffer) <>)
- , st
- { plainState_bufferStart = plainState_bufferStart + plainState_bufferWidth
- , plainState_bufferWidth = 0
- , plainState_buffer = mempty
- }
- )
- collapseSpaces = \case
- PlainChunk_Spaces s -> PlainChunk_Spaces (if s > 0 then 1 else 0)
- x -> x
+
+-- | Commit 'plainState_buffer' upto there, so that it won't be justified.
+flushLine :: Spaceable d => Plain d
+flushLine = Plain $ \_inh st ok ->
+ ok
+ ( (joinPlainLine (collapseSpaces <$> List.reverse (plainState_buffer st)) <>)
+ , st
+ { plainState_bufferStart = plainState_bufferStart st + plainState_bufferWidth st
+ , plainState_bufferWidth = 0
+ , plainState_buffer = mempty
+ }
+ )
+
+collapseSpaces :: PlainChunk d -> PlainChunk d
+collapseSpaces = \case
+ PlainChunk_Spaces s -> PlainChunk_Spaces (if s > 0 then 1 else 0)
+ x -> x
+
instance Spaceable d => Wrappable (Plain d) where
setWidth w p = Plain $ \inh ->
unPlain p inh{plainInh_width=w}
( if plainInh_justify inh then id else (space <>)
, st
{ plainState_buffer =
- case plainState_buffer st of
- PlainChunk_Spaces s:bs -> PlainChunk_Spaces (s+1):bs
- bs -> PlainChunk_Spaces 1:bs
+ if plainInh_justify inh
+ then case plainState_buffer st of
+ PlainChunk_Spaces s:bs -> PlainChunk_Spaces (s+1):bs
+ bs -> PlainChunk_Spaces 1:bs
+ else plainState_buffer st
, plainState_bufferWidth = plainState_bufferWidth st + 1
, plainState_removableIndent = newlineInd
}
|| maxWidth < plainInh_indent
then joinPlainLine $ List.reverse plainState_buffer
else
+ let superfluousSpaces = Fold.foldr
+ (\c acc ->
+ acc + case c of
+ PlainChunk_Ignored{} -> 0
+ PlainChunk_Word{} -> 0
+ PlainChunk_Spaces s -> s`minusNatural`(min 1 s))
+ 0 plainState_buffer in
+ let minBufferWidth =
+ -- NOTE: cap the spaces at 1,
+ -- to let justifyWidth decide where to add spaces.
+ plainState_bufferWidth`minusNatural`superfluousSpaces in
+ let justifyWidth =
+ -- NOTE: when minBufferWidth is not breakable,
+ -- the width of justification can be wider than
+ -- what remains to reach maxWidth.
+ max minBufferWidth $
+ maxWidth`minusNatural`plainState_bufferStart
+ in
let wordCount = countWords plainState_buffer in
- let bufferWidth =
- -- NOTE: compress all separated spaces into a single one.
- if wordCount == 0
- then 0
- else
- let spaceWidth = foldr
- (\c acc ->
- acc + case c of
- PlainChunk_Ignored{} -> 0
- PlainChunk_Word{} -> 0
- PlainChunk_Spaces s -> s)
- 0 plainState_buffer in
- (plainState_bufferWidth`minusNatural`spaceWidth) +
- (wordCount`minusNatural`1) in
- let adjustedWidth =
- max bufferWidth $
- min
- (maxWidth`minusNatural`plainState_bufferStart)
- (maxWidth`minusNatural`plainInh_indent) in
- unLine $ padPlainLineInits adjustedWidth $
- (bufferWidth,wordCount,List.reverse plainState_buffer)
+ unLine $ padPlainLineInits justifyWidth $
+ (minBufferWidth,wordCount,List.reverse plainState_buffer)
+-- | @('countWords' ps)@ returns the number of words in @(ps)@
+-- clearly separated by spaces.
countWords :: [PlainChunk d] -> Natural
countWords = go False 0
where
padPlainLineInits ::
Spaceable d =>
Width -> (Natural, Natural, [PlainChunk d]) -> Line d
-padPlainLineInits bufferWidth (lineWidth,wordCount,line) = Line $
- if bufferWidth <= lineWidth
- -- The gathered line reached or overreached the bufferWidth,
+padPlainLineInits maxWidth (lineWidth,wordCount,line) = Line $
+ if maxWidth <= lineWidth
+ -- The gathered line reached or overreached the maxWidth,
-- hence no padding id needed.
|| wordCount <= 1
- -- The case bufferWidth <= lineWidth && wordCount == 1
- -- can happen if first word's length is < bufferWidth
- -- but second word's len is >= bufferWidth.
+ -- The case maxWidth <= lineWidth && wordCount == 1
+ -- can happen if first word's length is < maxWidth
+ -- but second word's len is >= maxWidth.
then joinPlainLine line
else
-- Share the missing spaces as evenly as possible
-- between the words of the line.
- padPlainLine line $ justifyPadding (bufferWidth-lineWidth) (wordCount-1)
+ padPlainLine line $ justifyPadding (maxWidth-lineWidth) (wordCount-1)
+-- | Just concat 'PlainChunk's with no justification.
joinPlainLine :: Monoid d => Spaceable d => [PlainChunk d] -> d
joinPlainLine = mconcat . (runPlainChunk <$>)
+-- | Interleave 'PlainChunk's with 'Width's from 'justifyPadding'.
padPlainLine :: Spaceable d => [PlainChunk d] -> [Width] -> d
padPlainLine = go
where
, 10 `maxWidth` nestedAlign 10 ==> "1\n 2\n 3\n 4\n 5\n 6\n 7\n 8\n 9\n 10"
-- justify justifies
, 10 `maxWidth` justify "1 2 3 4 5 6" ==> "1 2 3 4 5\n6"
- -- justify compress spaces
+ -- justify compresses spaces
, 10 `maxWidth` justify "1 2 3 4 5 6" ==> "1 2 3 4 5\n6"
+ , 10 `maxWidth` justify " 1 2 3 4 5 6 7 8 9" ==> " 1 2 3 4 5\n6 7 8 9"
-- justify respects concatenating words
, 10 `maxWidth` justify (setWidth (Just 11) ("1 2 3"<>"4 5 6 7")) ==> "1 2 34 5 6\n7"
-- justify flushes the buffer before
, 10 `maxWidth` justify ("a b\n" <> nestedAlign 2) ==> "a b\n1 2"
, 10 `maxWidth` justify (bold ("12 34 56 78 "<> underline "90" <> " 123 456 789"))
==> "\ESC[1m12 34 56\n78 \ESC[4m90\ESC[0;1m 123\n456 789\ESC[0m"
+ -- align flushes the buffer
+ , 10 `maxWidth` justify (ul ["1 2 3 4 5 6 7 8 9"])
+ ==> "- 1 2 3 4\n\
+ \ 5 6 7 8\n\
+ \ 9"
+ -- ul/ol is mempty when no item
+ , ul [] ==> ""
+ , ol [] ==> ""
+ -- ul flushes the buffer
+ , 10 `maxWidth` justify (let i = "1 2 3 4 5 6 7 8 9" in ul [i, i])
+ ==> "- 1 2 3 4\n\
+ \ 5 6 7 8\n\
+ \ 9\n\
+ \- 1 2 3 4\n\
+ \ 5 6 7 8\n\
+ \ 9"
+ , 10 `maxWidth` justify (let i = "1 2 3 4 5 6 7 8 9" in
+ ul [ul [i, i], ul [i, i]])
+ ==> "- - 1 2 3\n\
+ \ 4 5 6\n\
+ \ 7 8 9\n\
+ \ - 1 2 3\n\
+ \ 4 5 6\n\
+ \ 7 8 9\n\
+ \- - 1 2 3\n\
+ \ 4 5 6\n\
+ \ 7 8 9\n\
+ \ - 1 2 3\n\
+ \ 4 5 6\n\
+ \ 7 8 9"
+ , 10 `maxWidth` justify (let i = "1 2 3 4 5 6 7 8 9" in
+ ol [ol [i, i], ol [i, i]])
+ ==> "1. 1. 1 2\n\
+ \ 3 4\n\
+ \ 5 6\n\
+ \ 7 8\n\
+ \ 9\n\
+ \ 2. 1 2\n\
+ \ 3 4\n\
+ \ 5 6\n\
+ \ 7 8\n\
+ \ 9\n\
+ \2. 1. 1 2\n\
+ \ 3 4\n\
+ \ 5 6\n\
+ \ 7 8\n\
+ \ 9\n\
+ \ 2. 1 2\n\
+ \ 3 4\n\
+ \ 5 6\n\
+ \ 7 8\n\
+ \ 9"
-- breakspace backtracking is bounded by the removable indentation
-- (hence it can actually wrap a few words in reasonable time).
, 80 `maxWidth`
fun :: IsString d => Indentable d => Wrappable d => d -> d
fun d = "function(" <> incrIndent 2 (breakalt d (newline<>d<>newline)) <> ")"
+
+t1 = 10 `maxWidth` justify (let i = "1 2 3 4 5 6 7 8 9" in ol [ol [i, i], ol [i, i]])