- ignore: {name: Use import/export shortcut}
- ignore: {name: Use list literal pattern}
- ignore: {name: Use list literal}
+- ignore: {name: Use null}
+- ignore: {name: Use span}
+- ignore: {name: Use ++}
# BEGIN: generated hints
- fixity: "infix 1 `maxWidth`"
-override GHCID_OPTIONS += --no-height-limit --reverse-errors
+override GHCID_OPTIONS += --no-height-limit --reverse-errors --color=always
override REPL_OPTIONS += -ignore-dot-ghci
cabal := $(wildcard *.cabal)
t tests:
cabal test $(CABAL_TEST_FLAGS) \
--test-show-details always --test-options "$(TEST_OPTIONS)"
-tests/prof-time: $(project)-test.eventlog.json
-tests/prof-heap: $(project)-test.eventlog.html
+tests/prof-time: $(project)-tests.eventlog.json
+tests/prof-heap: $(project)-tests.eventlog.html
.PHONY: $(project)-test.eventlog
$(project)-test.eventlog $(project)-test.prof:
cabal test $(CABAL_TEST_FLAGS) \
--test-show-details always --test-options "$(TEST_OPTIONS) +RTS $(RTS_OPTIONS)" \
--enable-profiling $(addprefix --ghc-options ,$(GHC_PROF_OPTIONS)) || true
t/repl tests/repl:
- cabal repl $(CABAL_REPL_FLAGS) $(CABAL_TEST_FLAGS) --enable-tests $(project)-test
+ cabal repl $(CABAL_REPL_FLAGS) $(CABAL_TEST_FLAGS) --enable-tests $(project)-tests
t/ghcid tests/ghcid:
ghcid $(GHCID_OPTIONS) --command 'cabal repl $(CABAL_REPL_FLAGS) $(CABAL_TEST_FLAGS) $(project):tests' --test ":main $(TEST_OPTIONS)"
! git tag --merged | grep -Fqx $(package)-$(version)
git diff --exit-code
git tag -f $(package)-$(version)
- git-chglog --output $@.new $(package)-$(version)
+ git-chglog --output $@.new --tag-filter-pattern '$(package)-.*' $(package)-$(version)
touch $@
cat $@ >>$@.new
mv -f $@.new $@
publish: upload/publish
-nix-build:
- nix -L build
-nix-relock:
- nix flake update --recreate-lock-file
-nix-repl:
- nix -L develop --command cabal repl $(CABAL_REPL_FLAGS)
-nix-shell:
- nix -L develop
-
.PHONY: .hlint.yaml
.hlint.yaml: $(shell find src -name '*.hs' -not -name 'HLint.hs')
sed -i -e '/^# BEGIN: generated hints/,/^# END: generated hints/d' $@
]
},
"locked": {
- "lastModified": 1633651466,
- "narHash": "sha256-vdplmNo0BIChVJtxXPH3oob6mR4C1zxpOlywORf03OY=",
+ "lastModified": 1633709659,
+ "narHash": "sha256-PALj5xnmMf6ko2MZlzDpOlJzApt1AHIDYXSCUNc7AQI=",
"ref": "main",
- "rev": "976663dccdd6807c501c35f9040325500da35e31",
- "revCount": 45,
+ "rev": "40592a770614008ef571b56ca7538e2fd03cc74e",
+ "revCount": 48,
"type": "git",
"url": "https://git.code.sourcephile.fr/~julm/symantic-base"
},
module Symantic.Document
( module Symantic.Document.Class
, module Symantic.Document.Plain
+ , module Symantic.Document.Utils
+ , ProductFunctor(..)
) where
+import Symantic.Class
import Symantic.Document.Class
import Symantic.Document.Plain
+import Symantic.Document.Utils
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
-module Symantic.Document.Class where
-
-import Control.Applicative (Applicative(..))
+module Symantic.Document.Class
+ ( module Symantic.Document.Class
+ , Emptyable(..)
+ , ProductFunctor(..)
+ , Voidable(..)
+ ) where
+
+--import Control.Applicative (Applicative(..))
import Data.Bool
import Data.Char (Char)
-import Data.Eq (Eq(..))
import Data.Foldable (Foldable)
-import Data.Function ((.), ($), id, const)
-import Data.Functor (Functor(..), (<$>))
+import Data.Function ((.), ($))
+--import Data.Function ((.), ($), id, const)
+--import Data.Functor (Functor(..), (<$>))
import Data.Int (Int)
-import Data.Kind (Type)
+--import Data.Kind (Type)
import Data.Maybe (Maybe(..))
-import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
-import Data.Semigroup (Semigroup(..))
-import Data.String (String, IsString(..))
-import Data.Text (Text)
+import Prelude (fromIntegral, pred)
+import Data.String (String)
+--import Data.Text (Text)
import Data.Traversable (Traversable)
import Numeric.Natural (Natural)
-import Prelude (Integer, fromIntegral, pred)
-import Text.Show (Show(..))
+import qualified Data.Functor as Fct
import qualified Data.Foldable as Fold
-import qualified Data.List as List
-import qualified Data.Text as Text
-import qualified Data.Text.Lazy as TL
-import qualified Data.Text.Lazy.Builder as TLB
+--import qualified Data.Text.Lazy.Builder as TLB
import qualified System.Console.ANSI as ANSI
+import Symantic.Derive
+import Symantic.Class
+ ( Emptyable(..)
+ , ProductFunctor(..)
+ , Voidable(..)
+ )
+
+concat ::
+ Emptyable repr => ProductFunctor repr =>
+ Foldable f => f (repr ()) -> repr ()
+concat = Fold.foldr (.>) empty
-- * Helper types
type Column = Natural
type Width = Natural
type SGR = ANSI.SGR
--- ** Type 'Line'
-newtype Line d = Line d
- deriving (Eq,Show)
-unLine :: Line d -> d
-unLine (Line d) = d
-
--- ** Type 'Word'
-newtype Word d = Word d
- deriving (Eq,Show,Semigroup)
-unWord :: Word d -> d
-unWord (Word d) = d
-instance From [SGR] d => From [SGR] (Word d) where
- from = Word . from
-
+{-
+-- ** Type 'Horiz'
+newtype Horiz repr a = Horiz { unHoriz :: repr a }
+ deriving (Eq, Show, Semigroup)
+type instance Derived (Horiz repr) = repr
+instance Derivable (Horiz repr) where
+ derive = unHoriz
+instance LiftDerived (Horiz repr) where
+ liftDerived = Horiz
+instance LiftDerived1 (Horiz repr)
+instance LiftDerived2 (Horiz repr)
+instance LiftDerived3 (Horiz repr)
+instance Emptyable repr => Emptyable (Horiz repr)
+--instance Semigroupable repr => Semigroupable (Horiz repr)
+instance ProductFunctor repr => ProductFunctor (Horiz repr) where
+ (<.) = liftDerived2 (<.)
+ (.>) = liftDerived2 (.>)
+instance
+ ( ProductFunctor repr
+ , Spaceable repr
+ ) => Spaceable (Horiz repr)
+-}
+
+{-
+instance From [SGR] repr => From [SGR] (Horiz repr) where
+ from = Horiz . from
+
+class Inject a repr ty where
+ inject :: a -> repr ty
+instance Inject String repr H => Inject Int repr H where
+ inject = inject . show
+instance Inject String repr H => Inject Integer repr H where
+ inject = inject . show
+instance Inject String repr H => Inject Natural repr H where
+ inject = inject . show
+instance Inject String repr H => Inject [SGR] repr H where
+ inject = inject . ANSI.setSGRCode
+instance Inject Text repr a => Inject TL.Text repr a where
+ inject = inject . TL.toStrict
+-}
+
+{-
-- * Class 'From'
-class From a d where
- from :: a -> d
- default from :: From String d => Show a => a -> d
+class From a repr where
+ from :: a -> repr
+ default from :: From String repr => Show a => a -> repr
from = from . show
-instance From (Line String) d => From Int d where
- from = from . Line . show
-instance From (Line String) d => From Integer d where
- from = from . Line . show
-instance From (Line String) d => From Natural d where
- from = from . Line . show
-- String
-instance From Char String where
- from = pure
-instance From String String where
- from = id
-instance From Text String where
- from = Text.unpack
-instance From TL.Text String where
- from = TL.unpack
-instance From d String => From (Line d) String where
+instance From repr String => From (Line repr) String where
from = from . unLine
-instance From d String => From (Word d) String where
+instance From repr String => From (Word repr) String where
from = from . unWord
instance From [SGR] String where
from = ANSI.setSGRCode
-- Text
-instance From Char Text where
- from = Text.singleton
-instance From String Text where
- from = Text.pack
-instance From Text Text where
- from = id
-instance From TL.Text Text where
- from = TL.toStrict
-instance From d Text => From (Line d) Text where
+instance From repr Text => From (Line repr) Text where
from = from . unLine
-instance From d Text => From (Word d) Text where
+instance From repr Text => From (Word repr) Text where
from = from . unWord
instance From [SGR] Text where
from = from . ANSI.setSGRCode
-- TL.Text
-instance From Char TL.Text where
- from = TL.singleton
-instance From String TL.Text where
- from = TL.pack
-instance From Text TL.Text where
- from = TL.fromStrict
-instance From TL.Text TL.Text where
- from = id
-instance From d TL.Text => From (Line d) TL.Text where
+instance From repr TL.Text => From (Line repr) TL.Text where
from = from . unLine
-instance From d TL.Text => From (Word d) TL.Text where
+instance From repr TL.Text => From (Word repr) TL.Text where
from = from . unWord
instance From [SGR] TL.Text where
from = from . ANSI.setSGRCode
-- TLB.Builder
-instance From Char TLB.Builder where
- from = TLB.singleton
-instance From String TLB.Builder where
- from = fromString
-instance From Text TLB.Builder where
- from = TLB.fromText
-instance From TL.Text TLB.Builder where
- from = TLB.fromLazyText
-instance From TLB.Builder TLB.Builder where
- from = id
-instance From d TLB.Builder => From (Line d) TLB.Builder where
+instance From repr TLB.Builder => From (Line repr) TLB.Builder where
from = from . unLine
-instance From d TLB.Builder => From (Word d) TLB.Builder where
+instance From repr TLB.Builder => From (Word repr) TLB.Builder where
from = from . unWord
instance From [SGR] TLB.Builder where
from = from . ANSI.setSGRCode
runTextBuilder :: TLB.Builder -> TL.Text
runTextBuilder = TLB.toLazyText
-
--- * Class 'Lengthable'
-class Lengthable d where
- width :: d -> Column
- nullWidth :: d -> Bool
- nullWidth d = width d == 0
-instance Lengthable Char where
- width _ = 1
- nullWidth = const False
-instance Lengthable String where
- width = fromIntegral . List.length
- nullWidth = Fold.null
-instance Lengthable Text.Text where
- width = fromIntegral . Text.length
- nullWidth = Text.null
-instance Lengthable TL.Text where
- width = fromIntegral . TL.length
- nullWidth = TL.null
-instance Lengthable d => Lengthable (Line d) where
- width = fromIntegral . width . unLine
- nullWidth = nullWidth . unLine
-instance Lengthable d => Lengthable (Word d) where
- width = fromIntegral . width . unWord
- nullWidth = nullWidth . unWord
+-}
-- * Class 'Spaceable'
-class Monoid d => Spaceable d where
- newline :: d
- space :: d
- default newline :: Spaceable (UnTrans d) => Trans d => d
- default space :: Spaceable (UnTrans d) => Trans d => d
- newline = noTrans newline
- space = noTrans space
-
+class
+ ( ProductFunctor repr
+ , Emptyable repr
+ ) => Spaceable repr where
+ space :: repr ()
-- | @'spaces' ind = 'replicate' ind 'space'@
- spaces :: Column -> d
- default spaces :: Monoid d => Column -> d
+ spaces :: Column -> repr ()
+ default space :: FromDerived Spaceable repr => repr ()
+ default spaces :: Column -> repr ()
spaces i = replicate (fromIntegral i) space
- unlines :: Foldable f => f (Line d) -> d
- unlines = Fold.foldr (\(Line x) acc -> x<>newline<>acc) mempty
- unwords :: Foldable f => Functor f => f (Word d) -> d
- unwords = intercalate space . (unWord <$>)
- -- | Like 'unlines' but without the trailing 'newline'.
- catLines :: Foldable f => Functor f => f (Line d) -> d
- catLines = catV . (unLine <$>)
+ space = liftDerived space
-- | @x '<+>' y = x '<>' 'space' '<>' y@
- (<+>) :: d -> d -> d
+ (<+>) :: repr a -> repr b -> repr (a,b)
+ x <+> y = x <.> space .> y
+ (+>) :: repr () -> repr a -> repr a
+ x +> y = x .> space .> y
+ (<+) :: repr a -> repr () -> repr a
+ x <+ y = x <. space <. y
+
+-- * Class 'Newlineable'
+class Newlineable repr where
+ newline :: repr ()
+ default newline :: FromDerived Newlineable repr => repr ()
+ newline = liftDerived newline
+
+ unlines ::
+ Emptyable repr =>
+ ProductFunctor repr =>
+ Foldable f =>
+ f (repr ()) -> repr ()
+ unlines = Fold.foldr (\x acc -> x.>newline.>acc) empty
+ unlines_ :: Listable repr => repr a -> repr [a]
+ unlines_ = intercalate_ newline
-- | @x '</>' y = x '<>' 'newline' '<>' y@
- (</>) :: d -> d -> d
- x <+> y = x <> space <> y
- x </> y = x <> newline <> y
- catH :: Foldable f => f d -> d
- catV :: Foldable f => f d -> d
- catH = Fold.foldr (<>) mempty
+ (</>) :: ProductFunctor repr => repr a -> repr b -> repr (a,b)
+ x </> y = x <.> newline .> y
+ catV ::
+ ProductFunctor repr =>
+ Emptyable repr =>
+ Foldable f =>
+ f (repr ()) -> repr ()
catV = intercalate newline
infixr 6 <+>
infixr 6 </>
-instance Spaceable String where
+{-
+instance Spaceable (f String) where
newline = "\n"
space = " "
spaces n = List.replicate (fromIntegral n) ' '
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
-
-replicate :: Monoid d => Int -> d -> d
-replicate cnt t | cnt <= 0 = mempty
- | otherwise = t `mappend` replicate (pred cnt) t
-
-between :: Semigroup d => d -> d -> d -> d
-between o c d = o<>d<>c
-parens :: Semigroup d => From (Word Char) d => d -> d
-parens = between (from (Word '(')) (from (Word ')'))
-braces :: Semigroup d => From (Word Char) d => d -> d
-braces = between (from (Word '{')) (from (Word '}'))
-brackets :: Semigroup d => From (Word Char) d => d -> d
-brackets = between (from (Word '[')) (from (Word ']'))
-angles :: Semigroup d => From (Word Char) d => d -> d
-angles = between (from (Word '<')) (from (Word '>'))
-
--- * Class 'Splitable'
-class (Lengthable d, Monoid d) => Splitable d where
- tail :: d -> Maybe d
- break :: (Char -> Bool) -> d -> (d, d)
- span :: (Char -> Bool) -> d -> (d, d)
- span f = break (not . f)
- lines :: d -> [Line d]
- words :: d -> [Word d]
- linesNoEmpty :: d -> [Line d]
- wordsNoEmpty :: d -> [Word d]
- lines = (Line <$>) . splitOnChar (== '\n')
- words = (Word <$>) . splitOnChar (== ' ')
- linesNoEmpty = (Line <$>) . splitOnCharNoEmpty (== '\n')
- wordsNoEmpty = (Word <$>) . splitOnCharNoEmpty (== ' ')
-
- splitOnChar :: (Char -> Bool) -> d -> [d]
- splitOnChar f d0 =
- if nullWidth d0 then [] else go d0
- where
- go d =
- let (l,r) = f`break`d in
- l : case tail r of
- Nothing -> []
- Just rt | nullWidth rt -> [mempty]
- | otherwise -> go rt
- splitOnCharNoEmpty :: (Char -> Bool) -> d -> [d]
- splitOnCharNoEmpty f d =
- let (l,r) = f`break`d in
- (if nullWidth l then [] else [l]) <>
- case tail r of
- Nothing -> []
- Just rt -> splitOnCharNoEmpty f rt
-instance Splitable String where
- tail [] = Nothing
- tail s = Just $ List.tail s
- break = List.break
-instance Splitable Text.Text where
- tail "" = Nothing
- tail s = Just $ Text.tail s
- break = Text.break
-instance Splitable TL.Text where
- tail "" = Nothing
- tail s = Just $ TL.tail s
- break = TL.break
+-}
+
+intercalate ::
+ Foldable f => Emptyable repr =>
+ ProductFunctor repr =>
+ repr () -> f (repr ()) -> repr ()
+intercalate sep rs
+ | Fold.null rs = empty
+ | otherwise = Fold.foldr1 (\x y -> x.>sep.>y) rs
+
+replicate ::
+ Emptyable repr => ProductFunctor repr =>
+ Int -> repr () -> repr ()
+replicate cnt t
+ | cnt <= 0 = empty
+ | otherwise = t .> replicate (pred cnt) t
+
+between ::
+ ProductFunctor repr =>
+ repr () -> repr () -> repr a -> repr a
+between o c x = o.>x<.c
+parens, braces, brackets, angles ::
+ ProductFunctor repr =>
+ Voidable repr =>
+ Inferable Char repr =>
+ repr a -> repr a
+parens = between (void '(' infer) (void ')' infer)
+braces = between (void '{' infer) (void '}' infer)
+brackets = between (void '[' infer) (void ']' infer)
+angles = between (void '<' infer) (void '>' infer)
-- * Class 'Decorable'
-class Decorable d where
- bold :: d -> d
- underline :: d -> d
- italic :: d -> d
- default bold :: Decorable (UnTrans d) => Trans d => d -> d
- default underline :: Decorable (UnTrans d) => Trans d => d -> d
- default italic :: Decorable (UnTrans d) => Trans d => d -> d
- bold = noTrans1 bold
- underline = noTrans1 underline
- italic = noTrans1 italic
+class Decorable repr where
+ bold :: repr a -> repr a
+ underline :: repr a -> repr a
+ italic :: repr a -> repr a
+ default bold :: FromDerived1 Decorable repr => repr a -> repr a
+ default underline :: FromDerived1 Decorable repr => repr a -> repr a
+ default italic :: FromDerived1 Decorable repr => repr a -> repr a
+ bold = liftDerived1 bold
+ underline = liftDerived1 underline
+ italic = liftDerived1 italic
-- * Class 'Colorable16'
-class Colorable16 d where
- reverse :: d -> d
+class Colorable16 repr where
+ reverse :: repr a -> repr a
-- Foreground colors
-- Dull
- black :: d -> d
- red :: d -> d
- green :: d -> d
- yellow :: d -> d
- blue :: d -> d
- magenta :: d -> d
- cyan :: d -> d
- white :: d -> d
+ black :: repr a -> repr a
+ red :: repr a -> repr a
+ green :: repr a -> repr a
+ yellow :: repr a -> repr a
+ blue :: repr a -> repr a
+ magenta :: repr a -> repr a
+ cyan :: repr a -> repr a
+ white :: repr a -> repr a
-- Vivid
- blacker :: d -> d
- redder :: d -> d
- greener :: d -> d
- yellower :: d -> d
- bluer :: d -> d
- magentaer :: d -> d
- cyaner :: d -> d
- whiter :: d -> d
+ blacker :: repr a -> repr a
+ redder :: repr a -> repr a
+ greener :: repr a -> repr a
+ yellower :: repr a -> repr a
+ bluer :: repr a -> repr a
+ magentaer :: repr a -> repr a
+ cyaner :: repr a -> repr a
+ whiter :: repr a -> repr a
-- Background colors
-- Dull
- onBlack :: d -> d
- onRed :: d -> d
- onGreen :: d -> d
- onYellow :: d -> d
- onBlue :: d -> d
- onMagenta :: d -> d
- onCyan :: d -> d
- onWhite :: d -> d
+ onBlack :: repr a -> repr a
+ onRed :: repr a -> repr a
+ onGreen :: repr a -> repr a
+ onYellow :: repr a -> repr a
+ onBlue :: repr a -> repr a
+ onMagenta :: repr a -> repr a
+ onCyan :: repr a -> repr a
+ onWhite :: repr a -> repr a
-- Vivid
- onBlacker :: d -> d
- onRedder :: d -> d
- onGreener :: d -> d
- onYellower :: d -> d
- onBluer :: d -> d
- onMagentaer :: d -> d
- onCyaner :: d -> d
- onWhiter :: d -> d
-
- default reverse :: Colorable16 (UnTrans d) => Trans d => d -> d
- default black :: Colorable16 (UnTrans d) => Trans d => d -> d
- default red :: Colorable16 (UnTrans d) => Trans d => d -> d
- default green :: Colorable16 (UnTrans d) => Trans d => d -> d
- default yellow :: Colorable16 (UnTrans d) => Trans d => d -> d
- default blue :: Colorable16 (UnTrans d) => Trans d => d -> d
- default magenta :: Colorable16 (UnTrans d) => Trans d => d -> d
- default cyan :: Colorable16 (UnTrans d) => Trans d => d -> d
- default white :: Colorable16 (UnTrans d) => Trans d => d -> d
- default blacker :: Colorable16 (UnTrans d) => Trans d => d -> d
- default redder :: Colorable16 (UnTrans d) => Trans d => d -> d
- default greener :: Colorable16 (UnTrans d) => Trans d => d -> d
- default yellower :: Colorable16 (UnTrans d) => Trans d => d -> d
- default bluer :: Colorable16 (UnTrans d) => Trans d => d -> d
- default magentaer :: Colorable16 (UnTrans d) => Trans d => d -> d
- default cyaner :: Colorable16 (UnTrans d) => Trans d => d -> d
- default whiter :: Colorable16 (UnTrans d) => Trans d => d -> d
- default onBlack :: Colorable16 (UnTrans d) => Trans d => d -> d
- default onRed :: Colorable16 (UnTrans d) => Trans d => d -> d
- default onGreen :: Colorable16 (UnTrans d) => Trans d => d -> d
- default onYellow :: Colorable16 (UnTrans d) => Trans d => d -> d
- default onBlue :: Colorable16 (UnTrans d) => Trans d => d -> d
- default onMagenta :: Colorable16 (UnTrans d) => Trans d => d -> d
- default onCyan :: Colorable16 (UnTrans d) => Trans d => d -> d
- default onWhite :: Colorable16 (UnTrans d) => Trans d => d -> d
- default onBlacker :: Colorable16 (UnTrans d) => Trans d => d -> d
- default onRedder :: Colorable16 (UnTrans d) => Trans d => d -> d
- default onGreener :: Colorable16 (UnTrans d) => Trans d => d -> d
- default onYellower :: Colorable16 (UnTrans d) => Trans d => d -> d
- default onBluer :: Colorable16 (UnTrans d) => Trans d => d -> d
- default onMagentaer :: Colorable16 (UnTrans d) => Trans d => d -> d
- default onCyaner :: Colorable16 (UnTrans d) => Trans d => d -> d
- default onWhiter :: Colorable16 (UnTrans d) => Trans d => d -> d
-
- reverse = noTrans1 reverse
- black = noTrans1 black
- red = noTrans1 red
- green = noTrans1 green
- yellow = noTrans1 yellow
- blue = noTrans1 blue
- magenta = noTrans1 magenta
- cyan = noTrans1 cyan
- white = noTrans1 white
- blacker = noTrans1 blacker
- redder = noTrans1 redder
- greener = noTrans1 greener
- yellower = noTrans1 yellower
- bluer = noTrans1 bluer
- magentaer = noTrans1 magentaer
- cyaner = noTrans1 cyaner
- whiter = noTrans1 whiter
- onBlack = noTrans1 onBlack
- onRed = noTrans1 onRed
- onGreen = noTrans1 onGreen
- onYellow = noTrans1 onYellow
- onBlue = noTrans1 onBlue
- onMagenta = noTrans1 onMagenta
- onCyan = noTrans1 onCyan
- onWhite = noTrans1 onWhite
- onBlacker = noTrans1 onBlacker
- onRedder = noTrans1 onRedder
- onGreener = noTrans1 onGreener
- onYellower = noTrans1 onYellower
- onBluer = noTrans1 onBluer
- onMagentaer = noTrans1 onMagentaer
- onCyaner = noTrans1 onCyaner
- onWhiter = noTrans1 onWhiter
-
--- | For debugging purposes.
-instance Colorable16 String where
- reverse = xmlSGR "reverse"
- black = xmlSGR "black"
- red = xmlSGR "red"
- green = xmlSGR "green"
- yellow = xmlSGR "yellow"
- blue = xmlSGR "blue"
- magenta = xmlSGR "magenta"
- cyan = xmlSGR "cyan"
- white = xmlSGR "white"
- blacker = xmlSGR "blacker"
- redder = xmlSGR "redder"
- greener = xmlSGR "greener"
- yellower = xmlSGR "yellower"
- bluer = xmlSGR "bluer"
- magentaer = xmlSGR "magentaer"
- cyaner = xmlSGR "cyaner"
- whiter = xmlSGR "whiter"
- onBlack = xmlSGR "onBlack"
- onRed = xmlSGR "onRed"
- onGreen = xmlSGR "onGreen"
- onYellow = xmlSGR "onYellow"
- onBlue = xmlSGR "onBlue"
- onMagenta = xmlSGR "onMagenta"
- onCyan = xmlSGR "onCyan"
- onWhite = xmlSGR "onWhite"
- onBlacker = xmlSGR "onBlacker"
- onRedder = xmlSGR "onRedder"
- onGreener = xmlSGR "onGreener"
- onYellower = xmlSGR "onYellower"
- onBluer = xmlSGR "onBluer"
- onMagentaer = xmlSGR "onMagentaer"
- onCyaner = xmlSGR "onCyaner"
- onWhiter = xmlSGR "onWhiter"
-
--- | For debugging purposes.
-xmlSGR :: Semigroup d => From String d => String -> d -> d
-xmlSGR newSGR s = from ("<"<>newSGR<>">")<>s<>from ("</"<>newSGR<>">")
+ onBlacker :: repr a -> repr a
+ onRedder :: repr a -> repr a
+ onGreener :: repr a -> repr a
+ onYellower :: repr a -> repr a
+ onBluer :: repr a -> repr a
+ onMagentaer :: repr a -> repr a
+ onCyaner :: repr a -> repr a
+ onWhiter :: repr a -> repr a
+
+ default reverse :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default black :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default red :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default green :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default yellow :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default blue :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default magenta :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default cyan :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default white :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default blacker :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default redder :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default greener :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default yellower :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default bluer :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default magentaer :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default cyaner :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default whiter :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default onBlack :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default onRed :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default onGreen :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default onYellow :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default onBlue :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default onMagenta :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default onCyan :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default onWhite :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default onBlacker :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default onRedder :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default onGreener :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default onYellower :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default onBluer :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default onMagentaer :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default onCyaner :: FromDerived1 Colorable16 repr => repr a -> repr a
+ default onWhiter :: FromDerived1 Colorable16 repr => repr a -> repr a
+
+ reverse = liftDerived1 reverse
+ black = liftDerived1 black
+ red = liftDerived1 red
+ green = liftDerived1 green
+ yellow = liftDerived1 yellow
+ blue = liftDerived1 blue
+ magenta = liftDerived1 magenta
+ cyan = liftDerived1 cyan
+ white = liftDerived1 white
+ blacker = liftDerived1 blacker
+ redder = liftDerived1 redder
+ greener = liftDerived1 greener
+ yellower = liftDerived1 yellower
+ bluer = liftDerived1 bluer
+ magentaer = liftDerived1 magentaer
+ cyaner = liftDerived1 cyaner
+ whiter = liftDerived1 whiter
+ onBlack = liftDerived1 onBlack
+ onRed = liftDerived1 onRed
+ onGreen = liftDerived1 onGreen
+ onYellow = liftDerived1 onYellow
+ onBlue = liftDerived1 onBlue
+ onMagenta = liftDerived1 onMagenta
+ onCyan = liftDerived1 onCyan
+ onWhite = liftDerived1 onWhite
+ onBlacker = liftDerived1 onBlacker
+ onRedder = liftDerived1 onRedder
+ onGreener = liftDerived1 onGreener
+ onYellower = liftDerived1 onYellower
+ onBluer = liftDerived1 onBluer
+ onMagentaer = liftDerived1 onMagentaer
+ onCyaner = liftDerived1 onCyaner
+ onWhiter = liftDerived1 onWhiter
-- * Class 'Indentable'
-class Spaceable d => Indentable d where
- -- | @('align' d)@ make @d@ uses current 'Column' as 'Indent' level.
- align :: d -> d
- -- | @('setIndent' p ind d)@ make @d@ uses @ind@ as 'Indent' level.
+class Spaceable repr => Indentable repr where
+ -- | @('align' doc)@ make @doc@ uses current 'Column' as 'Indent' level.
+ align :: repr a -> repr a
+ -- | @('setIndent' p ind doc)@ make @doc@ uses @ind@ as 'Indent' level.
-- Using @p@ as 'Indent' text.
- setIndent :: d -> Indent -> d -> d
- -- | @('incrIndent' p ind d)@ make @d@ uses current 'Indent' plus @ind@ as 'Indent' level.
+ setIndent :: repr () -> Indent -> repr a -> repr a
+ -- | @('incrIndent' p ind doc)@ make @doc@ uses current 'Indent' plus @ind@ as 'Indent' level.
-- Appending @p@ to the current 'Indent' text.
- incrIndent :: d -> Indent -> d -> d
- hang :: Indent -> d -> d
+ incrIndent :: repr () -> Indent -> repr a -> repr a
+ hang :: Indent -> repr a -> repr a
hang ind = align . incrIndent (spaces ind) ind
- -- | @('fill' w d)@ write @d@,
- -- then if @d@ is not wider than @w@,
+ -- | @('fill' w doc)@ write @doc@,
+ -- then if @doc@ is not wider than @w@,
-- write the difference with 'spaces'.
- fill :: Width -> d -> d
- -- | @('fillOrBreak' w d)@ write @d@,
- -- then if @d@ is not wider than @w@, write the difference with 'spaces'
- -- otherwise write a 'newline' indented to to the start 'Column' of @d@ plus @w@.
- fillOrBreak :: Width -> d -> d
-
- default align :: Indentable (UnTrans d) => Trans d => d -> d
- default incrIndent :: Indentable (UnTrans d) => Trans d => d -> Indent -> d -> d
- default setIndent :: Indentable (UnTrans d) => Trans d => d -> Indent -> d -> d
- default fill :: Indentable (UnTrans d) => Trans d => Width -> d -> d
- default fillOrBreak :: Indentable (UnTrans d) => Trans d => Width -> d -> d
-
- align = noTrans1 align
- setIndent p i = noTrans . setIndent (unTrans p) i . unTrans
- incrIndent p i = noTrans . incrIndent (unTrans p) i . unTrans
- fill = noTrans1 . fill
- fillOrBreak = noTrans1 . fillOrBreak
-
-class Listable d where
- ul :: Traversable f => f d -> d
- ol :: Traversable f => f d -> d
+ fill :: Width -> repr a -> repr a
+ -- | @('fillOrBreak' w doc)@ write @doc@,
+ -- then if @doc@ is not wider than @w@, write the difference with 'spaces'
+ -- otherwise write a 'newline' indented to to the start 'Column' of @doc@ plus @w@.
+ fillOrBreak :: Width -> repr a -> repr a
+
+ default align :: FromDerived1 Indentable repr => repr a -> repr a
+ default incrIndent :: FromDerived2 Indentable repr => repr () -> Indent -> repr a -> repr a
+ default setIndent :: FromDerived2 Indentable repr => repr () -> Indent -> repr a -> repr a
+ default fill :: FromDerived1 Indentable repr => Width -> repr a -> repr a
+ default fillOrBreak :: FromDerived1 Indentable repr => Width -> repr a -> repr a
+
+ align = liftDerived1 align
+ setIndent p i = liftDerived2 (`setIndent`i) p
+ incrIndent p i = liftDerived2 (`incrIndent`i) p
+ fill = liftDerived1 . fill
+ fillOrBreak = liftDerived1 . fillOrBreak
+
+-- * Class 'Listable'
+class Listable repr where
+ ul :: Traversable f => f (repr ()) -> repr ()
+ ol :: Traversable f => f (repr ()) -> repr ()
default ul ::
- Listable (UnTrans d) => Trans d =>
- Traversable f => f d -> d
+ FromDerived Listable repr => Derivable repr =>
+ Traversable f => f (repr ()) -> repr ()
default ol ::
- Listable (UnTrans d) => Trans d =>
- Traversable f => f d -> d
- ul ds = noTrans $ ul $ unTrans <$> ds
- ol ds = noTrans $ ol $ unTrans <$> ds
+ FromDerived Listable repr => Derivable repr =>
+ Traversable f => f (repr ()) -> repr ()
+ ul xs = liftDerived $ ul $ derive Fct.<$> xs
+ ol xs = liftDerived $ ol $ derive Fct.<$> xs
+ unorderedList :: repr a -> repr [a]
+ orderedList :: repr a -> repr [a]
+ list_ :: repr () -> repr () -> repr () -> repr a -> repr [a]
+ default unorderedList :: FromDerived1 Listable repr => repr a -> repr [a]
+ default orderedList :: FromDerived1 Listable repr => repr a -> repr [a]
+ default list_ :: FromDerived4 Listable repr => repr () -> repr () -> repr () -> repr a -> repr [a]
+ unorderedList = liftDerived1 unorderedList
+ orderedList = liftDerived1 orderedList
+ list_ = liftDerived4 list_
+ intercalate_ :: repr () -> repr a -> repr [a]
+ default intercalate_ ::
+ FromDerived2 Listable repr =>
+ repr () -> repr a -> repr [a]
+ intercalate_ = liftDerived2 intercalate_
+ braceList ::
+ Voidable repr => Inferable Char repr =>
+ repr a -> repr [a]
+ braceList = list_ (void '{' infer) (void ',' infer) (void '}' infer)
+ bracketList ::
+ Voidable repr => Inferable Char repr =>
+ repr a -> repr [a]
+ bracketList = list_ (void '[' infer) (void ',' infer) (void ']' infer)
+ parenList ::
+ Voidable repr => Inferable Char repr =>
+ repr a -> repr [a]
+ parenList = list_ (void '(' infer) (void ',' infer) (void ')' infer)
+ angleList ::
+ Voidable repr => Inferable Char repr =>
+ repr a -> repr [a]
+ angleList = list_ (void '<' infer) (void ',' infer) (void '>' infer)
-- * Class 'Wrappable'
-class Wrappable d where
- setWidth :: Maybe Width -> d -> d
- -- getWidth :: (Maybe Width -> d) -> d
- breakpoint :: d
- breakspace :: d
- breakalt :: d -> d -> d
- endline :: d
- default breakpoint :: Wrappable (UnTrans d) => Trans d => d
- default breakspace :: Wrappable (UnTrans d) => Trans d => d
- default breakalt :: Wrappable (UnTrans d) => Trans d => d -> d -> d
- default endline :: Wrappable (UnTrans d) => Trans d => d
- breakpoint = noTrans breakpoint
- breakspace = noTrans breakspace
- breakalt = noTrans2 breakalt
- endline = noTrans endline
+class Wrappable repr where
+ setWidth :: Maybe Width -> repr a -> repr a
+ -- getWidth :: (Maybe Width -> repr a) -> repr a
+ breakpoint :: repr ()
+ breakspace :: repr ()
+ breakalt :: repr a -> repr a -> repr a
+ endline :: repr ()
+ default breakpoint :: FromDerived Wrappable repr => repr ()
+ default breakspace :: FromDerived Wrappable repr => repr ()
+ default breakalt :: FromDerived2 Wrappable repr => repr a -> repr a -> repr a
+ default endline :: FromDerived Wrappable repr => repr ()
+ breakpoint = liftDerived breakpoint
+ breakspace = liftDerived breakspace
+ breakalt = liftDerived2 breakalt
+ endline = liftDerived endline
+ unwords ::
+ ProductFunctor repr =>
+ Listable repr =>
+ Emptyable repr =>
+ Foldable f =>
+ f (repr ()) -> repr ()
+ unwords_ :: Listable repr => repr a -> repr [a]
+ unwords = intercalate breakspace
+ unwords_ = intercalate_ breakspace
-- * Class 'Justifiable'
-class Justifiable d where
- justify :: d -> d
-
--- * Class 'Trans'
-class Trans repr where
- -- | Return the underlying @repr@ of the transformer.
- type UnTrans repr :: Type
-
- -- | Lift a repr to the transformer's.
- noTrans :: UnTrans repr -> repr
- -- | Unlift a repr from the transformer's.
- unTrans :: repr -> UnTrans repr
-
- -- | Identity transformation for a unary symantic method.
- noTrans1 :: (UnTrans repr -> UnTrans repr) -> (repr -> repr)
- noTrans1 f = noTrans . f . unTrans
-
- -- | Identity transformation for a binary symantic method.
- noTrans2
- :: (UnTrans repr -> UnTrans repr -> UnTrans repr)
- -> (repr -> repr -> repr)
- noTrans2 f a b = noTrans (f (unTrans a) (unTrans b))
-
- -- | Identity transformation for a ternary symantic method.
- noTrans3
- :: (UnTrans repr -> UnTrans repr -> UnTrans repr -> UnTrans repr)
- -> (repr -> repr -> repr -> repr)
- noTrans3 f a b c = noTrans (f (unTrans a) (unTrans b) (unTrans c))
+class Justifiable repr where
+ justify :: repr a -> repr a
+
+-- * Class 'Inferable'
+class Inferable a repr where
+ infer :: repr a
+ default infer :: FromDerived (Inferable a) repr => repr a
+ infer = liftDerived infer
+string :: Inferable String repr => repr String
+string = infer
+int :: Inferable Int repr => repr Int
+int = infer
+natural :: Inferable Natural repr => repr Natural
+natural = infer
--- /dev/null
+{-# LANGUAGE UndecidableInstances #-} -- For IsString (repr ())
+module Symantic.Document.Debug where
+
+import Data.Function (($))
+import Data.Semigroup ((<>))
+import Data.String (String, IsString(..))
+import Symantic.Document.Class
+
+newtype XML repr a = XML { unXML :: repr a }
+
+-- | For debugging purposes.
+instance
+ ( ProductFunctor repr
+ , IsString (repr ())
+ ) => Colorable16 (XML repr) where
+ reverse = xmlSGR "reverse"
+ black = xmlSGR "black"
+ red = xmlSGR "red"
+ green = xmlSGR "green"
+ yellow = xmlSGR "yellow"
+ blue = xmlSGR "blue"
+ magenta = xmlSGR "magenta"
+ cyan = xmlSGR "cyan"
+ white = xmlSGR "white"
+ blacker = xmlSGR "blacker"
+ redder = xmlSGR "redder"
+ greener = xmlSGR "greener"
+ yellower = xmlSGR "yellower"
+ bluer = xmlSGR "bluer"
+ magentaer = xmlSGR "magentaer"
+ cyaner = xmlSGR "cyaner"
+ whiter = xmlSGR "whiter"
+ onBlack = xmlSGR "onBlack"
+ onRed = xmlSGR "onRed"
+ onGreen = xmlSGR "onGreen"
+ onYellow = xmlSGR "onYellow"
+ onBlue = xmlSGR "onBlue"
+ onMagenta = xmlSGR "onMagenta"
+ onCyan = xmlSGR "onCyan"
+ onWhite = xmlSGR "onWhite"
+ onBlacker = xmlSGR "onBlacker"
+ onRedder = xmlSGR "onRedder"
+ onGreener = xmlSGR "onGreener"
+ onYellower = xmlSGR "onYellower"
+ onBluer = xmlSGR "onBluer"
+ onMagentaer = xmlSGR "onMagentaer"
+ onCyaner = xmlSGR "onCyaner"
+ onWhiter = xmlSGR "onWhiter"
+
+xmlSGR ::
+ IsString (repr ()) =>
+ ProductFunctor repr =>
+ String -> XML repr a -> XML repr a
+xmlSGR newSGR s = XML $
+ fromString ("<"<>newSGR<>">")
+ .> unXML s <.
+ fromString ("</"<>newSGR<>">")
+
-{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}
module Symantic.Document.Plain where
import Data.Eq (Eq(..))
import Data.Function (($), (.), id)
import Data.Functor ((<$>))
+import Data.Int (Int)
+import Data.Kind (Type)
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..), Ordering(..))
import Data.Semigroup (Semigroup(..))
-import Data.String (String, IsString(..))
-import Data.Text (Text)
-import Data.Tuple (snd)
+import Data.String (IsString(..), String)
import GHC.Natural (minusNatural,minusNaturalMaybe,quotRemNatural)
import Numeric.Natural (Natural)
-import Prelude (fromIntegral, Num(..), pred)
+import Prelude (fromIntegral, Num(..), pred, error)
import System.Console.ANSI hiding (SGR)
import Text.Show (Show(..), showString, showParen)
import qualified Data.Foldable as Fold
import qualified Data.List as List
+import qualified Data.Tuple as Tuple
+import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
+--import qualified Data.Text.Lazy.Builder as TLB
+import Symantic.Class
+ ( Repeatable(..)
+ )
import Symantic.Document.Class
+import Symantic.Document.Utils
-- * Type 'Plain'
-- | Church encoded for performance concerns.
-- Kind like 'ParsecT' in @megaparsec@ but a little bit different
-- due to the use of 'PlainFit' for implementing 'breakingSpace' correctly
--- when in the left hand side of ('<>').
+-- when in the left hand side of ('<.>').
-- Prepending is done using continuation, like in a difference list.
-newtype Plain d = Plain
- { unPlain ::
- {-curr-}PlainInh d ->
- {-curr-}PlainState d ->
- {-ok-}( ({-prepend-}(d->d), {-new-}PlainState d) -> PlainFit d) ->
- PlainFit d
+newtype Plain (o::Type) a = Plain
+ { unPlain :: a ->
+ {-curr-}PlainInh o ->
+ {-curr-}PlainState o ->
+ {-ok-}( ({-prepend-}(o->o), {-new-}PlainState o) -> PlainFit o) ->
+ PlainFit o
-- NOTE: equivalent to:
- -- ReaderT PlainInh (StateT (PlainState d) (Cont (PlainFit d))) (d->d)
- }
-instance (Show d, Spaceable d) => Show (Plain d) where
- show = show . runPlain
+ -- ReaderT PlainInh (StateT (PlainState o) (Cont (PlainFit o))) (o->o)
+ }
+
+instance Semigroup o => ProductFunctor (Plain o) where
+ x <.> y = Plain $ \(a,b) inh st k ->
+ unPlain x a inh st $ \(px,sx) ->
+ unPlain y b inh sx $ \(py,sy) ->
+ k (px.py, sy)
+ x .> y = Plain $ \b inh st k ->
+ unPlain x () inh st $ \(px,sx) ->
+ unPlain y b inh sx $ \(py,sy) ->
+ k (px.py, sy)
+ x <. y = Plain $ \a inh st k ->
+ unPlain x a inh st $ \(px,sx) ->
+ unPlain y () inh sx $ \(py,sy) ->
+ k (px.py, sy)
+instance Emptyable (Plain o) where
+ empty = Plain $ \_a _inh st k -> k (id,st)
+instance Outputable o => Repeatable (Plain o) where
+ many0 item = Plain $ \as ->
+ unPlain (concat ((`void` item) <$> as)) ()
+ many1 item = Plain $ \case
+ [] -> error "many1"
+ as -> unPlain (concat ((`void` item) <$> as)) ()
-runPlain :: Spaceable d => Plain d -> d
-runPlain x =
- unPlain x
+-- String
+instance (Convertible String o, Outputable o) => IsString (Plain o ()) where
+ fromString = convert
+instance (Convertible String o, Outputable o) => Convertible String (Plain o ()) where
+ convert =
+ concat .
+ List.intersperse newline .
+ (
+ concat .
+ List.intersperse breakspace .
+ (wordPlain <$>) .
+ words <$>
+ ) . lines
+instance (Convertible T.Text o, Convertible Char o, Outputable o) => Convertible T.Text (Plain o ()) where
+ convert =
+ concat .
+ List.intersperse newline .
+ (
+ concat .
+ List.intersperse breakspace .
+ (wordPlain <$>) .
+ words <$>
+ ) . lines
+instance (Convertible TL.Text o, Convertible Char o, Outputable o) => Convertible TL.Text (Plain o ()) where
+ convert =
+ concat .
+ List.intersperse newline .
+ (
+ concat .
+ List.intersperse breakspace .
+ (wordPlain <$>) .
+ words <$>
+ ) . lines
+--intersperse sep = concat . List.intersperse sep
+instance (Convertible String o, Outputable o) => Inferable Int (Plain o) where
+ infer = showWordPlain
+instance (Convertible String o, Outputable o) => Inferable Natural (Plain o) where
+ infer = showWordPlain
+instance (Convertible String o, Outputable o) => Inferable (Word String) (Plain o) where
+ infer = Plain $ ($ ()) . unPlain . wordPlain
+instance (Convertible String o, Outputable o) => Inferable String (Plain o) where
+ infer = Plain $ ($ ()) . unPlain . fromString
+instance (Convertible T.Text o, Convertible Char o, Outputable o) => Inferable T.Text (Plain o) where
+ infer = Plain $ ($ ()) . unPlain . convert
+instance (Convertible TL.Text o, Convertible Char o, Outputable o) => Inferable TL.Text (Plain o) where
+ infer = Plain $ ($ ()) . unPlain . convert
+instance Outputable o => Inferable Char (Plain o) where
+ infer = Plain $ \o _inh st k -> k ((char o<>),st)
+showWordPlain ::
+ Show a =>
+ Convertible String o =>
+ Outputable o =>
+ Inferable a (Plain o) => Plain o a
+showWordPlain = Plain $
+ ($ ()) . unPlain . wordPlain .
+ Word . show
+
+runPlain :: Monoid o => Plain o a -> a -> o
+runPlain x a =
+ unPlain x a
defPlainInh
defPlainState
{-k-}(\(px,_sx) fits _overflow ->
{-overflow-}id
-- ** Type 'PlainState'
-data PlainState d = PlainState
- { plainState_buffer :: ![PlainChunk d]
+data PlainState o = PlainState
+ { plainState_buffer :: ![PlainChunk o]
, plainState_bufferStart :: !Column
-- ^ The 'Column' from which the 'plainState_buffer'
-- must be written.
-- into a 'newlineJustifyingPlain'.
} deriving (Show)
-defPlainState :: PlainState d
+defPlainState :: PlainState o
defPlainState = PlainState
- { plainState_buffer = mempty
- , plainState_bufferStart = 0
- , plainState_bufferWidth = 0
- , plainState_breakIndent = 0
- }
+ { plainState_buffer = mempty
+ , plainState_bufferStart = 0
+ , plainState_bufferWidth = 0
+ , plainState_breakIndent = 0
+ }
-- ** Type 'PlainInh'
-data PlainInh d = PlainInh
- { plainInh_width :: !(Maybe Column)
- , plainInh_justify :: !Bool
- , plainInh_indent :: !Indent
- , plainInh_indenting :: !(Plain d)
- , plainInh_sgr :: ![SGR]
- }
+data PlainInh o = PlainInh
+ { plainInh_width :: !(Maybe Column)
+ , plainInh_justify :: !Bool
+ , plainInh_indent :: !Indent
+ , plainInh_indenting :: !(Plain o ())
+ , plainInh_sgr :: ![SGR]
+ }
-defPlainInh :: Spaceable d => PlainInh d
+defPlainInh :: Monoid o => PlainInh o
defPlainInh = PlainInh
- { plainInh_width = Nothing
- , plainInh_justify = False
- , plainInh_indent = 0
- , plainInh_indenting = mempty
- , plainInh_sgr = []
- }
+ { plainInh_width = Nothing
+ , plainInh_justify = False
+ , plainInh_indent = 0
+ , plainInh_indenting = empty
+ , plainInh_sgr = []
+ }
-- ** Type 'PlainFit'
-- | Double continuation to qualify the returned document
-- as fitting or overflowing the given 'plainInh_width'.
--- It's like @('Bool',d)@ in a normal style
+-- It's like @('Bool',o)@ in a normal style
-- (a non continuation-passing-style).
-type PlainFit d =
- {-fits-}(d -> d) ->
- {-overflow-}(d -> d) ->
- d
+type PlainFit o =
+ {-fits-}(o -> o) ->
+ {-overflow-}(o -> o) ->
+ o
-- ** Type 'PlainChunk'
-data PlainChunk d
- = PlainChunk_Ignored !d
+data PlainChunk o
+ = PlainChunk_Ignored !o
-- ^ Ignored by the justification but kept in place.
-- Used for instance to put ANSI sequences.
- | PlainChunk_Word !(Word d)
+ | PlainChunk_Word !(Word o)
| PlainChunk_Spaces !Width
-- ^ 'spaces' preserved to be interleaved
-- correctly with 'PlainChunk_Ignored'.
-instance Show d => Show (PlainChunk d) where
+instance Show o => Show (PlainChunk o) where
showsPrec p x =
showParen (p>10) $
case x of
- PlainChunk_Ignored d ->
- showString "Z " .
- showsPrec 11 d
- PlainChunk_Word (Word d) ->
- showString "W " .
- showsPrec 11 d
- PlainChunk_Spaces s ->
- showString "S " .
- showsPrec 11 s
-instance Lengthable d => Lengthable (PlainChunk d) where
- width = \case
+ PlainChunk_Ignored o ->
+ showString "Z " .
+ showsPrec 11 o
+ PlainChunk_Word (Word o) ->
+ showString "W " .
+ showsPrec 11 o
+ PlainChunk_Spaces s ->
+ showString "S " .
+ showsPrec 11 s
+instance Lengthable o => Lengthable (PlainChunk o) where
+ length = \case
PlainChunk_Ignored{} -> 0
- PlainChunk_Word d -> width d
+ PlainChunk_Word o -> length o
PlainChunk_Spaces s -> s
- nullWidth = \case
+ isEmpty = \case
PlainChunk_Ignored{} -> True
- PlainChunk_Word d -> nullWidth d
+ PlainChunk_Word o -> isEmpty o
PlainChunk_Spaces s -> s == 0
-instance From [SGR] d => From [SGR] (PlainChunk d) where
- from sgr = PlainChunk_Ignored (from sgr)
+--instance From [SGR] o => From [SGR] (PlainChunk o) where
+-- from sgr = PlainChunk_Ignored (from sgr)
-runPlainChunk :: Spaceable d => PlainChunk d -> d
+runPlainChunk :: Outputable o => PlainChunk o -> o
runPlainChunk = \case
- PlainChunk_Ignored d -> d
- PlainChunk_Word (Word d) -> d
- PlainChunk_Spaces s -> spaces s
+ PlainChunk_Ignored o -> o
+ PlainChunk_Word (Word o) -> o
+ PlainChunk_Spaces s -> repeatedChar s ' '
-instance Semigroup d => Semigroup (Plain d) where
- Plain x <> Plain y = Plain $ \inh st k ->
- x inh st $ \(px,sx) ->
- y inh sx $ \(py,sy) ->
- k (px.py,sy)
-instance Monoid d => Monoid (Plain d) where
- mempty = Plain $ \_inh st k -> k (id,st)
- mappend = (<>)
-instance Spaceable d => Spaceable (Plain d) where
+instance Voidable (Plain o) where
+ void a p = Plain $ \() -> unPlain p a
+instance (Convertible Char o, Outputable o) => Spaceable (Plain o) where
+ space = spaces 1
+ spaces n = Plain $ \() inh st@PlainState{..} k fits overflow ->
+ let newWidth = plainState_bufferStart + plainState_bufferWidth + n in
+ if plainInh_justify inh
+ then
+ let newState = st
+ { plainState_buffer =
+ case plainState_buffer of
+ PlainChunk_Spaces s:buf -> PlainChunk_Spaces (s+n):buf
+ buf -> PlainChunk_Spaces n:buf
+ , plainState_bufferWidth = plainState_bufferWidth + n
+ } in
+ case plainInh_width inh of
+ Just maxWidth | maxWidth < newWidth ->
+ overflow $ k (id{-(o<>)-}, newState) fits overflow
+ _ -> k (id{-(o<>)-}, newState) fits overflow
+ else
+ let newState = st
+ { plainState_bufferWidth = plainState_bufferWidth + n
+ } in
+ case plainInh_width inh of
+ Just maxWidth | maxWidth < newWidth ->
+ overflow $ k ((repeatedChar n ' ' <>), newState) fits fits
+ _ -> k ((repeatedChar n ' ' <>), newState) fits overflow
+instance (Outputable o) => Newlineable (Plain o) where
-- | The default 'newline' does not justify 'plainState_buffer',
-- for that use 'newlineJustifyingPlain'.
- newline = Plain $ \inh st ->
+ newline = Plain $ \() inh st ->
unPlain
( newlinePlain
- <> indentPlain
- <> propagatePlain (plainState_breakIndent st)
- <> flushlinePlain
- ) inh st
+ <. indentPlain
+ <. propagatePlain (plainState_breakIndent st)
+ <. flushlinePlain
+ ) () inh st
where
- indentPlain = Plain $ \inh ->
+ indentPlain = Plain $ \() inh ->
unPlain
(plainInh_indenting inh)
- inh{plainInh_justify=False}
- newlinePlain = Plain $ \inh st k ->
+ () inh{plainInh_justify=False}
+ newlinePlain = Plain $ \() inh st k ->
k (\next ->
(if plainInh_justify inh
then joinLinePlainChunk $ List.reverse $ plainState_buffer st
else mempty
- )<>newline<>next
+ )<>nl<>next
, st
{ plainState_bufferStart = 0
, plainState_bufferWidth = 0
, plainState_buffer = mempty
})
- propagatePlain breakIndent = Plain $ \inh st1 k fits overflow ->
+ propagatePlain breakIndent = Plain $ \() inh st1 k fits overflow ->
k (id,st1)
fits
{-overflow-}(
then overflow
else fits
)
- space = spaces 1
- spaces n = Plain $ \inh st@PlainState{..} k fits overflow ->
- let newWidth = plainState_bufferStart + plainState_bufferWidth + n in
+
+-- | Commit 'plainState_buffer' upto there, so that it won'o be justified.
+flushlinePlain :: Outputable o => Plain o ()
+flushlinePlain = Plain $ \() _inh st k ->
+ k( (joinLinePlainChunk (collapsePlainChunkSpaces <$> List.reverse (plainState_buffer st)) <>)
+ , st
+ { plainState_bufferStart = plainState_bufferStart st + plainState_bufferWidth st
+ , plainState_bufferWidth = 0
+ , plainState_buffer = mempty
+ }
+ )
+
+-- | Just concat 'PlainChunk's with no justification.
+joinLinePlainChunk :: Outputable o => [PlainChunk o] -> o
+joinLinePlainChunk = mconcat . (runPlainChunk <$>)
+
+collapsePlainChunkSpaces :: PlainChunk o -> PlainChunk o
+collapsePlainChunkSpaces = \case
+ PlainChunk_Spaces s -> PlainChunk_Spaces (if s > 0 then 1 else 0)
+ x -> x
+
+wordPlain ::
+ Lengthable i => Convertible i o => Outputable o =>
+ Word i -> Plain o ()
+wordPlain inp = Plain $ \() inh st@PlainState{..} k fits overflow ->
+ let wordWidth = length inp in
+ let out = convert inp in
+ if wordWidth <= 0
+ then k (id,st) fits overflow
+ else
+ let newBufferWidth = plainState_bufferWidth + wordWidth in
+ let newWidth = plainState_bufferStart + newBufferWidth in
if plainInh_justify inh
then
let newState = st
- { plainState_buffer =
- case plainState_buffer of
- PlainChunk_Spaces s:buf -> PlainChunk_Spaces (s+n):buf
- buf -> PlainChunk_Spaces n:buf
- , plainState_bufferWidth = plainState_bufferWidth + n
+ { plainState_buffer = PlainChunk_Word out : plainState_buffer
+ , plainState_bufferWidth = newBufferWidth
} in
case plainInh_width inh of
Just maxWidth | maxWidth < newWidth ->
- overflow $ k (id{-(d<>)-}, newState) fits overflow
- _ -> k (id{-(d<>)-}, newState) fits overflow
+ overflow $ k (id, newState) fits overflow
+ _ -> k (id, newState) fits overflow
else
let newState = st
- { plainState_bufferWidth = plainState_bufferWidth + n
+ { plainState_bufferWidth = newBufferWidth
} in
case plainInh_width inh of
Just maxWidth | maxWidth < newWidth ->
- overflow $ k ((spaces n <>), newState) fits fits
- _ -> k ((spaces n <>), newState) fits overflow
-instance (From (Word s) d, Semigroup d, Lengthable s) =>
- From (Word s) (Plain d) where
- from s = Plain $ \inh st@PlainState{..} k fits overflow ->
- let wordWidth = width s in
- if wordWidth <= 0
- then k (id,st) fits overflow
- else
- let newBufferWidth = plainState_bufferWidth + wordWidth in
- let newWidth = plainState_bufferStart + newBufferWidth in
- if plainInh_justify inh
- then
- let newState = st
- { plainState_buffer =
- PlainChunk_Word (Word (from s)) :
- plainState_buffer
- , plainState_bufferWidth = newBufferWidth
- } in
- case plainInh_width inh of
- Just maxWidth | maxWidth < newWidth ->
- overflow $ k (id, newState) fits overflow
- _ -> k (id, newState) fits overflow
- else
- let newState = st
- { plainState_bufferWidth = newBufferWidth
- } in
- case plainInh_width inh of
- Just maxWidth | maxWidth < newWidth ->
- overflow $ k ((from s <>), newState) fits fits
- _ -> k ((from s <>), newState) fits overflow
-instance (From (Word s) d, Lengthable s, Spaceable d, Splitable s) =>
- From (Line s) (Plain d) where
- from =
- mconcat .
- List.intersperse breakspace .
- (from <$>) .
- words .
- unLine
-instance Spaceable d => Indentable (Plain d) where
- align p = (flushlinePlain <>) $ Plain $ \inh st ->
+ overflow $ k ((unWord out <>), newState) fits fits
+ _ -> k ((unWord out <>), newState) fits overflow
+
+instance (Convertible Char o, Outputable o) => Indentable (Plain o) where
+ align p = (flushlinePlain .>) $ Plain $ \a inh st ->
let col = plainState_bufferStart st + plainState_bufferWidth st in
- unPlain p inh
+ unPlain p a inh
{ plainInh_indent = col
, plainInh_indenting =
if plainInh_indent inh <= col
then
- plainInh_indenting inh <>
+ plainInh_indenting inh .>
spaces (col`minusNatural`plainInh_indent inh)
else spaces col
} st
- setIndent d i p = Plain $ \inh ->
- unPlain p inh
+ setIndent o i p = Plain $ \a inh ->
+ unPlain p a inh
{ plainInh_indent = i
- , plainInh_indenting = d
+ , plainInh_indenting = o
}
- incrIndent d i p = Plain $ \inh ->
- unPlain p inh
+ incrIndent o i p = Plain $ \a inh ->
+ unPlain p a inh
{ plainInh_indent = plainInh_indent inh + i
- , plainInh_indenting = plainInh_indenting inh <> d
+ , plainInh_indenting = plainInh_indenting inh .> o
}
-
- fill m p = Plain $ \inh0 st0 ->
+ fill m p = Plain $ \a inh0 st0 ->
let maxCol = plainState_bufferStart st0 + plainState_bufferWidth st0 + m in
- let p1 = Plain $ \inh1 st1 ->
+ let p1 = Plain $ \() inh1 st1 ->
let col = plainState_bufferStart st1 + plainState_bufferWidth st1 in
unPlain
(if col <= maxCol
then spaces (maxCol`minusNatural`col)
- else mempty)
- inh1 st1
+ else empty)
+ () inh1 st1
in
- unPlain (p <> p1) inh0 st0
- fillOrBreak m p = Plain $ \inh0 st0 ->
+ unPlain (p <. p1) a inh0 st0
+ fillOrBreak m p = Plain $ \a inh0 st0 ->
let maxCol = plainState_bufferStart st0 + plainState_bufferWidth st0 + m in
- let p1 = Plain $ \inh1 st1 ->
+ let p1 = Plain $ \() inh1 st1 ->
let col = plainState_bufferStart st1 + plainState_bufferWidth st1 in
unPlain
(case col`compare`maxCol of
LT -> spaces (maxCol`minusNatural`col)
- EQ -> mempty
+ EQ -> empty
GT -> incrIndent (spaces m) m newline
- ) inh1 st1
+ ) () 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 =
+ unPlain (p <. p1) a inh0 st0
+instance (Convertible Char o, Convertible String o, Outputable o) => Listable (Plain o) where
+ ul is =
catV $
- (<$> ds) $ \d ->
- from (Word '-')<>space<>flushlinePlain<>align d{-<>flushlinePlain-}
- ol ds =
- catV $ snd $
+ (<$> is) $ \i ->
+ wordPlain (Word '-').>space.>flushlinePlain
+ .> align i
+ -- .> flushlinePlain
+ ol is =
+ catV $ Tuple.snd $
Fold.foldr
- (\d (i, acc) ->
- (pred i, (from i<>from (Word '.')<>space<>flushlinePlain<>align d{-<>flushlinePlain-}) : acc)
- ) (Fold.length ds, []) ds
-instance Spaceable d => Justifiable (Plain d) where
- justify p = (\x -> flushlinePlain <> x <> flushlinePlain) $ Plain $ \inh ->
- unPlain p inh{plainInh_justify=True}
-
--- | Commit 'plainState_buffer' upto there, so that it won't be justified.
-flushlinePlain :: Spaceable d => Plain d
-flushlinePlain = Plain $ \_inh st k ->
- k( (joinLinePlainChunk (collapsePlainChunkSpaces <$> List.reverse (plainState_buffer st)) <>)
- , st
- { plainState_bufferStart = plainState_bufferStart st + plainState_bufferWidth st
- , plainState_bufferWidth = 0
- , plainState_buffer = mempty
- }
- )
-
-collapsePlainChunkSpaces :: PlainChunk d -> PlainChunk d
-collapsePlainChunkSpaces = \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}
- breakpoint = Plain $ \inh st k fits overflow ->
- k(id, st {plainState_breakIndent = plainInh_indent inh})
+ (\o (n, acc) ->
+ ( pred n
+ , ( wordPlain (Word (show n))
+ .> wordPlain (Word '.') .> space
+ .> flushlinePlain
+ .> align o
+ -- .> flushlinePlain
+ ) : acc
+ )
+ ) (Fold.length is, []) is
+ unorderedList li = intercalate_ newline $
+ wordPlain (Word '-') .> space .> flushlinePlain .> align li
+ orderedList li = Plain $ \as ->
+ unPlain (intercalate_ newline item)
+ (List.zip [1..] as)
+ where
+ item = Plain $ \(i::Natural, a) ->
+ ($ a) $ unPlain $
+ void i natural
+ .> wordPlain (Word '.') .> space
+ .> flushlinePlain
+ .> align li
+ intercalate_ sep li = Plain $ \as ->
+ unPlain (concat (List.intersperse sep ((`void` li) <$> as))) ()
+ list_ opn sep cls li =
+ breakalt
+ (opn .> intercalate_ (sep .> space) li <. cls)
+ (align $ opn .> space
+ .> intercalate_ (newline .> sep .> space) li
+ <. newline <. cls)
+instance Outputable o => Justifiable (Plain o) where
+ justify p = (\x -> flushlinePlain .> x <. flushlinePlain) $ Plain $ \a inh ->
+ unPlain p a inh{plainInh_justify=True}
+instance Outputable o => Wrappable (Plain o) where
+ setWidth w p = Plain $ \a inh ->
+ unPlain p a inh{plainInh_width=w}
+ breakpoint = Plain $ \() inh st k fits overflow ->
+ k(id, st{plainState_breakIndent = plainInh_indent inh})
fits
- {-overflow-}(\_r -> unPlain newlineJustifyingPlain inh st k fits overflow)
- breakspace = Plain $ \inh st k fits overflow ->
- k( if plainInh_justify inh then id else (space <>)
+ {-overflow-}(\_r -> unPlain newlineJustifyingPlain () inh st k fits overflow)
+ breakspace = Plain $ \() inh st k fits overflow ->
+ k( if plainInh_justify inh then id else (char ' ' <>)
, st
{ plainState_buffer =
if plainInh_justify inh
}
)
fits
- {-overflow-}(\_r -> unPlain newlineJustifyingPlain inh st k fits overflow)
- breakalt x y = Plain $ \inh st k fits overflow ->
+ {-overflow-}(\_r -> unPlain newlineJustifyingPlain () inh st k fits overflow)
+ breakalt x y = Plain $ \a inh st k fits overflow ->
-- NOTE: breakalt must be y if and only if x does not fit,
-- hence the use of dummyK to limit the test
-- to overflows raised within x, and drop those raised after x.
- unPlain x inh st dummyK
- {-fits-} (\_r -> unPlain x inh st k fits overflow)
- {-overflow-}(\_r -> unPlain y inh st k fits overflow)
+ unPlain x a inh st dummyK
+ {-fits-} (\_r -> unPlain x a inh st k fits overflow)
+ {-overflow-}(\_r -> unPlain y a inh st k fits overflow)
where
dummyK (px,_sx) fits _overflow =
-- NOTE: if px fits, then appending mempty fits
fits (px mempty)
- endline = Plain $ \inh st k fits _overflow ->
+ endline = Plain $ \() inh st k fits _overflow ->
let col = plainState_bufferStart st + plainState_bufferWidth st in
case plainInh_width inh >>= (`minusNaturalMaybe` col) of
Nothing -> k (id, st) fits fits
k (id,newState) fits fits
-- | Like 'newline', but justify 'plainState_buffer' before.
-newlineJustifyingPlain :: Spaceable d => Plain d
-newlineJustifyingPlain = Plain $ \inh st ->
+newlineJustifyingPlain :: Outputable o => Plain o ()
+newlineJustifyingPlain = Plain $ \() inh st ->
unPlain
( newlinePlain
- <> indentPlain
- <> propagatePlain (plainState_breakIndent st)
- <> flushlinePlain
- ) inh st
+ .> indentPlain
+ .> propagatePlain (plainState_breakIndent st)
+ <. flushlinePlain
+ ) () inh st
where
- indentPlain = Plain $ \inh ->
+ indentPlain = Plain $ \a inh ->
unPlain
- (plainInh_indenting inh)
+ (plainInh_indenting inh) a
inh{plainInh_justify=False}
- newlinePlain = Plain $ \inh st k ->
+ newlinePlain = Plain $ \() inh st k ->
k (\next ->
(if plainInh_justify inh
then justifyLinePlain inh st
else mempty
- )<>newline<>next
+ )<>nl<>next
, st
{ plainState_bufferStart = 0
, plainState_bufferWidth = 0
, plainState_buffer = mempty
})
- propagatePlain breakIndent = Plain $ \inh st1 k fits overflow ->
+ propagatePlain breakIndent = Plain $ \() inh st1 k fits overflow ->
k (id,st1)
fits
{-overflow-}(
else fits
)
--- String
-instance (From (Word String) d, Spaceable d) =>
- From String (Plain d) where
- from =
- mconcat .
- List.intersperse newline .
- (from <$>) .
- lines
-instance (From (Word String) d, Spaceable d) =>
- IsString (Plain d) where
- fromString = from
--- Text
-instance (From (Word Text) d, Spaceable d) =>
- From Text (Plain d) where
- from =
- mconcat .
- List.intersperse newline .
- (from <$>) .
- lines
-instance (From (Word TL.Text) d, Spaceable d) =>
- From TL.Text (Plain d) where
- from =
- mconcat .
- List.intersperse newline .
- (from <$>) .
- lines
--- Char
-instance (From (Word Char) d, Spaceable d) =>
- From Char (Plain d) where
- from ' ' = breakspace
- from '\n' = newline
- from c = from (Word c)
-
-instance (From [SGR] d, Semigroup d) => From [SGR] (Plain d) where
- from sgr = Plain $ \inh st k ->
- if plainInh_justify inh
- then k (id, st {plainState_buffer = PlainChunk_Ignored (from sgr) : plainState_buffer st})
- else k ((from sgr <>), st)
-
-- * Justifying
justifyLinePlain ::
- Spaceable d =>
- PlainInh d -> PlainState d -> d
+ Outputable o =>
+ PlainInh o -> PlainState o -> o
justifyLinePlain inh PlainState{..} =
case plainInh_width inh of
Nothing -> joinLinePlainChunk $ List.reverse plainState_buffer
plainState_bufferWidth`minusNatural`superfluousSpaces in
let justifyWidth =
-- NOTE: when minBufferWidth is not breakable,
- -- the width of justification can be wider than
+ -- the length of justification can be wider than
-- what remains to reach maxWidth.
max minBufferWidth $
maxWidth`minusNatural`plainState_bufferStart
-- | @('countWordsPlain' ps)@ returns the number of words in @(ps)@
-- clearly separated by spaces.
-countWordsPlain :: [PlainChunk d] -> Natural
+countWordsPlain :: [PlainChunk o] -> Natural
countWordsPlain = go False 0
where
go inWord acc = \case
go rr bmr = q:(q+1) : go (rr`minusNatural`1) (bmr`minusNatural`1)
padLinePlainChunkInits ::
- Spaceable d =>
- Width -> (Natural, Natural, [PlainChunk d]) -> Line d
+ Outputable o =>
+ Width -> (Natural, Natural, [PlainChunk o]) -> Line o
padLinePlainChunkInits maxWidth (lineWidth,wordCount,line) = Line $
if maxWidth <= lineWidth
-- The gathered line reached or overreached the maxWidth,
-- between the words of the line.
padLinePlainChunk line $ justifyPadding (maxWidth-lineWidth) (wordCount-1)
--- | Just concat 'PlainChunk's with no justification.
-joinLinePlainChunk :: Monoid d => Spaceable d => [PlainChunk d] -> d
-joinLinePlainChunk = mconcat . (runPlainChunk <$>)
-
-- | Interleave 'PlainChunk's with 'Width's from 'justifyPadding'.
-padLinePlainChunk :: Spaceable d => [PlainChunk d] -> [Width] -> d
+padLinePlainChunk :: Outputable o => [PlainChunk o] -> [Width] -> o
padLinePlainChunk = go
where
go (w:ws) lls@(l:ls) =
case w of
- PlainChunk_Spaces _s -> spaces (fromIntegral (l+1)) <> go ws ls
- _ -> runPlainChunk w <> go ws lls
+ PlainChunk_Spaces _s -> repeatedChar (fromIntegral (l+1)) ' ' <> go ws ls
+ _ -> runPlainChunk w <> go ws lls
go (w:ws) [] = runPlainChunk w <> go ws []
go [] _ls = mempty
--- * Escaping
-instance (Semigroup d, From [SGR] d) => Colorable16 (Plain d) where
+
+sgrPlain :: Outputable o => [SGR] -> Plain o ()
+sgrPlain sgr = Plain $ \() inh st k ->
+ if plainInh_justify inh
+ then k (id, st {plainState_buffer =
+ PlainChunk_Ignored (fromString (setSGRCode sgr)) :
+ plainState_buffer st
+ })
+ else k ((fromString (setSGRCode sgr) <>), st)
+
+instance Outputable o => Colorable16 (Plain o) where
reverse = plainSGR $ SetSwapForegroundBackground True
black = plainSGR $ SetColor Foreground Dull Black
red = plainSGR $ SetColor Foreground Dull Red
onMagentaer = plainSGR $ SetColor Background Vivid Magenta
onCyaner = plainSGR $ SetColor Background Vivid Cyan
onWhiter = plainSGR $ SetColor Background Vivid White
-instance (Semigroup d, From [SGR] d) => Decorable (Plain d) where
+instance Outputable o => Decorable (Plain o) where
bold = plainSGR $ SetConsoleIntensity BoldIntensity
underline = plainSGR $ SetUnderlining SingleUnderline
italic = plainSGR $ SetItalicized True
-plainSGR ::
- Semigroup d =>
- From [SGR] d =>
- SGR -> Plain d -> Plain d
-plainSGR newSGR p = before <> middle <> after
+plainSGR :: Outputable o => SGR -> Plain o a -> Plain o a
+plainSGR newSGR p = before .> middle <. after
where
- before = Plain $ \inh st k ->
- let d = from [newSGR] in
+ before = Plain $ \() inh st k ->
+ let o = fromString $ setSGRCode [newSGR] in
if plainInh_justify inh
then k (id, st
{ plainState_buffer =
- PlainChunk_Ignored d :
+ PlainChunk_Ignored o :
plainState_buffer st
})
- else k ((d <>), st)
- middle = Plain $ \inh ->
- unPlain p inh{plainInh_sgr=newSGR:plainInh_sgr inh}
- after = Plain $ \inh st k ->
- let d = from $ Reset : List.reverse (plainInh_sgr inh) in
+ else k ((o <>), st)
+ middle = Plain $ \a inh ->
+ unPlain p a inh{plainInh_sgr=newSGR:plainInh_sgr inh}
+ after = Plain $ \() inh st k ->
+ let o = fromString $ setSGRCode $ Reset : List.reverse (plainInh_sgr inh) in
if plainInh_justify inh
then k (id, st
{ plainState_buffer =
- PlainChunk_Ignored d :
+ PlainChunk_Ignored o :
plainState_buffer st
})
- else k ((d <>), st)
+ else k ((o <>), st)
-- PVP: +-+------- breaking API changes
-- | | +----- non-breaking API additions
-- | | | +--- code changes with no API change
-version: 1.6.0.20211008
+version: 2.0.0.20211020
stability: experimental
category: Text
synopsis: Symantics combinators for generating documents.
exposed-modules:
Symantic.Document
Symantic.Document.Class
+ Symantic.Document.Debug
+ Symantic.Document.Output
Symantic.Document.Plain
default-language: Haskell2010
default-extensions:
import Data.Functor ((<$>))
import Data.Int (Int)
import Data.Maybe (Maybe(..))
-import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
-import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Prelude ((+))
import Text.Show (Show(..))
import qualified Data.List as List
-import Symantic.Document.Lang
-import Symantic.Document.Plain
+import Symantic.Document.Class
+import Symantic.Document.Plain (Plain, runPlain)
-- * Tests
hunits :: TestTree
hunitPlain :: TestTree
hunitPlain = testList "Plain"
[ newline ==> "\n"
+ , "hello".>"world" ==> "helloworld"
+ , "hello".>newline.>"world" ==> "hello\nworld"
, "hello\nworld" ==> "hello\nworld"
, 10`maxWidth` breakpoints ["hello", "world"] ==> "helloworld"
- , 9`maxWidth` breakpoints ["hello", "world"] ==> "hello\nworld"
+ , 9`maxWidth` "hello" .> breakpoint .> "world" ==> "hello\nworld"
, 6`maxWidth` breakpoints ["he", "ll", "o!"] ==> "hello!"
, 6`maxWidth` breakpoints ["he", "ll", "o!", "wo", "rl", "d!"] ==> "hello!\nworld!"
, 5`maxWidth` breakpoints ["hello", "world"] ==> "hello\nworld"
, 3`maxWidth` breakpoints ["he", "ll"] ==> "he\nll"
, 3`maxWidth` breakpoints ["he", "ll", "o!"] ==> "he\nll\no!"
, 1`maxWidth` breakpoints ["he", "ll", "o!"] ==> "he\nll\no!"
- , 4`maxWidth` mconcat ["__", align $ breakpoints ["he", "ll", "o!", "wo", "rl", "d!"]]
+ , 4`maxWidth` concat ["__", align $ breakpoints ["he", "ll", "o!", "wo", "rl", "d!"]]
==> "__he\n ll\n o!\n wo\n rl\n d!"
- , 6`maxWidth` mconcat ["__", align $ breakpoints ["he", "ll", "o!", "wo", "rl", "d!"]]
+ , testPlain
+ (4`maxWidth` "__" .> align (intercalate_ breakpoint string))
+ ["he", "ll", "o!", "wo", "rl", "d!"]
+ "__he\n ll\n o!\n wo\n rl\n d!"
+ , 6`maxWidth` concat ["__", align $ breakpoints ["he", "ll", "o!", "wo", "rl", "d!"]]
==> "__hell\n o!wo\n rld!"
- , 16`maxWidth` mconcat ["__", listHorV ["hello", "world"]] ==> "__[hello, world]"
- , 4`maxWidth` mconcat ["__", listHorV ["hello", "world"]] ==> "__[ hello\n , world\n ]"
+ , testPlain
+ (6`maxWidth` "__" .> align (intercalate_ breakpoint string))
+ ["he", "ll", "o!", "wo", "rl", "d!"]
+ "__hell\n o!wo\n rld!"
+ , 16`maxWidth` concat ["__", listHorV ["hello", "world"]] ==> "__[hello, world]"
+ , testPlain
+ (16`maxWidth` "__" .> bracketList string)
+ ["hello", "world"]
+ "__[hello, world]"
+ , 4`maxWidth` concat ["__", listHorV ["hello", "world"]] ==> "__[ hello\n , world\n ]"
, 11`maxWidth` breakspaces ["hello", "world"] ==> "hello world"
, 10`maxWidth` breakspaces ["hello", "world"] ==> "hello\nworld"
, 6`maxWidth` breakspaces ["hel", "lo", "wo", "rld"] ==> "hel lo\nwo rld"
==> "function(function(\n function(\n function(\n function(\n [ abcdefg\n , abcdefg\n ]\n )\n )\n )\n ))"
, 19`maxWidth` fun (fun $ fun $ fun $ fun $ listHorV ["abcdefgh", "abcdefgh"])
==> "function(\n function(\n function(\n function(\n function(\n [ abcdefgh\n , abcdefgh\n ]\n )\n )\n )\n )\n )"
- , 7`maxWidth` ("hello"<>breakspace<>"world") ==> "hello\nworld"
- , 7`maxWidth` ("hello "<>"world") ==> "hello\nworld"
- , " "<> "hello\nworld\n!" ==> " hello\nworld\n!"
- , "__"<>align "hello\nworld\n!" ==> "__hello\n world\n !"
+ , 7`maxWidth` ("hello".>breakspace.>"world") ==> "hello\nworld"
+ , 7`maxWidth` ("hello ".>"world") ==> "hello\nworld"
+ , " ".> "hello\nworld\n!" ==> " hello\nworld\n!"
+ , "__".>align "hello\nworld\n!" ==> "__hello\n world\n !"
, hang 2 "hello\nworld\n!" ==> "hello\n world\n !"
- , hang 2 "hello\nworld\n!"<>"\nhello\n!" ==> "hello\n world\n !\nhello\n!"
- , "let " <> align (catV $
- (\(name, typ) -> fill 6 name <+> "::" <+> typ)
+ , hang 2 "hello\nworld\n!".>"\nhello\n!" ==> "hello\n world\n !\nhello\n!"
+ , "let " .> align (catV $
+ (\(name, typ) -> fill 6 name <+ "::" +> typ)
<$> [ ("abcdef","Doc")
, ("abcde","Int -> Doc -> Doc")
, ("abcdefghi","Doc") ])
==> "let abcdef :: Doc\n abcde :: Int -> Doc -> Doc\n abcdefghi :: Doc"
- , "let " <> align (catV $
- (\(name, typ) -> fillOrBreak 6 name <> " ::" <+> typ)
+ , "let " .> align (catV $
+ (\(name, typ) -> fillOrBreak 6 name <. " ::" +> typ)
<$> [ ("abcdef","Doc")
, ("abcde","Int -> Doc -> Doc")
, ("abcdefghi","Doc") ])
==> "let abcdef :: Doc\n abcde :: Int -> Doc -> Doc\n abcdefghi\n :: Doc"
- , "let " <> align (catV $
- (\(name, typ) -> fillOrBreak 6 name <> " ::" <+> typ)
+ , "let " .> align (catV $
+ (\(name, typ) -> fillOrBreak 6 name <. " ::" +> typ)
<$> [("abcdefghi","Doc ->\nDoc")])
==> "let abcdefghi\n :: Doc ->\n Doc"
- , "let " <> align (catV $
- (\(name, typ) -> fillOrBreak 6 name <> align (" ::" <+> typ))
+ , "let " .> align (catV $
+ (\(name, typ) -> fillOrBreak 6 name <. align (" ::" +> typ))
<$> [("abcdefghi","Doc ->\nDoc")])
==> "let abcdefghi\n :: Doc ->\n Doc"
, 10 `maxWidth` "1 2 3 4 5 6 7 8 9 10 11 12 13 14 15" ==> "1 2 3 4 5\n6 7 8 9 10\n11 12 13\n14 15"
- , 10 `maxWidth` "a b "<>"12"<>align (" 34 5") ==> "a b 12 34\n 5"
- , 10 `maxWidth` "a b "<>"12"<>align (" 34" <> align "") ==> "a b 12 34"
- , 10 `maxWidth` "a b "<>"12"<>align (" 34" <> align " ") ==> "a b 12 34 "
- , 10 `maxWidth` "a b "<>"12"<>align (" 34" <> align " 5") ==> "a b 12 34\n 5"
- , 10 `maxWidth` "a b "<>"12"<>align (" 34" <> align " 56") ==> "a b 12\n 34\n 56"
- , 10 `maxWidth` "a b "<>"12"<>align (" 34" <> align " 567") ==> "a b\n12 34 567"
- , 10 `maxWidth` "a b "<>"12"<>align (" 34" <> align " 5678") ==> "a b\n12 34 5678"
- , 10 `maxWidth` "a b "<>"12"<>align (" 34" <> align " 56789") ==> "a b\n12 34\n 56789"
- , 10 `maxWidth` ("1234567890" <> " ") <> "1" ==> "1234567890\n1"
+ , 10 `maxWidth` "a b ".>"12".>align (" 34 5") ==> "a b 12 34\n 5"
+ , 10 `maxWidth` "a b ".>"12".>align (" 34" .> align "") ==> "a b 12 34"
+ , 10 `maxWidth` "a b ".>"12".>align (" 34" .> align " ") ==> "a b 12 34 "
+ , 10 `maxWidth` "a b ".>"12".>align (" 34" .> align " 5") ==> "a b 12 34\n 5"
+ , 10 `maxWidth` "a b ".>"12".>align (" 34" .> align " 56") ==> "a b 12\n 34\n 56"
+ , 10 `maxWidth` "a b ".>"12".>align (" 34" .> align " 567") ==> "a b\n12 34 567"
+ , 10 `maxWidth` "a b ".>"12".>align (" 34" .> align " 5678") ==> "a b\n12 34 5678"
+ , 10 `maxWidth` "a b ".>"12".>align (" 34" .> align " 56789") ==> "a b\n12 34\n 56789"
+ , 10 `maxWidth` ("1234567890" .> " ") .> "1" ==> "1234567890\n1"
, 10 `maxWidth` nestedAlign 6 ==> "1 2 3 4 5\n 6"
, 10 `maxWidth` nestedAlign 7 ==> "1 2 3 4\n 5\n 6\n 7"
, 10 `maxWidth` nestedAlign 8 ==> "1 2 3\n 4\n 5\n 6\n 7\n 8"
, 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"
+ , 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` "__" <> align (justify "1 2 3 4 5") ==> "__1 2 3 4\n 5"
+ , 10 `maxWidth` "__" .> align (justify "1 2 3 4 5") ==> "__1 2 3 4\n 5"
-- justify does not overflow the alignment
, 10 `maxWidth` justify (nestedAlign 6) ==> "1 2 3 4 5\n 6"
- , 10 `maxWidth` justify ("a b c de " <> nestedAlign 2) ==> "a b c de\n1 2"
- , 10 `maxWidth` justify (bold ("12 34 56 78 "<> underline "90" <> " 123 456 789"))
+ , 10 `maxWidth` justify ("a b c de " .> nestedAlign 2) ==> "a b c de\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"
-- justify does not justify on explicit newlines
, 10 `maxWidth` justify "1 2 3 4 5 6 7\n8 9 1 2 3 4 5" ==> "1 2 3 4 5\n6 7\n8 9 1 2 3\n4 5"
==> "- 1 2 3 4\n\
\ 5 6 7 8\n\
\ 9"
- -- ul/ol is mempty when no item
+ -- ul/ol is empty when no item
, ul [] ==> ""
, ol [] ==> ""
-- ul flushes the buffer
\- 1 2 3 4\n\
\ 5 6 7 8\n\
\ 9"
+ , testPlain (10 `maxWidth` justify (unorderedList (unwords_ int))) (let i = [1..9] in [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"
+ , testPlain (11 `maxWidth` justify (orderedList (unwords_ int))) (let i = [1..9] in [i, i])
+ "1. 1 2 3 4\n\
+ \ 5 6 7 8\n\
+ \ 9\n\
+ \2. 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\
\ 7 8\n\
\ 9"
-- endline breakspaces
- , 10 `maxWidth` ("a"<>endline<>" b") ==> "a\nb"
+ , 10 `maxWidth` ("a".>endline.>" b") ==> "a\nb"
-- endline does no justify
- , 10 `maxWidth` justify ("a b"<>endline<>" c") ==> "a b\nc"
+ , 10 `maxWidth` justify ("a b".>endline.>" c") ==> "a b\nc"
-- endline works overflowed
- , 10 `maxWidth` justify ("abcdefghijk"<>endline<>" a") ==> "abcdefghijk\na"
+ , 10 `maxWidth` justify ("abcdefghijk".>endline.>" a") ==> "abcdefghijk\na"
-- endline prints no nothing
- , 10 `maxWidth` justify ("12345678"<>endline<>"90ab"<>align (" cdefghijk cdefghijk"))
+ , 10 `maxWidth` justify ("12345678".>endline.>"90ab".>align (" cdefghijk cdefghijk"))
==> "1234567890ab\n\
\ cdefghijk\n\
\ cdefghijk"
-- newline stops overflow
- , 10 `maxWidth` breakalt "fits" "over"<>"\n"<>"12345678901"
+ , 10 `maxWidth` breakalt "fits" "over".>"\n".>"12345678901"
==> "fits\n\
\12345678901"
-- breakalt triggers only if its first argument overflows,
-- not if what's next overflows.
- , 10 `maxWidth` spaces 2<>align(breakalt "fits" "over"<>newline<>"12345678901")
+ , 10 `maxWidth` spaces 2.>align(breakalt "fits" "over".>newline.>"12345678901")
==> " fits\n\
\ 12345678901"
-- handle escaping correctly over custom indenting
- , 10 `maxWidth` setIndent (blue "X") 1 (red ("12"<>green "4\n5" <> "6"))
+ , 10 `maxWidth` setIndent (blue "X") 1 (red ("12".>green "4\n5" .> "6"))
==> "\ESC[31m12\ESC[32m4\n\ESC[34mX\ESC[0;31;32m5\ESC[0;31m6\ESC[0m"
- , 10 `maxWidth` setIndent (blue "X") 1 (justify (red ("1 2 3 4"<>green " 5 6 " <> "7 ") <> "8"))
+ , 10 `maxWidth` setIndent (blue "X") 1 (justify (red ("1 2 3 4".>green " 5 6 " .> "7 ") .> "8"))
==> "\ESC[31m1 2 3 4\ESC[32m 5\n\ESC[34mX\ESC[0;31;32m6 \ESC[0;31m7 \ESC[0m8"
-- breakspace backtracking is bounded by the removable indentation
-- (hence it can actually wrap a few words in reasonable time).
\dolor sit amet, consectetur adipiscing elit. Donec libero risus, commodo vitae,\n\
\pharetra mollis, posuere eu, pede. Nulla nec tortor. Donec id elit quis purus\n\
\consectetur consequat. Nam congue semper tellus. Sed erat dolor, dapibus sit\n\
- \amet, venenatis ornare, ultrices ut, nisi."
+ \amet, venenatis ornare, ultrices ut, nisi."
]
- where
- (==>) :: IsString d => d ~ String => Plain d -> d -> Assertion; infix 0 ==>
- p ==> exp = got @?= exp
- where got = runPlain p
+ where
+ (==>) :: IsString o => o ~ String => Plain o () -> o -> Assertion; infix 0 ==>
+ fmt ==> exp = got @?= exp
+ where got = runPlain fmt ()
+ testPlain :: IsString o => o ~ String => Plain o a -> a -> o -> Assertion
+ testPlain fmt a exp = got @?= exp
+ where got = runPlain fmt a
testList :: String -> [Assertion] -> TestTree
testList n as = testGroup n $ List.zipWith testCase (show <$> [1::Int ..]) as
-breakpoints :: Wrappable d => Monoid d => [d] -> d
+breakpoints ::
+ Emptyable repr =>
+ ProductFunctor repr =>
+ Wrappable repr =>
+ [repr ()] -> repr ()
breakpoints = intercalate breakpoint
-breakspaces :: Wrappable d => Monoid d => [d] -> d
+breakspaces ::
+ Emptyable repr =>
+ ProductFunctor repr =>
+ Wrappable repr =>
+ [repr ()] -> repr ()
breakspaces = intercalate breakspace
infix 1 `maxWidth`
-maxWidth :: Wrappable d => Width -> d -> d
+maxWidth :: Wrappable repr => Width -> repr a -> repr a
maxWidth = setWidth . Just
nestedAlign ::
- From (Line String) d =>
- Spaceable d => Indentable d => Wrappable d =>
- Int -> d
+ IsString (repr ()) =>
+ Indentable repr =>
+ Emptyable repr =>
+ ProductFunctor repr =>
+ Wrappable repr =>
+ Int -> repr ()
nestedAlign n = go 1
- where
- go i =
- from (Line (show i)) <>
- (if n <= i then mempty
- else align (breakspace <> go (i+1)))
+ where
+ go i =
+ fromString (show i) .>
+ (if n <= i then empty
+ else align (breakspace .> go (i+1)))
-listHorV :: IsString d => Indentable d => Wrappable d => [d] -> d
+listHorV ::
+ IsString (repr ()) =>
+ Emptyable repr =>
+ Wrappable repr =>
+ ProductFunctor repr =>
+ Indentable repr =>
+ Newlineable repr =>
+ [repr ()] -> repr ()
listHorV [] = "[]"
-listHorV [d] = "["<>d<>"]"
-listHorV ds =
- breakalt
- ("[" <> intercalate ("," <> space) ds <> "]")
- (align $ "[" <> space
- <> foldr1 (\a acc -> a <> newline <> "," <> space <> acc) ds
- <> newline <> "]")
-
-fun :: IsString d => Indentable d => Wrappable d => d -> d
-fun d = "function(" <> incrIndent (spaces 2) 2 (breakalt d (newline<>d<>newline)) <> ")"
+listHorV [t] = "[".>t<."]"
+listHorV ts =
+ breakalt
+ ("[" .> intercalate ("," .> space) ts <. "]")
+ (align $ "[" .> space
+ .> foldr1 (\a acc -> a <. newline <. "," <. space <. acc) ts
+ <. newline <. "]")
+fun ::
+ Wrappable repr =>
+ ProductFunctor repr =>
+ Indentable repr =>
+ Newlineable repr =>
+ IsString (repr ()) =>
+ repr a -> repr a
+fun t = "function("
+ .> incrIndent (spaces 2) 2 (breakalt t (newline.>t<.newline))
+ <. ")"
main :: IO ()
main = do
- defaultMain $
- testGroup "Document"
- [ hunits
- ]
+ defaultMain $
+ testGroup "Document"
+ [ hunits
+ ]
sourcephile / git / haskell / symantic-document.git / commitdiff