From b65dfeb171c6b994737ada9cc7849bd48bf1ce1f Mon Sep 17 00:00:00 2001
From: Julien Moutinho <julm@sourcephile.fr>
Date: Thu, 7 Oct 2021 15:50:30 +0200
Subject: [PATCH] impl: cleanup
---
.hlint.yaml | 24 +
HLint.hs | 19 -
Makefile | 55 ++-
src/HLint.hs | 1 -
src/Symantic/Document/HLint.hs | 1 -
src/Symantic/Document/Lang.hs | 722 ++++++++++++++--------------
src/Symantic/Document/Plain.hs | 832 ++++++++++++++++-----------------
src/Symantic/HLint.hs | 1 -
tests/HLint.hs | 1 -
9 files changed, 839 insertions(+), 817 deletions(-)
create mode 100644 .hlint.yaml
delete mode 100644 HLint.hs
delete mode 120000 src/HLint.hs
delete mode 120000 src/Symantic/Document/HLint.hs
delete mode 120000 src/Symantic/HLint.hs
delete mode 120000 tests/HLint.hs
diff --git a/.hlint.yaml b/.hlint.yaml
new file mode 100644
index 0000000..4b76cdf
--- /dev/null
+++ b/.hlint.yaml
@@ -0,0 +1,24 @@
+- extensions:
+ - name: Haskell2010
+ - name: NoCPP
+ - name: TypeApplications
+
+- ignore: {name: Move brackets to avoid $}
+- ignore: {name: Reduce duplication}
+- ignore: {name: Redundant $}
+- ignore: {name: Redundant bracket}
+- ignore: {name: Redundant do}
+- ignore: {name: Redundant lambda}
+- ignore: {name: Use camelCase}
+- ignore: {name: Use const}
+- ignore: {name: Use fmap}
+- ignore: {name: Use if}
+- ignore: {name: Use import/export shortcut}
+- ignore: {name: Use list literal pattern}
+- ignore: {name: Use list literal}
+
+# BEGIN: generated hints
+- fixity: "infix 1 `maxWidth`"
+- fixity: "infixr 6 <+>"
+- fixity: "infixr 6 </>"
+# END: generated hints
diff --git a/HLint.hs b/HLint.hs
deleted file mode 100644
index a86561a..0000000
--- a/HLint.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-import "hint" HLint.HLint
-ignore "Move brackets to avoid $"
-ignore "Reduce duplication"
-ignore "Redundant $"
-ignore "Redundant bracket"
-ignore "Redundant do"
-ignore "Use camelCase"
-ignore "Use const"
-ignore "Use fmap"
-ignore "Use if"
-ignore "Use import/export shortcut"
-ignore "Use list literal pattern"
-ignore "Use list literal"
-
--- BEGIN: generated hints
-infix 1 `maxWidth`
-infixr 6 </>
-infixr 6 <+>
--- END: generated hints
diff --git a/Makefile b/Makefile
index adcc70b..1f9a76b 100644
--- a/Makefile
+++ b/Makefile
@@ -1,36 +1,37 @@
-override RTS_OPTIONS += -L100
-override TEST_OPTIONS += --color always $(addprefix -p ,$t)
-override GHC_PROF_OPTIONS += -fprof-auto -fprof-auto-calls
+override GHCID_OPTIONS += --no-height-limit --reverse-errors
override REPL_OPTIONS += -ignore-dot-ghci
cabal := $(wildcard *.cabal)
package := $(notdir ./$(cabal:.cabal=))
version := $(shell sed -ne 's/^version: *\(.*\)/\1/p' $(cabal))
project := $(patsubst %.cabal,%,$(cabal))
+cabal_builddir ?= dist-newstyle
all: build
build:
- cabal build
+ cabal build $(CABAL_BUILD_FLAGS)
clean c:
cabal clean
repl:
- cabal repl $(project)
+ cabal repl $(CABAL_REPL_FLAGS) $(project)
ghcid:
- ghcid -c 'cabal repl $(project) --repl-options "$(REPL_OPTIONS)"' --reverse-errors
+ ghcid $(GHCID_OPTIONS) --command 'cabal repl -fno-code $(CABAL_REPL_FLAGS) $(project) $(addprefix --repl-options ,$(REPL_OPTIONS))'
.PHONY: tests
t tests:
cabal test $(CABAL_TEST_FLAGS) \
--test-show-details always --test-options "$(TEST_OPTIONS)"
-tests/prof-time: $(project)-tests.eventlog.json
-tests/prof-heap: $(project)-tests.eventlog.html
-.PHONY: $(project)-tests.eventlog
-$(project)-tests.eventlog $(project)-tests.prof:
+tests/prof-time: $(project)-test.eventlog.json
+tests/prof-heap: $(project)-test.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 $(GHC_PROF_OPTIONS) || true
-tests/repl:
- cabal repl --enable-tests $(project)-tests
+ --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
+t/ghcid tests/ghcid:
+ ghcid $(GHCID_OPTIONS) --command 'cabal repl $(CABAL_REPL_FLAGS) $(CABAL_TEST_FLAGS) $(project):tests' --test ":main $(TEST_OPTIONS)"
%/accept: TEST_OPTIONS += --accept
%/accept: %
@@ -38,6 +39,12 @@ tests/repl:
%/cover: CABAL_TEST_FLAGS += --enable-coverage
%/cover: %
+%.eventlog.html: RTS_OPTIONS += -hy -l-au
+%.eventlog.html: %.eventlog
+ eventlog2html $<
+%.eventlog.json: RTS_OPTIONS += -p -l-au
+%.eventlog.json: %.eventlog
+ hs-speedscope $<
doc:
cabal haddock --haddock-css ocean --haddock-hyperlink-source
@@ -47,12 +54,15 @@ tag:
git tag -f -s -m "$(package) v$(version)" $(package)-$(version)
tar:
+ git diff --exit-code
+ reuse lint
cabal sdist
cabal haddock --haddock-for-hackage --enable-doc
upload: LANG=C
-upload: tar
- cabal upload $(CABAL_UPLOAD_FLAGS) dist-newstyle/sdist/$(package)-$(version).tar.gz
- cabal upload $(CABAL_UPLOAD_FLAGS) --documentation dist-newstyle/$(package)-$(version)-docs.tar.gz
+upload: tar tag
+ git push --follow-tags $(GIT_PUSH_FLAGS)
+ cabal upload $(CABAL_UPLOAD_FLAGS) "$(cabal_builddir)"/sdist/$(package)-$(version).tar.gz
+ cabal upload $(CABAL_UPLOAD_FLAGS) --documentation "$(cabal_builddir)"/$(package)-$(version)-docs.tar.gz
%/publish: CABAL_UPLOAD_FLAGS+=--publish
%/publish: %
@@ -63,6 +73,17 @@ nix-build:
nix-relock:
nix flake update --recreate-lock-file
nix-repl:
- nix -L develop --command cabal 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' $@
+ echo >>$@ '# BEGIN: generated hints'
+ hlint --find . | grep -- '- fixity:' | sort -u >>$@
+ echo >>$@ '# END: generated hints'
+lint: .hlint.yaml
+ if hlint --quiet --report=hlint.html -XNoCPP $(HLINT_FLAGS) .; \
+ then rm -f hlint.html; \
+ else sensible-browser ./hlint.html & fi
diff --git a/src/HLint.hs b/src/HLint.hs
deleted file mode 120000
index ab18269..0000000
--- a/src/HLint.hs
+++ /dev/null
@@ -1 +0,0 @@
-../HLint.hs
\ No newline at end of file
diff --git a/src/Symantic/Document/HLint.hs b/src/Symantic/Document/HLint.hs
deleted file mode 120000
index ab18269..0000000
--- a/src/Symantic/Document/HLint.hs
+++ /dev/null
@@ -1 +0,0 @@
-../HLint.hs
\ No newline at end of file
diff --git a/src/Symantic/Document/Lang.hs b/src/Symantic/Document/Lang.hs
index 4a5051d..ebf5425 100644
--- a/src/Symantic/Document/Lang.hs
+++ b/src/Symantic/Document/Lang.hs
@@ -46,161 +46,161 @@ newtype Word d = Word d
unWord :: Word d -> d
unWord (Word d) = d
instance From [SGR] d => From [SGR] (Word d) where
- from = Word . from
+ from = Word . from
-- * Class 'From'
class From a d where
- from :: a -> d
- default from :: From String d => Show a => a -> d
- from = from . show
+ from :: a -> d
+ default from :: From String d => Show a => a -> d
+ from = from . show
instance From (Line String) d => From Int d where
- from = from . Line . show
+ from = from . Line . show
instance From (Line String) d => From Integer d where
- from = from . Line . show
+ from = from . Line . show
instance From (Line String) d => From Natural d where
- from = from . Line . show
+ from = from . Line . show
-- String
instance From Char String where
- from = pure
+ from = pure
instance From String String where
- from = id
+ from = id
instance From Text String where
- from = Text.unpack
+ from = Text.unpack
instance From TL.Text String where
- from = TL.unpack
+ from = TL.unpack
instance From d String => From (Line d) String where
- from = from . unLine
+ from = from . unLine
instance From d String => From (Word d) String where
- from = from . unWord
+ from = from . unWord
instance From [SGR] String where
- from = ANSI.setSGRCode
+ from = ANSI.setSGRCode
-- Text
instance From Char Text where
- from = Text.singleton
+ from = Text.singleton
instance From String Text where
- from = Text.pack
+ from = Text.pack
instance From Text Text where
- from = id
+ from = id
instance From TL.Text Text where
- from = TL.toStrict
+ from = TL.toStrict
instance From d Text => From (Line d) Text where
- from = from . unLine
+ from = from . unLine
instance From d Text => From (Word d) Text where
- from = from . unWord
+ from = from . unWord
instance From [SGR] Text where
- from = from . ANSI.setSGRCode
+ from = from . ANSI.setSGRCode
-- TL.Text
instance From Char TL.Text where
- from = TL.singleton
+ from = TL.singleton
instance From String TL.Text where
- from = TL.pack
+ from = TL.pack
instance From Text TL.Text where
- from = TL.fromStrict
+ from = TL.fromStrict
instance From TL.Text TL.Text where
- from = id
+ from = id
instance From d TL.Text => From (Line d) TL.Text where
- from = from . unLine
+ from = from . unLine
instance From d TL.Text => From (Word d) TL.Text where
- from = from . unWord
+ from = from . unWord
instance From [SGR] TL.Text where
- from = from . ANSI.setSGRCode
+ from = from . ANSI.setSGRCode
-- TLB.Builder
instance From Char TLB.Builder where
- from = TLB.singleton
+ from = TLB.singleton
instance From String TLB.Builder where
- from = fromString
+ from = fromString
instance From Text TLB.Builder where
- from = TLB.fromText
+ from = TLB.fromText
instance From TL.Text TLB.Builder where
- from = TLB.fromLazyText
+ from = TLB.fromLazyText
instance From TLB.Builder TLB.Builder where
- from = id
+ from = id
instance From d TLB.Builder => From (Line d) TLB.Builder where
- from = from . unLine
+ from = from . unLine
instance From d TLB.Builder => From (Word d) TLB.Builder where
- from = from . unWord
+ from = from . unWord
instance From [SGR] TLB.Builder where
- from = from . ANSI.setSGRCode
+ 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
+ width :: d -> Column
+ nullWidth :: d -> Bool
+ nullWidth d = width d == 0
instance Lengthable Char where
- width _ = 1
- nullWidth = const False
+ width _ = 1
+ nullWidth = const False
instance Lengthable String where
- width = fromIntegral . List.length
- nullWidth = Fold.null
+ width = fromIntegral . List.length
+ nullWidth = Fold.null
instance Lengthable Text.Text where
- width = fromIntegral . Text.length
- nullWidth = Text.null
+ width = fromIntegral . Text.length
+ nullWidth = Text.null
instance Lengthable TL.Text where
- width = fromIntegral . TL.length
- nullWidth = TL.null
+ width = fromIntegral . TL.length
+ nullWidth = TL.null
instance Lengthable d => Lengthable (Line d) where
- width = fromIntegral . width . unLine
- nullWidth = nullWidth . unLine
+ width = fromIntegral . width . unLine
+ nullWidth = nullWidth . unLine
instance Lengthable d => Lengthable (Word d) where
- width = fromIntegral . width . unWord
- nullWidth = nullWidth . unWord
+ 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
-
- -- | @'spaces' ind = 'replicate' ind 'space'@
- spaces :: Column -> d
- default spaces :: Monoid d => Column -> d
- 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 <$>)
- -- | @x '<+>' y = x '<>' 'space' '<>' y@
- (<+>) :: d -> d -> d
- -- | @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
- catV = intercalate newline
+ 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
+
+ -- | @'spaces' ind = 'replicate' ind 'space'@
+ spaces :: Column -> d
+ default spaces :: Monoid d => Column -> d
+ 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 <$>)
+ -- | @x '<+>' y = x '<>' 'space' '<>' y@
+ (<+>) :: d -> d -> d
+ -- | @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
+ catV = intercalate newline
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 TL.Text where
- newline = "\n"
- space = " "
- spaces n = TL.replicate (fromIntegral n) " "
+ newline = "\n"
+ space = " "
+ spaces n = TL.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
@@ -222,210 +222,210 @@ 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
+ 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
+ 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
+ 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
+ tail "" = Nothing
+ tail s = Just $ TL.tail s
+ break = TL.break
-- * 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
+ 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 'Colorable16'
class Colorable16 d where
- reverse :: d -> d
-
- -- 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
-
- -- 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
-
- -- 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
-
- -- 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
+ reverse :: d -> d
+
+ -- 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
+
+ -- 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
+
+ -- 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
+
+ -- 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"
+ 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
@@ -433,92 +433,92 @@ xmlSGR newSGR s = from ("<"<>newSGR<>">")<>s<>from ("</"<>newSGR<>">")
-- * 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.
- -- Using @p@ as 'Indent' text.
- setIndent :: d -> Indent -> d -> d
- -- | @('incrIndent' p ind d)@ make @d@ uses current 'Indent' plus @ind@ as 'Indent' level.
- -- Appending @p@ to the current 'Indent' text.
- incrIndent :: d -> Indent -> d -> d
- hang :: Indent -> d -> d
- hang ind = align . incrIndent (spaces ind) ind
- -- | @('fill' w d)@ write @d@,
- -- then if @d@ 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
+ -- | @('align' d)@ make @d@ uses current 'Column' as 'Indent' level.
+ align :: d -> d
+ -- | @('setIndent' p ind d)@ make @d@ 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.
+ -- Appending @p@ to the current 'Indent' text.
+ incrIndent :: d -> Indent -> d -> d
+ hang :: Indent -> d -> d
+ hang ind = align . incrIndent (spaces ind) ind
+ -- | @('fill' w d)@ write @d@,
+ -- then if @d@ 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
- 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
+ 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
- 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
+ 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 'Justifiable'
class Justifiable d where
- justify :: d -> d
+ 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))
+ -- | 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))
diff --git a/src/Symantic/Document/Plain.hs b/src/Symantic/Document/Plain.hs
index a5bc8ad..077c407 100644
--- a/src/Symantic/Document/Plain.hs
+++ b/src/Symantic/Document/Plain.hs
@@ -43,18 +43,18 @@ newtype Plain d = Plain
-- ReaderT PlainInh (StateT (PlainState d) (Cont (PlainFit d))) (d->d)
}
instance (Show d, Spaceable d) => Show (Plain d) where
- show = show . runPlain
+ show = show . runPlain
runPlain :: Spaceable d => Plain d -> d
runPlain x =
- unPlain x
- defPlainInh
- defPlainState
- {-k-}(\(px,_sx) fits _overflow ->
- -- NOTE: if px fits, then appending mempty fits
- fits (px mempty) )
- {-fits-}id
- {-overflow-}id
+ unPlain x
+ defPlainInh
+ defPlainState
+ {-k-}(\(px,_sx) fits _overflow ->
+ -- NOTE: if px fits, then appending mempty fits
+ fits (px mempty) )
+ {-fits-}id
+ {-overflow-}id
-- ** Type 'PlainState'
data PlainState d = PlainState
@@ -115,29 +115,29 @@ data PlainChunk d
-- ^ 'spaces' preserved to be interleaved
-- correctly with 'PlainChunk_Ignored'.
instance Show d => Show (PlainChunk d) 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
+ 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{} -> 0
- PlainChunk_Word d -> width d
- PlainChunk_Spaces s -> s
- nullWidth = \case
- PlainChunk_Ignored{} -> True
- PlainChunk_Word d -> nullWidth d
- PlainChunk_Spaces s -> s == 0
+ width = \case
+ PlainChunk_Ignored{} -> 0
+ PlainChunk_Word d -> width d
+ PlainChunk_Spaces s -> s
+ nullWidth = \case
+ PlainChunk_Ignored{} -> True
+ PlainChunk_Word d -> nullWidth d
+ PlainChunk_Spaces s -> s == 0
instance From [SGR] d => From [SGR] (PlainChunk d) where
- from sgr = PlainChunk_Ignored (from sgr)
+ from sgr = PlainChunk_Ignored (from sgr)
runPlainChunk :: Spaceable d => PlainChunk d -> d
runPlainChunk = \case
@@ -146,185 +146,185 @@ runPlainChunk = \case
PlainChunk_Spaces s -> spaces 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)
+ 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 = (<>)
+ mempty = Plain $ \_inh st k -> k (id,st)
+ mappend = (<>)
instance Spaceable d => Spaceable (Plain d) where
- -- | The default 'newline' does not justify 'plainState_buffer',
- -- for that use 'newlineJustifyingPlain'.
- newline = Plain $ \inh st ->
- unPlain
- ( newlinePlain
- <> indentPlain
- <> propagatePlain (plainState_breakIndent st)
- <> flushlinePlain
- ) inh st
- where
- indentPlain = Plain $ \inh ->
- unPlain
- (plainInh_indenting inh)
- 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
- , st
- { plainState_bufferStart = 0
- , plainState_bufferWidth = 0
- , plainState_buffer = mempty
- })
- propagatePlain breakIndent = Plain $ \inh st1 k fits overflow ->
- k (id,st1)
- fits
- {-overflow-}(
- -- NOTE: the text after this newline overflows,
- -- so propagate the overflow before this 'newline',
- -- if and only if there is a 'breakspace' before this 'newline'
- -- whose replacement by a 'newline' indents to a lower indent
- -- than this 'newline''s indent.
- -- Otherwise there is no point in propagating the overflow.
- if breakIndent < plainInh_indent inh
- then overflow
- else fits
- )
- 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{-(d<>)-}, newState) fits overflow
- _ -> k (id{-(d<>)-}, newState) fits overflow
- else
- let newState = st
- { plainState_bufferWidth = plainState_bufferWidth + n
- } in
- case plainInh_width inh of
- Just maxWidth | maxWidth < newWidth ->
- overflow $ k ((spaces n <>), newState) fits fits
- _ -> k ((spaces n <>), newState) fits overflow
+ -- | The default 'newline' does not justify 'plainState_buffer',
+ -- for that use 'newlineJustifyingPlain'.
+ newline = Plain $ \inh st ->
+ unPlain
+ ( newlinePlain
+ <> indentPlain
+ <> propagatePlain (plainState_breakIndent st)
+ <> flushlinePlain
+ ) inh st
+ where
+ indentPlain = Plain $ \inh ->
+ unPlain
+ (plainInh_indenting inh)
+ 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
+ , st
+ { plainState_bufferStart = 0
+ , plainState_bufferWidth = 0
+ , plainState_buffer = mempty
+ })
+ propagatePlain breakIndent = Plain $ \inh st1 k fits overflow ->
+ k (id,st1)
+ fits
+ {-overflow-}(
+ -- NOTE: the text after this newline overflows,
+ -- so propagate the overflow before this 'newline',
+ -- if and only if there is a 'breakspace' before this 'newline'
+ -- whose replacement by a 'newline' indents to a lower indent
+ -- than this 'newline''s indent.
+ -- Otherwise there is no point in propagating the overflow.
+ if breakIndent < plainInh_indent inh
+ then overflow
+ else fits
+ )
+ 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{-(d<>)-}, newState) fits overflow
+ _ -> k (id{-(d<>)-}, newState) fits overflow
+ else
+ let newState = st
+ { plainState_bufferWidth = plainState_bufferWidth + n
+ } 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
+ 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
+ from =
+ mconcat .
+ List.intersperse breakspace .
+ (from <$>) .
+ words .
+ unLine
instance Spaceable d => Indentable (Plain d) where
- align p = (flushlinePlain <>) $ Plain $ \inh st ->
- let col = plainState_bufferStart st + plainState_bufferWidth st in
- unPlain p inh
- { plainInh_indent = col
- , plainInh_indenting =
- if plainInh_indent inh <= col
- then
- plainInh_indenting inh <>
- spaces (col`minusNatural`plainInh_indent inh)
- else spaces col
- } st
- setIndent d i p = Plain $ \inh ->
- unPlain p inh
- { plainInh_indent = i
- , plainInh_indenting = d
- }
- incrIndent d i p = Plain $ \inh ->
- unPlain p inh
- { plainInh_indent = plainInh_indent inh + i
- , plainInh_indenting = plainInh_indenting inh <> d
- }
-
- fill m p = Plain $ \inh0 st0 ->
- let maxCol = plainState_bufferStart st0 + plainState_bufferWidth st0 + m in
- 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
- in
- unPlain (p <> p1) inh0 st0
- fillOrBreak m p = Plain $ \inh0 st0 ->
- let maxCol = plainState_bufferStart st0 + plainState_bufferWidth st0 + m in
- 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
- GT -> incrIndent (spaces m) m newline
- ) inh1 st1
- in
- unPlain (p <> p1) inh0 st0
+ align p = (flushlinePlain <>) $ Plain $ \inh st ->
+ let col = plainState_bufferStart st + plainState_bufferWidth st in
+ unPlain p inh
+ { plainInh_indent = col
+ , plainInh_indenting =
+ if plainInh_indent inh <= col
+ then
+ plainInh_indenting inh <>
+ spaces (col`minusNatural`plainInh_indent inh)
+ else spaces col
+ } st
+ setIndent d i p = Plain $ \inh ->
+ unPlain p inh
+ { plainInh_indent = i
+ , plainInh_indenting = d
+ }
+ incrIndent d i p = Plain $ \inh ->
+ unPlain p inh
+ { plainInh_indent = plainInh_indent inh + i
+ , plainInh_indenting = plainInh_indenting inh <> d
+ }
+
+ fill m p = Plain $ \inh0 st0 ->
+ let maxCol = plainState_bufferStart st0 + plainState_bufferWidth st0 + m in
+ 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
+ in
+ unPlain (p <> p1) inh0 st0
+ fillOrBreak m p = Plain $ \inh0 st0 ->
+ let maxCol = plainState_bufferStart st0 + plainState_bufferWidth st0 + m in
+ 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
+ GT -> incrIndent (spaces m) m newline
+ ) 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<>flushlinePlain<>align d{-<>flushlinePlain-}
- ol ds =
- catV $ snd $
- Fold.foldr
- (\d (i, acc) ->
- (pred i, (from i<>from (Word '.')<>space<>flushlinePlain<>align d{-<>flushlinePlain-}) : acc)
- ) (Fold.length ds, []) ds
+ ul ds =
+ catV $
+ (<$> ds) $ \d ->
+ from (Word '-')<>space<>flushlinePlain<>align d{-<>flushlinePlain-}
+ ol ds =
+ catV $ 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}
+ 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
- }
- )
+ 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
@@ -332,176 +332,176 @@ collapsePlainChunkSpaces = \case
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})
- 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 <>)
- , st
- { plainState_buffer =
- 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_breakIndent = plainInh_indent inh
- }
- )
- fits
- {-overflow-}(\_r -> unPlain newlineJustifyingPlain inh st k fits overflow)
- breakalt x y = Plain $ \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)
- where
- dummyK (px,_sx) fits _overflow =
- -- NOTE: if px fits, then appending mempty fits
- fits (px mempty)
- 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
- Just w ->
- let newState = st
- { plainState_bufferWidth = plainState_bufferWidth st + w
- } in
- k (id,newState) fits fits
+ 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})
+ 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 <>)
+ , st
+ { plainState_buffer =
+ 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_breakIndent = plainInh_indent inh
+ }
+ )
+ fits
+ {-overflow-}(\_r -> unPlain newlineJustifyingPlain inh st k fits overflow)
+ breakalt x y = Plain $ \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)
+ where
+ dummyK (px,_sx) fits _overflow =
+ -- NOTE: if px fits, then appending mempty fits
+ fits (px mempty)
+ 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
+ Just w ->
+ let newState = st
+ { plainState_bufferWidth = plainState_bufferWidth st + w
+ } in
+ k (id,newState) fits fits
-- | Like 'newline', but justify 'plainState_buffer' before.
newlineJustifyingPlain :: Spaceable d => Plain d
newlineJustifyingPlain = Plain $ \inh st ->
- unPlain
- ( newlinePlain
- <> indentPlain
- <> propagatePlain (plainState_breakIndent st)
- <> flushlinePlain
- ) inh st
- where
- indentPlain = Plain $ \inh ->
- unPlain
- (plainInh_indenting inh)
- inh{plainInh_justify=False}
- newlinePlain = Plain $ \inh st k ->
- k (\next ->
- (if plainInh_justify inh
- then justifyLinePlain inh st
- else mempty
- )<>newline<>next
- , st
- { plainState_bufferStart = 0
- , plainState_bufferWidth = 0
- , plainState_buffer = mempty
- })
- propagatePlain breakIndent = Plain $ \inh st1 k fits overflow ->
- k (id,st1)
- fits
- {-overflow-}(
- -- NOTE: the text after this newline overflows,
- -- so propagate the overflow before this 'newline',
- -- if and only if there is a 'breakspace' before this 'newline'
- -- whose replacement by a 'newline' indents to a lower indent
- -- than this 'newline''s indent.
- -- Otherwise there is no point in propagating the overflow.
- if breakIndent < plainInh_indent inh
- then overflow
- else fits
- )
+ unPlain
+ ( newlinePlain
+ <> indentPlain
+ <> propagatePlain (plainState_breakIndent st)
+ <> flushlinePlain
+ ) inh st
+ where
+ indentPlain = Plain $ \inh ->
+ unPlain
+ (plainInh_indenting inh)
+ inh{plainInh_justify=False}
+ newlinePlain = Plain $ \inh st k ->
+ k (\next ->
+ (if plainInh_justify inh
+ then justifyLinePlain inh st
+ else mempty
+ )<>newline<>next
+ , st
+ { plainState_bufferStart = 0
+ , plainState_bufferWidth = 0
+ , plainState_buffer = mempty
+ })
+ propagatePlain breakIndent = Plain $ \inh st1 k fits overflow ->
+ k (id,st1)
+ fits
+ {-overflow-}(
+ -- NOTE: the text after this newline overflows,
+ -- so propagate the overflow before this 'newline',
+ -- if and only if there is a 'breakspace' before this 'newline'
+ -- whose replacement by a 'newline' indents to a lower indent
+ -- than this 'newline''s indent.
+ -- Otherwise there is no point in propagating the overflow.
+ if breakIndent < plainInh_indent inh
+ then overflow
+ else fits
+ )
-- String
instance (From (Word String) d, Spaceable d) =>
From String (Plain d) where
- from =
- mconcat .
- List.intersperse newline .
- (from <$>) .
- lines
+ from =
+ mconcat .
+ List.intersperse newline .
+ (from <$>) .
+ lines
instance (From (Word String) d, Spaceable d) =>
IsString (Plain d) where
- fromString = from
+ fromString = from
-- Text
instance (From (Word Text) d, Spaceable d) =>
From Text (Plain d) where
- from =
- mconcat .
- List.intersperse newline .
- (from <$>) .
- lines
+ 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
+ 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)
+ 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)
+ 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
justifyLinePlain inh PlainState{..} =
- case plainInh_width inh of
- Nothing -> joinLinePlainChunk $ List.reverse plainState_buffer
- Just maxWidth ->
- if maxWidth < plainState_bufferStart
- || maxWidth < plainInh_indent inh
- then joinLinePlainChunk $ 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 = countWordsPlain plainState_buffer in
- unLine $ padLinePlainChunkInits justifyWidth $
- (minBufferWidth,wordCount,List.reverse plainState_buffer)
+ case plainInh_width inh of
+ Nothing -> joinLinePlainChunk $ List.reverse plainState_buffer
+ Just maxWidth ->
+ if maxWidth < plainState_bufferStart
+ || maxWidth < plainInh_indent inh
+ then joinLinePlainChunk $ 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 = countWordsPlain plainState_buffer in
+ unLine $ padLinePlainChunkInits justifyWidth $
+ (minBufferWidth,wordCount,List.reverse plainState_buffer)
-- | @('countWordsPlain' ps)@ returns the number of words in @(ps)@
-- clearly separated by spaces.
countWordsPlain :: [PlainChunk d] -> Natural
countWordsPlain = go False 0
where
- go inWord acc = \case
- [] -> acc
- PlainChunk_Word{}:xs ->
- if inWord
- then go inWord acc xs
- else go True (acc+1) xs
- PlainChunk_Spaces s:xs
- | s == 0 -> go inWord acc xs
- | otherwise -> go False acc xs
- PlainChunk_Ignored{}:xs -> go inWord acc xs
+ go inWord acc = \case
+ [] -> acc
+ PlainChunk_Word{}:xs ->
+ if inWord
+ then go inWord acc xs
+ else go True (acc+1) xs
+ PlainChunk_Spaces s:xs
+ | s == 0 -> go inWord acc xs
+ | otherwise -> go False acc xs
+ PlainChunk_Ignored{}:xs -> go inWord acc xs
-- | @('justifyPadding' a b)@ returns the padding lengths
-- to reach @(a)@ in @(b)@ pads,
@@ -520,29 +520,29 @@ countWordsPlain = go False 0
-- @
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)
+ 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)
padLinePlainChunkInits ::
Spaceable d =>
Width -> (Natural, Natural, [PlainChunk d]) -> Line d
padLinePlainChunkInits 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 maxWidth <= lineWidth && wordCount == 1
- -- can happen if first word's length is < maxWidth
- -- but second word's len is >= maxWidth.
- then joinLinePlainChunk line
- else
- -- Share the missing spaces as evenly as possible
- -- between the words of the line.
- padLinePlainChunk line $ justifyPadding (maxWidth-lineWidth) (wordCount-1)
+ if maxWidth <= lineWidth
+ -- The gathered line reached or overreached the maxWidth,
+ -- hence no padding id needed.
+ || wordCount <= 1
+ -- The case maxWidth <= lineWidth && wordCount == 1
+ -- can happen if first word's length is < maxWidth
+ -- but second word's len is >= maxWidth.
+ then joinLinePlainChunk line
+ else
+ -- Share the missing spaces as evenly as possible
+ -- 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
@@ -551,77 +551,77 @@ joinLinePlainChunk = mconcat . (runPlainChunk <$>)
-- | Interleave 'PlainChunk's with 'Width's from 'justifyPadding'.
padLinePlainChunk :: Spaceable d => [PlainChunk d] -> [Width] -> d
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
- go (w:ws) [] = runPlainChunk w <> go ws []
- go [] _ls = mempty
+ 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
+ go (w:ws) [] = runPlainChunk w <> go ws []
+ go [] _ls = mempty
-- * Escaping
instance (Semigroup d, From [SGR] d) => Colorable16 (Plain d) where
- reverse = plainSGR $ SetSwapForegroundBackground True
- black = plainSGR $ SetColor Foreground Dull Black
- red = plainSGR $ SetColor Foreground Dull Red
- green = plainSGR $ SetColor Foreground Dull Green
- yellow = plainSGR $ SetColor Foreground Dull Yellow
- blue = plainSGR $ SetColor Foreground Dull Blue
- magenta = plainSGR $ SetColor Foreground Dull Magenta
- cyan = plainSGR $ SetColor Foreground Dull Cyan
- white = plainSGR $ SetColor Foreground Dull White
- blacker = plainSGR $ SetColor Foreground Vivid Black
- redder = plainSGR $ SetColor Foreground Vivid Red
- greener = plainSGR $ SetColor Foreground Vivid Green
- yellower = plainSGR $ SetColor Foreground Vivid Yellow
- bluer = plainSGR $ SetColor Foreground Vivid Blue
- magentaer = plainSGR $ SetColor Foreground Vivid Magenta
- cyaner = plainSGR $ SetColor Foreground Vivid Cyan
- whiter = plainSGR $ SetColor Foreground Vivid White
- onBlack = plainSGR $ SetColor Background Dull Black
- onRed = plainSGR $ SetColor Background Dull Red
- onGreen = plainSGR $ SetColor Background Dull Green
- onYellow = plainSGR $ SetColor Background Dull Yellow
- onBlue = plainSGR $ SetColor Background Dull Blue
- onMagenta = plainSGR $ SetColor Background Dull Magenta
- onCyan = plainSGR $ SetColor Background Dull Cyan
- onWhite = plainSGR $ SetColor Background Dull White
- onBlacker = plainSGR $ SetColor Background Vivid Black
- onRedder = plainSGR $ SetColor Background Vivid Red
- onGreener = plainSGR $ SetColor Background Vivid Green
- onYellower = plainSGR $ SetColor Background Vivid Yellow
- onBluer = plainSGR $ SetColor Background Vivid Blue
- onMagentaer = plainSGR $ SetColor Background Vivid Magenta
- onCyaner = plainSGR $ SetColor Background Vivid Cyan
- onWhiter = plainSGR $ SetColor Background Vivid White
+ reverse = plainSGR $ SetSwapForegroundBackground True
+ black = plainSGR $ SetColor Foreground Dull Black
+ red = plainSGR $ SetColor Foreground Dull Red
+ green = plainSGR $ SetColor Foreground Dull Green
+ yellow = plainSGR $ SetColor Foreground Dull Yellow
+ blue = plainSGR $ SetColor Foreground Dull Blue
+ magenta = plainSGR $ SetColor Foreground Dull Magenta
+ cyan = plainSGR $ SetColor Foreground Dull Cyan
+ white = plainSGR $ SetColor Foreground Dull White
+ blacker = plainSGR $ SetColor Foreground Vivid Black
+ redder = plainSGR $ SetColor Foreground Vivid Red
+ greener = plainSGR $ SetColor Foreground Vivid Green
+ yellower = plainSGR $ SetColor Foreground Vivid Yellow
+ bluer = plainSGR $ SetColor Foreground Vivid Blue
+ magentaer = plainSGR $ SetColor Foreground Vivid Magenta
+ cyaner = plainSGR $ SetColor Foreground Vivid Cyan
+ whiter = plainSGR $ SetColor Foreground Vivid White
+ onBlack = plainSGR $ SetColor Background Dull Black
+ onRed = plainSGR $ SetColor Background Dull Red
+ onGreen = plainSGR $ SetColor Background Dull Green
+ onYellow = plainSGR $ SetColor Background Dull Yellow
+ onBlue = plainSGR $ SetColor Background Dull Blue
+ onMagenta = plainSGR $ SetColor Background Dull Magenta
+ onCyan = plainSGR $ SetColor Background Dull Cyan
+ onWhite = plainSGR $ SetColor Background Dull White
+ onBlacker = plainSGR $ SetColor Background Vivid Black
+ onRedder = plainSGR $ SetColor Background Vivid Red
+ onGreener = plainSGR $ SetColor Background Vivid Green
+ onYellower = plainSGR $ SetColor Background Vivid Yellow
+ onBluer = plainSGR $ SetColor Background Vivid Blue
+ 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
- bold = plainSGR $ SetConsoleIntensity BoldIntensity
- underline = plainSGR $ SetUnderlining SingleUnderline
- italic = plainSGR $ SetItalicized True
+ 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
- where
- before = Plain $ \inh st k ->
- let d = from [newSGR] in
- if plainInh_justify inh
- then k (id, st
- { plainState_buffer =
- PlainChunk_Ignored d :
- 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
- if plainInh_justify inh
- then k (id, st
- { plainState_buffer =
- PlainChunk_Ignored d :
- plainState_buffer st
- })
- else k ((d <>), st)
+ where
+ before = Plain $ \inh st k ->
+ let d = from [newSGR] in
+ if plainInh_justify inh
+ then k (id, st
+ { plainState_buffer =
+ PlainChunk_Ignored d :
+ 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
+ if plainInh_justify inh
+ then k (id, st
+ { plainState_buffer =
+ PlainChunk_Ignored d :
+ plainState_buffer st
+ })
+ else k ((d <>), st)
diff --git a/src/Symantic/HLint.hs b/src/Symantic/HLint.hs
deleted file mode 120000
index ab18269..0000000
--- a/src/Symantic/HLint.hs
+++ /dev/null
@@ -1 +0,0 @@
-../HLint.hs
\ No newline at end of file
diff --git a/tests/HLint.hs b/tests/HLint.hs
deleted file mode 120000
index ab18269..0000000
--- a/tests/HLint.hs
+++ /dev/null
@@ -1 +0,0 @@
-../HLint.hs
\ No newline at end of file
--
2.47.2