From 51a3979480d3abed9929227912ffe89d24e85dbb Mon Sep 17 00:00:00 2001
From: Julien Moutinho <julm+symantic@autogeree.net>
Date: Mon, 12 Mar 2018 06:18:54 +0100
Subject: [PATCH] Polish symantic-document.
---
.../Language/Symantic/Document/Sym.hs | 67 ++++++++++---------
.../Language/Symantic/Document/Term.hs | 16 ++---
.../Symantic/Document/Term/Dimension.hs | 17 ++---
.../Language/Symantic/Document/Term/IO.hs | 26 +++----
4 files changed, 58 insertions(+), 68 deletions(-)
diff --git a/symantic-document/Language/Symantic/Document/Sym.hs b/symantic-document/Language/Symantic/Document/Sym.hs
index 71ede01..b8c4970 100644
--- a/symantic-document/Language/Symantic/Document/Sym.hs
+++ b/symantic-document/Language/Symantic/Document/Sym.hs
@@ -12,8 +12,8 @@ import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..), Ordering(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString)
-import Prelude (Integer, toInteger, fromIntegral, Num(..), undefined, Integral, Real, Enum)
-import Text.Show (Show)
+import Prelude (Integer, fromIntegral, Num(..), pred, undefined, Integral, Real, Enum)
+import Text.Show (Show(..))
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
@@ -53,6 +53,7 @@ type Indent = Column
-- * Class 'Textable'
class (IsString d, Semigroup d) => Textable d where
+ empty :: d
charH :: Char -- ^ XXX: MUST NOT be '\n'
-> d
stringH :: String -- ^ XXX: MUST NOT contain '\n'
@@ -61,22 +62,17 @@ class (IsString d, Semigroup d) => Textable d where
-> d
ltextH :: TL.Text -- ^ XXX: MUST NOT contain '\n'
-> d
- replicate :: Int -> d -> d
- integer :: Integer -> d
- default replicate :: Textable (ReprOf d) => Trans d => Int -> d -> d
- default integer :: Textable (ReprOf d) => Trans d => Integer -> d
+ default empty :: Textable (ReprOf d) => Trans d => d
default charH :: Textable (ReprOf d) => Trans d => Char -> d
default stringH :: Textable (ReprOf d) => Trans d => String -> d
default textH :: Textable (ReprOf d) => Trans d => Text.Text -> d
default ltextH :: Textable (ReprOf d) => Trans d => TL.Text -> d
- charH = trans . charH
- stringH = trans . stringH
- textH = trans . textH
- ltextH = trans . ltextH
- replicate = trans1 . replicate
- integer = trans . integer
+ empty = trans empty
+ charH = trans . charH
+ stringH = trans . stringH
+ textH = trans . textH
+ ltextH = trans . ltextH
- empty :: d
newline :: d
space :: d
-- | @x '<+>' y = x '<>' 'space' '<>' y@
@@ -84,6 +80,7 @@ class (IsString d, Semigroup d) => Textable d where
-- | @x '</>' y = x '<>' 'newline' '<>' y@
(</>) :: d -> d -> d
int :: Int -> d
+ integer :: Integer -> d
char :: Char -> d
string :: String -> d
text :: Text.Text -> d
@@ -94,34 +91,31 @@ class (IsString d, Semigroup d) => Textable d where
foldWith :: Foldable f => (d -> d) -> f d -> d
intercalate :: Foldable f => d -> f d -> d
between :: d -> d -> d -> d
+ replicate :: Int -> d -> d
- newline = "\n"
- space = char ' '
- x <+> y = x <> space <> y
- x </> y = x <> newline <> y
- int = integer . toInteger
- char = \case '\n' -> newline; c -> charH c
- string = catV . fmap stringH . lines
- text = catV . fmap textH . Text.lines
- ltext = catV . fmap ltextH . TL.lines
- catH = foldr (<>) empty
- catV = foldrWith (\x y -> x<>newline<>y)
+ newline = "\n"
+ space = char ' '
+ x <+> y = x <> space <> y
+ x </> y = x <> newline <> y
+ int = stringH . show
+ integer = stringH . show
+ char = \case '\n' -> newline; c -> charH c
+ string = catV . fmap stringH . lines
+ text = catV . fmap textH . Text.lines
+ ltext = catV . fmap ltextH . TL.lines
+ catH = foldr (<>) empty
+ catV = foldrWith (\x y -> x<>newline<>y)
foldrWith f ds = if null ds then empty else foldr1 f ds
foldWith f = foldrWith $ \a acc -> a <> f acc
intercalate sep = foldrWith (\x y -> x<>sep<>y)
between o c d = o<>d<>c
- -- default catH :: Textable (ReprOf d) => Trans d => Foldable f => Functor f => f d -> d
- -- default catV :: Textable (ReprOf d) => Trans d => Foldable f => Functor f => f d -> d
- -- catH l = trans (catH (fmap unTrans l))
- -- catV l = trans (catV (fmap unTrans l))
+ replicate cnt t | cnt <= 0 = empty
+ | otherwise = t <> replicate (pred cnt) t
-- * Class 'Indentable'
class Textable d => Indentable d where
-- | @('align' d)@ make @d@ uses current 'Column' as 'Indent' level.
align :: d -> d
- -- | @('hang' ind d)@ make @d@ uses current 'Column' plus @ind@ as 'Indent' level.
- hang :: Indent -> d -> d
- hang ind = align . incrIndent ind
-- | @('incrIndent' ind d)@ make @d@ uses current 'Indent' plus @ind@ as 'Indent' level.
incrIndent :: Indent -> d -> d
-- | @('withIndent' ind d)@ make @d@ uses @ind@ as 'Indent' level.
@@ -136,6 +130,11 @@ class Textable d => Indentable d where
column :: (Column -> d) -> d
-- | @('indent' f)@ write @f@ applied to the current 'Indent'.
indent :: (Indent -> d) -> d
+
+ -- | @('hang' ind d)@ make @d@ uses current 'Column' plus @ind@ as 'Indent' level.
+ hang :: Indent -> d -> d
+ hang ind = align . incrIndent ind
+
-- | @('endToEndWidth' d f)@ write @d@ then
-- @f@ applied to the difference between
-- the end 'Column' and start 'Column' of @d@.
@@ -186,23 +185,29 @@ class (Textable d, Indentable d) => Breakable d where
-- write @onNoBreak@ then @d@ if they fit,
-- @onBreak@ otherwise.
breakpoint :: d -> d -> d -> d
+
-- | @('breakableEmpty' d)@ write @d@ if it fits, 'newline' then @d@ otherwise.
breakableEmpty :: d -> d
breakableEmpty = breakpoint empty newline
+
-- | @x '><' y = x '<>' 'breakableEmpty' y@
(><) :: d -> d -> d
x >< y = x <> breakableEmpty y
+
-- | @('breakableSpace' d)@ write 'space' then @d@ it they fit,
-- 'newline' then @d@ otherwise.
breakableSpace :: d -> d
breakableSpace = breakpoint space newline
+
-- | @x '>+<' y = x '<>' 'breakableSpace' y@
(>+<) :: d -> d -> d
x >+< y = x <> breakableSpace y
+
-- | @'breakableSpaces' ds@ intercalate a 'breakableSpace'
-- between items of @ds@.
breakableSpaces :: Foldable f => f d -> d
breakableSpaces = foldWith breakableSpace
+
-- | @('intercalateHorV' sep ds)@
-- write @ds@ with @sep@ intercalated if the whole fits,
-- otherwise write 'align' of @ds@ with 'newline' and @sep@ intercalated.
diff --git a/symantic-document/Language/Symantic/Document/Term.hs b/symantic-document/Language/Symantic/Document/Term.hs
index 78dfe42..4658033 100644
--- a/symantic-document/Language/Symantic/Document/Term.hs
+++ b/symantic-document/Language/Symantic/Document/Term.hs
@@ -14,7 +14,6 @@ import Data.String (IsString(..))
import GHC.Exts (IsList(..))
import Prelude (pred, fromIntegral, Num(..))
import System.Console.ANSI
-import Text.Show (Show(..))
import qualified Data.List as List
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
@@ -102,8 +101,6 @@ instance Textable Term where
stringH t = writeH (length t) (fromString t)
textH t = writeH (length t) (TLB.fromText t)
ltextH t = writeH (length t) (TLB.fromLazyText t)
- int = stringH . show
- integer = stringH . show
replicate cnt t | cnt <= 0 = empty
| otherwise = t <> replicate (pred cnt) t
newline = Term $ \ro -> unTerm (reader_newline ro) ro
@@ -129,11 +126,10 @@ instance Breakable Term where
Nothing -> ko
Just{} -> (\_sx _tx -> unTerm y ro st ok ko)
breakpoint onNoBreak onBreak t = Term $ \ro st ok ko ->
+ unTerm (onNoBreak <> t) ro st ok $
case reader_breakable ro of
- Nothing -> unTerm t ro st ok ko
- Just{} ->
- unTerm (onNoBreak <> t) ro st ok
- (\_sp _tp -> unTerm (onBreak <> t) ro st ok ko)
+ Nothing -> ko
+ Just{} -> (\_sp _tp -> unTerm (onBreak <> t) ro st ok ko)
writeSGR :: (Reader -> Bool) -> SGR -> Term -> Term
writeSGR isOn s (Term t) =
@@ -185,6 +181,6 @@ instance Colorable Term where
instance Decorable Term where
decorable f = Term $ \ro -> unTerm (f (reader_decorable ro)) ro
withDecorable b t = Term $ \ro -> unTerm t ro{reader_decorable=b}
- bold = writeSGR reader_decorable $ SetConsoleIntensity BoldIntensity
- underline = writeSGR reader_decorable $ SetUnderlining SingleUnderline
- italic = writeSGR reader_decorable $ SetItalicized True
+ bold = writeSGR reader_decorable $ SetConsoleIntensity BoldIntensity
+ underline = writeSGR reader_decorable $ SetUnderlining SingleUnderline
+ italic = writeSGR reader_decorable $ SetItalicized True
diff --git a/symantic-document/Language/Symantic/Document/Term/Dimension.hs b/symantic-document/Language/Symantic/Document/Term/Dimension.hs
index 7ceb685..634e378 100644
--- a/symantic-document/Language/Symantic/Document/Term/Dimension.hs
+++ b/symantic-document/Language/Symantic/Document/Term/Dimension.hs
@@ -13,7 +13,7 @@ import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
import GHC.Exts (IsList(..))
-import Prelude ((+), pred)
+import Prelude ((+))
import Text.Show (Show(..))
import Language.Symantic.Document.Sym
@@ -54,7 +54,7 @@ defReader :: Reader
defReader = Reader
{ reader_indent = 0
, reader_newline = newlineWithIndent
- , reader_breakable = Just $ Nat 80
+ , reader_breakable = Nothing
, reader_colorable = True
, reader_decorable = True
}
@@ -117,11 +117,7 @@ instance Textable Dimension where
stringH = writeH . length
textH = writeH . length
ltextH = writeH . length
- int = stringH . show
- integer = stringH . show
- replicate cnt p | cnt <= 0 = empty
- | otherwise = p <> replicate (pred cnt) p
- newline = Dimension $ \ro -> unDimension (reader_newline ro) ro
+ newline = Dimension $ \ro -> unDimension (reader_newline ro) ro
instance Indentable Dimension where
align p = Dimension $ \ro st -> unDimension p ro{reader_indent=st} st
withNewline nl p = Dimension $ \ro -> unDimension p ro{reader_newline=nl}
@@ -154,11 +150,10 @@ instance Breakable Dimension where
Nothing -> ko
Just{} -> (\_sx _tx -> unDimension y ro st ok ko)
breakpoint onNoBreak onBreak t = Dimension $ \ro st ok ko ->
+ unDimension (onNoBreak <> t) ro st ok $
case reader_breakable ro of
- Nothing -> unDimension t ro st ok ko
- Just{} ->
- unDimension (onNoBreak <> t) ro st ok
- (\_sp _tp -> unDimension (onBreak <> t) ro st ok ko)
+ Nothing -> ko
+ Just{} -> (\_sp _tp -> unDimension (onBreak <> t) ro st ok ko)
instance Colorable Dimension where
colorable f = Dimension $ \ro -> unDimension (f (reader_colorable ro)) ro
withColorable b t = Dimension $ \ro -> unDimension t ro{reader_colorable=b}
diff --git a/symantic-document/Language/Symantic/Document/Term/IO.hs b/symantic-document/Language/Symantic/Document/Term/IO.hs
index 66c6e52..cf53460 100644
--- a/symantic-document/Language/Symantic/Document/Term/IO.hs
+++ b/symantic-document/Language/Symantic/Document/Term/IO.hs
@@ -5,17 +5,16 @@ module Language.Symantic.Document.Term.IO
import Control.Applicative (Applicative(..))
import Data.Bool
-import Data.Function (($), (.), id)
+import Data.Function (($), id)
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
import GHC.Exts (IsList(..))
-import Prelude (pred, fromIntegral, Num(..))
+import Prelude (fromIntegral, Num(..))
import System.Console.ANSI
import System.IO (IO)
-import Text.Show (Show(..))
import qualified Data.List as List
import qualified Data.Text.IO as Text
import qualified Data.Text.Lazy.IO as TL
@@ -42,7 +41,7 @@ defReader = Reader
, reader_newline = newlineWithIndent
, reader_sgr = []
, reader_handle = IO.stdout
- , reader_breakable = Just $ Nat 80
+ , reader_breakable = Nothing
, reader_colorable = True
, reader_decorable = True
}
@@ -101,11 +100,7 @@ instance Textable TermIO where
stringH t = writeH (length t) (`IO.hPutStr` t)
textH t = writeH (length t) (`Text.hPutStr` t)
ltextH t = writeH (length t) (`TL.hPutStr` t)
- int = stringH . show
- integer = stringH . show
- replicate cnt t | cnt <= 0 = empty
- | otherwise = t <> replicate (pred cnt) t
- newline = TermIO $ \ro -> unTermIO (reader_newline ro) ro
+ newline = TermIO $ \ro -> unTermIO (reader_newline ro) ro
instance Indentable TermIO where
align t = TermIO $ \ro st -> unTermIO t ro{reader_indent=st} st
withNewline nl t = TermIO $ \ro -> unTermIO t ro{reader_newline=nl}
@@ -128,11 +123,10 @@ instance Breakable TermIO where
Nothing -> ko
Just{} -> (\_sx _tx -> unTermIO y ro st ok ko)
breakpoint onNoBreak onBreak t = TermIO $ \ro st ok ko ->
+ unTermIO (onNoBreak <> t) ro st ok $
case reader_breakable ro of
- Nothing -> unTermIO t ro st ok ko
- Just{} ->
- unTermIO (onNoBreak <> t) ro st ok
- (\_sp _tp -> unTermIO (onBreak <> t) ro st ok ko)
+ Nothing -> ko
+ Just{} -> (\_sp _tp -> unTermIO (onBreak <> t) ro st ok ko)
writeSGR :: (Reader -> Bool) -> SGR -> TermIO -> TermIO
writeSGR isOn s (TermIO t) =
@@ -184,6 +178,6 @@ instance Colorable TermIO where
instance Decorable TermIO where
decorable f = TermIO $ \ro -> unTermIO (f (reader_decorable ro)) ro
withDecorable b t = TermIO $ \ro -> unTermIO t ro{reader_decorable=b}
- bold = writeSGR reader_decorable $ SetConsoleIntensity BoldIntensity
- underline = writeSGR reader_decorable $ SetUnderlining SingleUnderline
- italic = writeSGR reader_decorable $ SetItalicized True
+ bold = writeSGR reader_decorable $ SetConsoleIntensity BoldIntensity
+ underline = writeSGR reader_decorable $ SetUnderlining SingleUnderline
+ italic = writeSGR reader_decorable $ SetItalicized True
--
2.47.2