deriving (Eq,Show,Semigroup)
unWord :: Word d -> d
unWord (Word d) = d
-instance DocFrom [SGR] d => DocFrom [SGR] (Word d) where
- docFrom = Word . docFrom
+instance From [SGR] d => From [SGR] (Word d) where
+ from = Word . from
--- * Class 'DocFrom'
-class DocFrom a d where
- docFrom :: a -> d
- default docFrom :: DocFrom String d => Show a => a -> d
- docFrom = docFrom . show
-instance DocFrom (Line String) d => DocFrom Int d where
- docFrom = docFrom . Line . show
-instance DocFrom (Line String) d => DocFrom Integer d where
- docFrom = docFrom . Line . show
-instance DocFrom (Line String) d => DocFrom Natural d where
- docFrom = docFrom . Line . show
+-- * Class 'From'
+class From a d where
+ 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
+instance From (Line String) d => From Integer d where
+ from = from . Line . show
+instance From (Line String) d => From Natural d where
+ from = from . Line . show
-- String
-instance DocFrom Char String where
- docFrom = pure
-instance DocFrom String String where
- docFrom = id
-instance DocFrom Text String where
- docFrom = Text.unpack
-instance DocFrom TL.Text String where
- docFrom = TL.unpack
-instance DocFrom d String => DocFrom (Line d) String where
- docFrom = docFrom . unLine
-instance DocFrom d String => DocFrom (Word d) String where
- docFrom = docFrom . unWord
-instance DocFrom [SGR] String where
- docFrom = setSGRCode
+instance From Char String where
+ from = pure
+instance From String String where
+ from = id
+instance From Text String where
+ from = Text.unpack
+instance From TL.Text String where
+ from = TL.unpack
+instance From d String => From (Line d) String where
+ from = from . unLine
+instance From d String => From (Word d) String where
+ from = from . unWord
+instance From [SGR] String where
+ from = setSGRCode
-- Text
-instance DocFrom Char Text where
- docFrom = Text.singleton
-instance DocFrom String Text where
- docFrom = Text.pack
-instance DocFrom Text Text where
- docFrom = id
-instance DocFrom TL.Text Text where
- docFrom = TL.toStrict
-instance DocFrom d Text => DocFrom (Line d) Text where
- docFrom = docFrom . unLine
-instance DocFrom d Text => DocFrom (Word d) Text where
- docFrom = docFrom . unWord
-instance DocFrom [SGR] Text where
- docFrom = docFrom . setSGRCode
+instance From Char Text where
+ from = Text.singleton
+instance From String Text where
+ from = Text.pack
+instance From Text Text where
+ from = id
+instance From TL.Text Text where
+ from = TL.toStrict
+instance From d Text => From (Line d) Text where
+ from = from . unLine
+instance From d Text => From (Word d) Text where
+ from = from . unWord
+instance From [SGR] Text where
+ from = from . setSGRCode
-- TLB.Builder
-instance DocFrom Char TLB.Builder where
- docFrom = TLB.singleton
-instance DocFrom String TLB.Builder where
- docFrom = fromString
-instance DocFrom Text TLB.Builder where
- docFrom = TLB.fromText
-instance DocFrom TL.Text TLB.Builder where
- docFrom = TLB.fromLazyText
-instance DocFrom TLB.Builder TLB.Builder where
- docFrom = id
-instance DocFrom d TLB.Builder => DocFrom (Line d) TLB.Builder where
- docFrom = docFrom . unLine
-instance DocFrom d TLB.Builder => DocFrom (Word d) TLB.Builder where
- docFrom = docFrom . unWord
-instance DocFrom [SGR] TLB.Builder where
- docFrom = docFrom . setSGRCode
+instance From Char TLB.Builder where
+ from = TLB.singleton
+instance From String TLB.Builder where
+ from = fromString
+instance From Text TLB.Builder where
+ from = TLB.fromText
+instance From TL.Text TLB.Builder where
+ from = TLB.fromLazyText
+instance From TLB.Builder TLB.Builder where
+ from = id
+instance From d TLB.Builder => From (Line d) TLB.Builder where
+ from = from . unLine
+instance From d TLB.Builder => From (Word d) TLB.Builder where
+ from = from . unWord
+instance From [SGR] TLB.Builder where
+ from = from . setSGRCode
runTextBuilder :: TLB.Builder -> TL.Text
runTextBuilder = TLB.toLazyText
between :: Semigroup d => d -> d -> d -> d
between o c d = o<>d<>c
-parens :: Semigroup d => DocFrom (Word Char) d => d -> d
-parens = between (docFrom (Word '(')) (docFrom (Word ')'))
-braces :: Semigroup d => DocFrom (Word Char) d => d -> d
-braces = between (docFrom (Word '{')) (docFrom (Word '}'))
-brackets :: Semigroup d => DocFrom (Word Char) d => d -> d
-brackets = between (docFrom (Word '[')) (docFrom (Word ']'))
-angles :: Semigroup d => DocFrom (Word Char) d => d -> d
-angles = between (docFrom (Word '<')) (docFrom (Word '>'))
+parens :: Semigroup d => From (Word Char) d => d -> d
+parens = between (from (Word '(')) (from (Word ')'))
+braces :: Semigroup d => From (Word Char) d => d -> d
+braces = between (from (Word '{')) (from (Word '}'))
+brackets :: Semigroup d => From (Word Char) d => d -> d
+brackets = between (from (Word '[')) (from (Word ']'))
+angles :: Semigroup d => From (Word Char) d => d -> d
+angles = between (from (Word '<')) (from (Word '>'))
-- * Class 'Splitable'
class (Lengthable d, Monoid d) => Splitable d where
onWhiter = xmlSGR "onWhiter"
-- | For debugging purposes.
-xmlSGR :: Semigroup d => DocFrom String d => String -> d -> d
-xmlSGR newSGR s = docFrom ("<"<>newSGR<>">")<>s<>docFrom ("</"<>newSGR<>">")
+xmlSGR :: Semigroup d => From String d => String -> d -> d
+xmlSGR newSGR s = from ("<"<>newSGR<>">")<>s<>from ("</"<>newSGR<>">")
-- * Class 'Indentable'
class Spaceable d => Indentable d where
runAnsiText :: AnsiText d -> d
runAnsiText (AnsiText d) = (`runReader` []) d
-instance DocFrom Char d => DocFrom Char (AnsiText d) where
- docFrom = AnsiText . return . docFrom
-instance DocFrom String d => DocFrom String (AnsiText d) where
- docFrom = AnsiText . return . docFrom
-instance DocFrom Text d => DocFrom Text (AnsiText d) where
- docFrom = AnsiText . return . docFrom
-instance DocFrom TL.Text d => DocFrom TL.Text (AnsiText d) where
- docFrom = AnsiText . return . docFrom
-instance DocFrom s (AnsiText d) => DocFrom (Line s) (AnsiText d) where
- docFrom = docFrom . unLine
-instance DocFrom s (AnsiText d) => DocFrom (Word s) (AnsiText d) where
- docFrom = docFrom . unWord
-instance DocFrom String d => IsString (AnsiText d) where
- fromString = docFrom
+instance From Char d => From Char (AnsiText d) where
+ from = AnsiText . return . from
+instance From String d => From String (AnsiText d) where
+ from = AnsiText . return . from
+instance From Text d => From Text (AnsiText d) where
+ from = AnsiText . return . from
+instance From TL.Text d => From TL.Text (AnsiText d) where
+ from = AnsiText . return . from
+instance From s (AnsiText d) => From (Line s) (AnsiText d) where
+ from = from . unLine
+instance From s (AnsiText d) => From (Word s) (AnsiText d) where
+ from = from . unWord
+instance From String d => IsString (AnsiText d) where
+ fromString = from
instance Semigroup d => Semigroup (AnsiText d) where
AnsiText x <> AnsiText y = AnsiText $ liftA2 (<>) x y
instance Monoid d => Monoid (AnsiText d) where
newline = AnsiText $ return newline
space = AnsiText $ return space
spaces = AnsiText . return . spaces
-instance (Semigroup d, DocFrom [SGR] d) => Colorable16 (AnsiText d) where
+instance (Semigroup d, From [SGR] d) => Colorable16 (AnsiText d) where
reverse = ansiTextSGR $ SetSwapForegroundBackground True
black = ansiTextSGR $ SetColor Foreground Dull Black
red = ansiTextSGR $ SetColor Foreground Dull Red
onMagentaer = ansiTextSGR $ SetColor Background Vivid Magenta
onCyaner = ansiTextSGR $ SetColor Background Vivid Cyan
onWhiter = ansiTextSGR $ SetColor Background Vivid White
-instance (Semigroup d, DocFrom [SGR] d) => Decorable (AnsiText d) where
+instance (Semigroup d, From [SGR] d) => Decorable (AnsiText d) where
bold = ansiTextSGR $ SetConsoleIntensity BoldIntensity
underline = ansiTextSGR $ SetUnderlining SingleUnderline
italic = ansiTextSGR $ SetItalicized True
breakalt (AnsiText x) (AnsiText y) = AnsiText $ liftA2 breakalt x y
ansiTextSGR ::
- Semigroup d => DocFrom [SGR] d =>
+ Semigroup d => From [SGR] d =>
SGR -> AnsiText d -> AnsiText d
ansiTextSGR newSGR (AnsiText d) = AnsiText $ do
oldSGR <- ask
- (\m -> docFrom [newSGR] <> m <> docFrom (Reset:List.reverse oldSGR))
+ (\m -> from [newSGR] <> m <> from (Reset:List.reverse oldSGR))
<$> local (newSGR :) d
-- * Type 'PlainText'
runPlainText :: PlainText d -> d
runPlainText (PlainText d) = d
-instance DocFrom Char d => DocFrom Char (PlainText d) where
- docFrom = PlainText . docFrom
-instance DocFrom String d => DocFrom String (PlainText d) where
- docFrom = PlainText . docFrom
-instance DocFrom Text d => DocFrom Text (PlainText d) where
- docFrom = PlainText . docFrom
-instance DocFrom TL.Text d => DocFrom TL.Text (PlainText d) where
- docFrom = PlainText . docFrom
-instance DocFrom s (PlainText d) => DocFrom (Line s) (PlainText d) where
- docFrom = docFrom . unLine
-instance DocFrom s (PlainText d) => DocFrom (Word s) (PlainText d) where
- docFrom = docFrom . unWord
-instance DocFrom String d => IsString (PlainText d) where
- fromString = docFrom
+instance From Char d => From Char (PlainText d) where
+ from = PlainText . from
+instance From String d => From String (PlainText d) where
+ from = PlainText . from
+instance From Text d => From Text (PlainText d) where
+ from = PlainText . from
+instance From TL.Text d => From TL.Text (PlainText d) where
+ from = PlainText . from
+instance From s (PlainText d) => From (Line s) (PlainText d) where
+ from = from . unLine
+instance From s (PlainText d) => From (Word s) (PlainText d) where
+ from = from . unWord
+instance From String d => IsString (PlainText d) where
+ fromString = from
instance Semigroup d => Semigroup (PlainText d) where
PlainText x <> PlainText y = PlainText $ (<>) x y
instance Monoid d => Monoid (PlainText d) where
onMagentaer = plainTextSGR
onCyaner = plainTextSGR
onWhiter = plainTextSGR
-instance (Semigroup d, DocFrom [SGR] d) => Decorable (PlainText d) where
+instance (Semigroup d, From [SGR] d) => Decorable (PlainText d) where
bold = plainTextSGR
underline = plainTextSGR
italic = plainTextSGR
PlainChunk_Ignored{} -> True
PlainChunk_Word d -> nullLength d
PlainChunk_Spaces s -> s == 0
-instance DocFrom [SGR] d => DocFrom [SGR] (PlainChunk d) where
- docFrom sgr = PlainChunk_Ignored (docFrom sgr)
+instance From [SGR] d => From [SGR] (PlainChunk d) where
+ from sgr = PlainChunk_Ignored (from sgr)
runPlainChunk :: Spaceable d => PlainChunk d -> d
runPlainChunk = \case
Just width | width < newWidth ->
overflow $ k ((spaces n <>), newState) fits fits
_ -> k ((spaces n <>), newState) fits overflow
-instance (DocFrom (Word s) d, Semigroup d, Lengthable s) => DocFrom (Word s) (Plain d) where
- docFrom s = Plain $ \inh st@PlainState{..} k 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 wordLen = length s in
if wordLen <= 0
then k (id,st) fits overflow
then
let newState = st
{ plainState_buffer =
- PlainChunk_Word (Word (docFrom s)) :
+ PlainChunk_Word (Word (from s)) :
plainState_buffer
, plainState_bufferWidth = newBufferWidth
} in
} in
case plainInh_width inh of
Just width | width < newWidth ->
- overflow $ k ((docFrom s <>), newState) fits fits
- _ -> k ((docFrom s <>), newState) fits overflow
-instance (DocFrom (Word s) d, Lengthable s, Spaceable d, Splitable s) =>
- DocFrom (Line s) (Plain d) where
- docFrom =
+ 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 .
- (docFrom <$>) .
+ (from <$>) .
words .
unLine
instance Spaceable d => Indentable (Plain d) where
unPlain y inh st k fits overflow
)
-- String
-instance (DocFrom (Word String) d, Spaceable d) =>
- DocFrom String (Plain d) where
- docFrom =
+instance (From (Word String) d, Spaceable d) =>
+ From String (Plain d) where
+ from =
mconcat .
List.intersperse newline .
- (docFrom <$>) .
+ (from <$>) .
lines
-instance (DocFrom (Word String) d, Spaceable d) =>
+instance (From (Word String) d, Spaceable d) =>
IsString (Plain d) where
- fromString = docFrom
+ fromString = from
-- Text
-instance (DocFrom (Word Text) d, Spaceable d) =>
- DocFrom Text (Plain d) where
- docFrom =
+instance (From (Word Text) d, Spaceable d) =>
+ From Text (Plain d) where
+ from =
mconcat .
List.intersperse newline .
- (docFrom <$>) .
+ (from <$>) .
lines
-instance (DocFrom (Word TL.Text) d, Spaceable d) =>
- DocFrom TL.Text (Plain d) where
- docFrom =
+instance (From (Word TL.Text) d, Spaceable d) =>
+ From TL.Text (Plain d) where
+ from =
mconcat .
List.intersperse newline .
- (docFrom <$>) .
+ (from <$>) .
lines
-- Char
-instance (DocFrom (Word Char) d, Spaceable d) =>
- DocFrom Char (Plain d) where
- docFrom ' ' = breakspace
- docFrom '\n' = newline
- docFrom c = docFrom (Word c)
+instance (From (Word Char) d, Spaceable d) =>
+ From Char (Plain d) where
+ from ' ' = breakspace
+ from '\n' = newline
+ from c = from (Word c)
-instance (DocFrom [SGR] d, Semigroup d) => DocFrom [SGR] (Plain d) where
- docFrom sgr = Plain $ \inh st k ->
+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 (docFrom sgr) : plainState_buffer st})
- else k ((docFrom sgr <>), st)
+ then k (id, st {plainState_buffer = PlainChunk_Ignored (from sgr) : plainState_buffer st})
+ else k ((from sgr <>), st)
joinLine ::
Spaceable d =>
maxWidth = setWidth . Just
nestedAlign ::
- DocFrom (Line String) d =>
+ From (Line String) d =>
Spaceable d => Indentable d => Wrappable d =>
Int -> d
nestedAlign n = go 1
where
go i =
- docFrom (Line (show i)) <>
+ from (Line (show i)) <>
(if n <= i then mempty
else align (breakspace <> go (i+1)))
sourcephile / git / haskell / symantic-document.git / commitdiff