From 4b4d7fed700e1525a379d879462e340b323fadd9 Mon Sep 17 00:00:00 2001
From: Julien Moutinho <julm+symantic@autogeree.net>
Date: Fri, 23 Jun 2017 00:12:58 +0200
Subject: [PATCH] Add replicate.
---
.../Language/Symantic/Document/ANSI.hs | 52 ++++----
.../Language/Symantic/Document/Dim.hs | 16 +--
.../Language/Symantic/Document/Plain.hs | 104 ++++++++--------
.../Language/Symantic/Document/Sym.hs | 115 ++++++++++--------
.../Language/Symantic/Document/Valid.hs | 34 +++---
symantic-document/symantic-document.cabal | 2 +-
6 files changed, 167 insertions(+), 156 deletions(-)
diff --git a/symantic-document/Language/Symantic/Document/ANSI.hs b/symantic-document/Language/Symantic/Document/ANSI.hs
index defaad9..88ba849 100644
--- a/symantic-document/Language/Symantic/Document/ANSI.hs
+++ b/symantic-document/Language/Symantic/Document/ANSI.hs
@@ -1,12 +1,11 @@
module Language.Symantic.Document.ANSI where
-import Control.Monad (Monad(..))
+import Control.Monad (Monad(..), replicateM_)
import Data.Bool (Bool(..))
-import Data.Function (($), (.))
+import Data.Function (($), (.), const)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
-import Prelude (fromInteger, toInteger)
import System.Console.ANSI
import System.IO (IO)
import Text.Show (Show(..))
@@ -40,18 +39,17 @@ instance Monoid ANSI where
mempty = empty
mappend = (<>)
instance Doc_Text ANSI where
- spaces i = ANSI $ \_ -> TLB.fromLazyText $ TL.replicate (int64 i) " "
- where int64 = fromInteger . toInteger
- int i = ANSI $ \_ -> fromString $ show i
- integer i = ANSI $ \_ -> fromString $ show i
- char x = ANSI $ \_ -> TLB.singleton x
- string x = ANSI $ \_ -> fromString x
- text x = ANSI $ \_ -> TLB.fromText x
- ltext x = ANSI $ \_ -> TLB.fromLazyText x
- charH = char
- stringH = string
- textH = text
- ltextH = ltext
+ replicate i d = ANSI $ TLB.fromLazyText . TL.replicate (int64OfInt i) . TLB.toLazyText . unANSI d
+ int = ANSI . const . fromString . show
+ integer = ANSI . const . fromString . show
+ char = ANSI . const . TLB.singleton
+ string = ANSI . const . fromString
+ text = ANSI . const . TLB.fromText
+ ltext = ANSI . const . TLB.fromLazyText
+ charH = char
+ stringH = string
+ textH = text
+ ltextH = ltext
instance Doc_Color ANSI where
reverse = pushSGR $ SetSwapForegroundBackground True
black = pushSGR $ SetColor Foreground Dull Black
@@ -112,18 +110,18 @@ instance Monoid ANSI_IO where
mempty = empty
mappend = (<>)
instance Doc_Text ANSI_IO where
- empty = ANSI_IO $ \_ _ -> return ()
- spaces i = ANSI_IO $ \_ h -> IO.hPutStr h (L.replicate i ' ')
- int i = ANSI_IO $ \_ h -> IO.hPutStr h (show i)
- integer i = ANSI_IO $ \_ h -> IO.hPutStr h (show i)
- char x = ANSI_IO $ \_ h -> IO.hPutChar h x
- string x = ANSI_IO $ \_ h -> IO.hPutStr h x
- text x = ANSI_IO $ \_ h -> T.hPutStr h x
- ltext x = ANSI_IO $ \_ h -> TL.hPutStr h x
- charH = char
- stringH = string
- textH = text
- ltextH = ltext
+ empty = ANSI_IO $ \_ _ -> return ()
+ replicate i d = ANSI_IO $ \c -> replicateM_ i . unANSI_IO d c
+ int i = ANSI_IO $ \_ h -> IO.hPutStr h (show i)
+ integer i = ANSI_IO $ \_ h -> IO.hPutStr h (show i)
+ char x = ANSI_IO $ \_ h -> IO.hPutChar h x
+ string x = ANSI_IO $ \_ h -> IO.hPutStr h x
+ text x = ANSI_IO $ \_ h -> T.hPutStr h x
+ ltext x = ANSI_IO $ \_ h -> TL.hPutStr h x
+ charH = char
+ stringH = string
+ textH = text
+ ltextH = ltext
instance Doc_Color ANSI_IO where
reverse = pushSGR_IO $ SetSwapForegroundBackground True
black = pushSGR_IO $ SetColor Foreground Dull Black
diff --git a/symantic-document/Language/Symantic/Document/Dim.hs b/symantic-document/Language/Symantic/Document/Dim.hs
index 040fc66..edf18b4 100644
--- a/symantic-document/Language/Symantic/Document/Dim.hs
+++ b/symantic-document/Language/Symantic/Document/Dim.hs
@@ -5,6 +5,7 @@ import Data.Function (($), id)
import Data.Functor ((<$>))
import Data.Int (Int)
import Data.Monoid (Monoid(..))
+import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
import Prelude (min, max, Num(..), toInteger)
@@ -54,13 +55,14 @@ instance Monoid Dim where
mempty = empty
mappend = (<>)
instance Doc_Text Dim where
- spaces i = Dim i 1 i 1
- int i = fromString $ show i
- integer i = fromString $ show i
- charH _c = Dim 1 1 1 1
- stringH t = Dim l h l l where h = min 1 l; l = length t
- textH t = Dim l h l l where h = min 1 l; l = T.length t
- ltextH t = Dim l h l l where h = min 1 l; l = fromInteger $ toInteger $ TL.length t
+ spaces i = Dim i 1 i i
+ replicate i d = if i <= 0 then empty else d <> replicate (i - 1) d
+ int i = fromString $ show i
+ integer i = fromString $ show i
+ charH _c = Dim 1 1 1 1
+ stringH t = Dim l h l l where h = min 1 l; l = length t
+ textH t = Dim l h l l where h = min 1 l; l = T.length t
+ ltextH t = Dim l h l l where h = min 1 l; l = fromInteger $ toInteger $ TL.length t
instance Doc_Color Dim where
reverse = id
black = id
diff --git a/symantic-document/Language/Symantic/Document/Plain.hs b/symantic-document/Language/Symantic/Document/Plain.hs
index ceabc72..07d3a4c 100644
--- a/symantic-document/Language/Symantic/Document/Plain.hs
+++ b/symantic-document/Language/Symantic/Document/Plain.hs
@@ -1,15 +1,14 @@
module Language.Symantic.Document.Plain where
-import Control.Monad (Monad(..))
+import Control.Monad (Monad(..), replicateM_)
import Data.Function (($), (.), id)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
import System.IO (IO)
import Text.Show (Show(..))
-import qualified Data.List as L
-import qualified Data.Text as T
import qualified Data.Text.IO as T
+import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.IO as TL
import qualified Data.Text.Lazy.Builder as TLB
import qualified System.IO as IO
@@ -26,15 +25,16 @@ instance IsString Plain where
plain :: Plain -> TLB.Builder
plain (Plain d) = d
+
instance Semigroup Plain where
Plain x <> Plain y = Plain (x <> y)
instance Monoid Plain where
mempty = empty
mappend = (<>)
instance Doc_Text Plain where
- spaces i = Plain $ TLB.fromText $ T.replicate i " "
int = Plain . fromString . show
integer = Plain . fromString . show
+ replicate i = Plain . TLB.fromLazyText . TL.replicate (int64OfInt i) . TLB.toLazyText . plain
char = Plain . TLB.singleton
string = Plain . fromString
text = Plain . TLB.fromText
@@ -98,53 +98,53 @@ instance Monoid PlainIO where
mempty = empty
mappend = (<>)
instance Doc_Text PlainIO where
- empty = PlainIO $ \_ -> return ()
- spaces i = PlainIO $ \h -> IO.hPutStr h (L.replicate i ' ')
- int i = PlainIO $ \h -> IO.hPutStr h (show i)
- integer i = PlainIO $ \h -> IO.hPutStr h (show i)
- char x = PlainIO $ \h -> IO.hPutChar h x
- string x = PlainIO $ \h -> IO.hPutStr h x
- text x = PlainIO $ \h -> T.hPutStr h x
- ltext x = PlainIO $ \h -> TL.hPutStr h x
- charH = char
- stringH = string
- textH = text
- ltextH = ltext
+ empty = PlainIO $ \_ -> return ()
+ int i = PlainIO $ \h -> IO.hPutStr h (show i)
+ integer i = PlainIO $ \h -> IO.hPutStr h (show i)
+ replicate i d = PlainIO $ replicateM_ i . plainIO d
+ char x = PlainIO $ \h -> IO.hPutChar h x
+ string x = PlainIO $ \h -> IO.hPutStr h x
+ text x = PlainIO $ \h -> T.hPutStr h x
+ ltext x = PlainIO $ \h -> TL.hPutStr h x
+ charH = char
+ stringH = string
+ textH = text
+ ltextH = ltext
instance Doc_Color PlainIO where
- reverse = id
- black = id
- red = id
- green = id
- yellow = id
- blue = id
- magenta = id
- cyan = id
- white = id
- blacker = id
- redder = id
- greener = id
- yellower = id
- bluer = id
- magentaer = id
- cyaner = id
- whiter = id
- onBlack = id
- onRed = id
- onGreen = id
- onYellow = id
- onBlue = id
- onMagenta = id
- onCyan = id
- onWhite = id
- onBlacker = id
- onRedder = id
- onGreener = id
- onYellower = id
- onBluer = id
- onMagentaer = id
- onCyaner = id
- onWhiter = id
+ reverse = id
+ black = id
+ red = id
+ green = id
+ yellow = id
+ blue = id
+ magenta = id
+ cyan = id
+ white = id
+ blacker = id
+ redder = id
+ greener = id
+ yellower = id
+ bluer = id
+ magentaer = id
+ cyaner = id
+ whiter = id
+ onBlack = id
+ onRed = id
+ onGreen = id
+ onYellow = id
+ onBlue = id
+ onMagenta = id
+ onCyan = id
+ onWhite = id
+ onBlacker = id
+ onRedder = id
+ onGreener = id
+ onYellower = id
+ onBluer = id
+ onMagentaer = id
+ onCyaner = id
+ onWhiter = id
instance Doc_Decoration PlainIO where
- bold = id
- underline = id
- italic = id
+ bold = id
+ underline = id
+ italic = id
diff --git a/symantic-document/Language/Symantic/Document/Sym.hs b/symantic-document/Language/Symantic/Document/Sym.hs
index 4bde7ac..c90bf45 100644
--- a/symantic-document/Language/Symantic/Document/Sym.hs
+++ b/symantic-document/Language/Symantic/Document/Sym.hs
@@ -5,70 +5,80 @@ module Language.Symantic.Document.Sym where
import Data.Char (Char)
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
-import Data.Maybe (Maybe(..))
import Data.Function ((.))
import Data.Functor (Functor(..))
-import Data.Int (Int)
+import Data.Int (Int, Int64)
+import Data.Maybe (Maybe(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString)
import Data.Text (Text)
-import Prelude (Integer)
+import Prelude (Integer, fromInteger, toInteger)
import qualified Data.List as L
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
-- * Class 'Doc_Text'
class (IsString d, Semigroup d) => Doc_Text d where
- empty :: d
- eol :: d
- space :: d
- spaces :: Int -> d
- int :: Int -> d
- integer :: Integer -> d
- char :: Char -> d
- string :: String -> d
- text :: Text -> d
- ltext :: TL.Text -> d
- charH :: Char -> d -- XXX: MUST NOT be '\n'
- stringH :: String -> d -- XXX: MUST NOT contain '\n'
- textH :: Text -> d -- XXX: MUST NOT contain '\n'
- ltextH :: TL.Text -> d -- XXX: MUST NOT contain '\n'
- catH :: Foldable f => f d -> d
- catV :: Foldable f => f d -> d
- dquote :: d -> d
- fquote :: d -> d
- squote :: d -> d
- default spaces :: Doc_Text (ReprOf d) => Trans d => Int -> d
- default int :: Doc_Text (ReprOf d) => Trans d => Int -> d
- default integer :: Doc_Text (ReprOf d) => Trans d => Integer -> d
- default charH :: Doc_Text (ReprOf d) => Trans d => Char -> d
- default stringH :: Doc_Text (ReprOf d) => Trans d => String -> d
- default textH :: Doc_Text (ReprOf d) => Trans d => Text -> d
- default ltextH :: Doc_Text (ReprOf d) => Trans d => TL.Text -> d
- -- default catH :: Doc_Text (ReprOf d) => Trans d => Foldable f => Functor f => f d -> d
- -- default catV :: Doc_Text (ReprOf d) => Trans d => Foldable f => Functor f => f d -> d
- empty = ""
- eol = "\n"
- space = " "
- spaces = trans . spaces
- int = trans . int
- integer = trans . integer
- char = \case '\n' -> eol; c -> charH c
- string = catV . fmap stringH . lines
- text = catV . fmap textH . lines
- ltext = catV . fmap ltextH . lines
- charH = trans . charH
- stringH = trans . stringH
- textH = trans . textH
- ltextH = trans . ltextH
+ charH :: Char -> d -- ^ XXX: MUST NOT be '\n'
+ stringH :: String -> d -- ^ XXX: MUST NOT contain '\n'
+ textH :: Text -> d -- ^ XXX: MUST NOT contain '\n'
+ ltextH :: TL.Text -> d -- ^ XXX: MUST NOT contain '\n'
+ replicate :: Int -> d -> d
+ integer :: Integer -> d
+ default charH :: Doc_Text (ReprOf d) => Trans d => Char -> d
+ default stringH :: Doc_Text (ReprOf d) => Trans d => String -> d
+ default textH :: Doc_Text (ReprOf d) => Trans d => Text -> d
+ default ltextH :: Doc_Text (ReprOf d) => Trans d => TL.Text -> d
+ default replicate :: Doc_Text (ReprOf d) => Trans d => Int -> d -> d
+ default integer :: Doc_Text (ReprOf d) => Trans d => Integer -> d
+ charH = trans . charH
+ stringH = trans . stringH
+ textH = trans . textH
+ ltextH = trans . ltextH
+ replicate = trans1 . replicate
+ integer = trans . integer
+
+ empty :: d
+ eol :: d
+ space :: d
+ spaces :: Int -> d
+ int :: Int -> d
+ char :: Char -> d
+ string :: String -> d
+ text :: Text -> d
+ ltext :: TL.Text -> d
+ catH :: Foldable f => f d -> d
+ catV :: Foldable f => f d -> d
+ paren :: d -> d
+ brace :: d -> d
+ bracket :: d -> d
+ bquote :: d -> d
+ dquote :: d -> d
+ fquote :: d -> d
+ squote :: d -> d
+
+ empty = ""
+ eol = "\n"
+ space = char ' '
+ spaces i = replicate i space
+ int = integer . toInteger
+ char = \case '\n' -> eol; c -> charH c
+ string = catV . fmap stringH . lines
+ text = catV . fmap textH . lines
+ ltext = catV . fmap ltextH . lines
+ catH = foldr (<>) empty
+ catV l = if null l then empty else foldr1 (\a acc -> a <> eol <> acc) l
+ paren d = charH '(' <> d <> charH ')'
+ brace d = charH '{' <> d <> charH '}'
+ bracket d = charH '[' <> d <> charH ']'
+ bquote d = charH '`' <> d <> charH '`'
+ dquote d = charH '\"' <> d <> charH '\"'
+ fquote d = "« " <> d <> " »"
+ squote d = charH '\'' <> d <> charH '\''
+ -- default catH :: Doc_Text (ReprOf d) => Trans d => Foldable f => Functor f => f d -> d
+ -- default catV :: Doc_Text (ReprOf d) => Trans d => Foldable f => Functor f => f d -> d
-- catH l = trans (catH (fmap unTrans l))
- catH = foldr (<>) empty
-- catV l = trans (catV (fmap unTrans l))
- catV l | null l = empty
- catV l = foldr1 (\a acc -> a <> eol <> acc) l
- dquote d = "\"" <> d <> "\""
- fquote d = "« " <> d <> " »"
- squote d = "'" <> d <> "'"
-- * Class 'Doc_Color'
class Doc_Color d where
@@ -245,7 +255,8 @@ instance SplitOnCharWithEmpty String where
lines :: SplitOnCharWithEmpty t => t -> [t]
lines = splitOnCharWithEmpty '\n'
-
+int64OfInt :: Int -> Int64
+int64OfInt = fromInteger . toInteger
{-
diff --git a/symantic-document/Language/Symantic/Document/Valid.hs b/symantic-document/Language/Symantic/Document/Valid.hs
index 97a995f..75852dc 100644
--- a/symantic-document/Language/Symantic/Document/Valid.hs
+++ b/symantic-document/Language/Symantic/Document/Valid.hs
@@ -31,7 +31,7 @@ valid = id
-- ** Type 'Error_Valid'
data Error_Valid
= Error_Valid_not_horizontal TL.Text
- | Error_Valid_negative_spaces Int
+ | Error_Valid_negative_replicate Int
deriving (Eq, Show)
instance Semigroup repr => Semigroup (Valid repr) where
@@ -56,22 +56,22 @@ instance Monad Valid where
Ok a >>= f = f a
KO e >>= _ = KO e
instance (Doc_Text repr, Semigroup repr) => Doc_Text (Valid repr) where
- spaces i | i < 0 = KO [Error_Valid_negative_spaces i]
- spaces i = Ok $ spaces i
- int = pure . int
- integer = pure . integer
- char = pure . char
- string = pure . string
- text = pure . text
- ltext = pure . ltext
- charH '\n' = KO [Error_Valid_not_horizontal $ TL.singleton '\n']
- charH c = Ok $ charH c
- stringH t | any (== '\n') t = KO [Error_Valid_not_horizontal $ fromString t]
- stringH t = Ok $ stringH t
- textH t | T.any (== '\n') t = KO [Error_Valid_not_horizontal $ TL.fromStrict t]
- textH t = Ok $ textH t
- ltextH t | TL.any (== '\n') t = KO [Error_Valid_not_horizontal t]
- ltextH t = Ok $ ltextH t
+ replicate i _ | i < 0 = KO [Error_Valid_negative_replicate i]
+ replicate i d = d >>= Ok . replicate i
+ int = pure . int
+ integer = pure . integer
+ char = pure . char
+ string = pure . string
+ text = pure . text
+ ltext = pure . ltext
+ charH '\n'= KO [Error_Valid_not_horizontal $ TL.singleton '\n']
+ charH c = Ok $ charH c
+ stringH t | any (== '\n') t = KO [Error_Valid_not_horizontal $ fromString t]
+ stringH t = Ok $ stringH t
+ textH t | T.any (== '\n') t = KO [Error_Valid_not_horizontal $ TL.fromStrict t]
+ textH t = Ok $ textH t
+ ltextH t | TL.any (== '\n') t = KO [Error_Valid_not_horizontal t]
+ ltextH t = Ok $ ltextH t
instance Doc_Color repr => Doc_Color (Valid repr) where
reverse = fmap reverse
black = fmap black
diff --git a/symantic-document/symantic-document.cabal b/symantic-document/symantic-document.cabal
index f876144..faaccbe 100644
--- a/symantic-document/symantic-document.cabal
+++ b/symantic-document/symantic-document.cabal
@@ -20,7 +20,7 @@ tested-with: GHC==8.0.2
-- PVP: +-+------- breaking API changes
-- | | +----- non-breaking API additions
-- | | | +--- code changes with no API change
-version: 0.0.0.20170621
+version: 0.0.0.20170623
source-repository head
location: git://git.autogeree.net/symantic
--
2.47.2