-- * Class 'Indentable'
class Spaceable repr => Indentable repr where
- -- | @('align' doc)@ make @doc@ uses current 'Column' as 'Indent' level.
+ -- | @('align' fmt)@ make @fmt@ uses current 'Column' as 'Indent' level.
align :: repr a -> repr a
- -- | @('setIndent' p ind doc)@ make @doc@ uses @ind@ as 'Indent' level.
+ -- | @('setIndent' p ind fmt)@ make @fmt@ uses @ind@ as 'Indent' level.
-- Using @p@ as 'Indent' text.
setIndent :: repr () -> Indent -> repr a -> repr a
- -- | @('incrIndent' p ind doc)@ make @doc@ uses current 'Indent' plus @ind@ as 'Indent' level.
+ -- | @('incrIndent' p ind fmt)@ make @fmt@ uses current 'Indent' plus @ind@ as 'Indent' level.
-- Appending @p@ to the current 'Indent' text.
incrIndent :: repr () -> Indent -> repr a -> repr a
hang :: Indent -> repr a -> repr a
hang ind = align . incrIndent (spaces ind) ind
- -- | @('fill' w doc)@ write @doc@,
- -- then if @doc@ is not wider than @w@,
+ -- | @('fill' w fmt)@ write @fmt@,
+ -- then if @fmt@ is not wider than @w@,
-- write the difference with 'spaces'.
fill :: Width -> repr a -> repr a
- -- | @('fillOrBreak' w doc)@ write @doc@,
- -- then if @doc@ is not wider than @w@, write the difference with 'spaces'
- -- otherwise write a 'newline' indented to to the start 'Column' of @doc@ plus @w@.
+ -- | @('fillOrBreak' w fmt)@ write @fmt@,
+ -- then if @fmt@ is not wider than @w@, write the difference with 'spaces'
+ -- otherwise write a 'newline' indented to the start 'Column' of @fmt@ plus @w@.
fillOrBreak :: Width -> repr a -> repr a
default align :: FromDerived1 Indentable repr => repr a -> repr a
-- ReaderT PlainInh (StateT (PlainState o) (Cont (PlainFit o))) (o->o)
}
+runPlain :: Monoid o => Plain o a -> a -> o
+runPlain x a =
+ unPlain x a
+ defPlainInh
+ defPlainState
+ {-k-}(\(px,_sx) fits _overflow ->
+ -- NOTE: if px fits, then appending mempty fits
+ fits (px mempty) )
+ {-fits-}id
+ {-overflow-}id
+
instance Semigroup o => ProductFunctor (Plain o) where
x <.> y = Plain $ \(a,b) inh st k ->
unPlain x a inh st $ \(px,sx) ->
(wordPlain <$>) .
words <$>
) . lines
---intersperse sep = concat . List.intersperse sep
+
instance (Convertible String o, Outputable o) => Inferable Int (Plain o) where
infer = showWordPlain
instance (Convertible String o, Outputable o) => Inferable Natural (Plain o) where
($ ()) . unPlain . wordPlain .
Word . show
-runPlain :: Monoid o => Plain o a -> a -> o
-runPlain x a =
- unPlain x a
- defPlainInh
- defPlainState
- {-k-}(\(px,_sx) fits _overflow ->
- -- NOTE: if px fits, then appending mempty fits
- fits (px mempty) )
- {-fits-}id
- {-overflow-}id
-
-- ** Type 'PlainState'
data PlainState o = PlainState
{ plainState_buffer :: ![PlainChunk o]
} in
case plainInh_width inh of
Just maxWidth | maxWidth < newWidth ->
- overflow $ k (id, newState) fits overflow
+ overflow $ k (id, newState) fits overflow
_ -> k (id, newState) fits overflow
else
let newState = st
align p = (flushlinePlain .>) $ Plain $ \a inh st ->
let col = plainState_bufferStart st + plainState_bufferWidth st in
unPlain p a inh
- { plainInh_indent = col
+ { plainInh_indent = col
, plainInh_indenting =
- if plainInh_indent inh <= col
- then
- plainInh_indenting inh .>
- spaces (col`minusNatural`plainInh_indent inh)
- else spaces col
+ if plainInh_indent inh <= col
+ then
+ plainInh_indenting inh .>
+ spaces (col`minusNatural`plainInh_indent inh)
+ else spaces col
} st
setIndent o i p = Plain $ \a inh ->
unPlain p a inh
PlainInh o -> PlainState o -> o
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 length 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)
+ 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 length 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 = 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
+ [] -> 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,
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)
sourcephile / git / haskell / symantic-document.git / commitdiff