Hdoc/TCT/Write/Plain.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4 module Hdoc.TCT.Write.Plain where
   5
   6 import Control.Applicative (liftA2)
   7 import Control.Monad (Monad(..))
   8 import Data.Bool
   9 import Data.Char (Char)
  10 import Data.Default.Class (Default(..))
  11 import Data.Eq (Eq(..))
  12 import Data.Foldable (Foldable(..))
  13 import Data.Function (($))
  14 import Data.Functor ((<$>))
  15 import Data.Int (Int)
  16 import Data.List.NonEmpty (NonEmpty(..))
  17 import Data.Maybe (Maybe(..))
  18 import Data.Monoid (Monoid(..))
  19 import Data.Ord (Ord(..), Ordering(..))
  20 import Data.Semigroup (Semigroup(..))
  21 import Data.Sequence (ViewL(..))
  22 import Data.String (String, IsString(..))
  23 import Prelude (Num(..), error)
  24 import Text.Show (Show(..))
  25 import qualified Control.Monad.Trans.State as S
  26 import qualified Data.List as List
  27 import qualified Data.Text.Lazy as TL
  28 import qualified Data.Text.Lazy.Builder as TLB
  29 import qualified Data.Sequence as Seq
  30
  31 import Hdoc.TCT
  32 import Hdoc.TCT.Utils
  33 -- import Hdoc.TCT.Debug
  34
  35 writePlain :: Roots -> TL.Text
  36 writePlain doc = text (setStart doc def) doc
  37
  38 -- * Type 'Plain'
  39 type Plain = S.State State TLB.Builder
  40  -- NOTE: To get maximum performance when building lazy Text values using a builder,
  41  --       associate mappend calls to the right.
  42  -- NOTE: (Semigroup.<>) associates to the right.
  43 instance IsString Plain where
  44         fromString = plainify
  45 instance Semigroup Plain where
  46         (<>) = liftA2 (<>)
  47 instance Monoid Plain where
  48         mempty  = return ""
  49         mappend = (<>)
  50
  51 runPlain :: Plain -> State -> TL.Text
  52 runPlain p s = TLB.toLazyText $ S.evalState p s
  53
  54 text :: Plainify a => State -> a -> TL.Text
  55 text s a = runPlain (plainify a) s
  56
  57 -- ** Type 'State'
  58 data State
  59  =   State
  60  {   state_escape   :: Bool -- FIXME: useful?
  61  ,   state_pos      :: Pos
  62      -- ^ current position,
  63      -- always in sync annotated 'Pos' of the input,
  64      -- not with the output (whose colmuns may be shifted left by 'state_unindent')
  65  ,   state_indent   :: TL.Text
  66      -- ^ indentation, which contain horizontal spaces,
  67      -- but also any repeated prefix introduced by 'HeaderBar' or 'HeaderGreat'
  68  ,   state_unindent :: Int
  69      -- ^ initial 'pos_column' set by 'setStart',
  70      -- useful to shift everything to the left
  71  } deriving (Eq, Show)
  72 instance Default State where
  73         def = State
  74          { state_escape   = True
  75          , state_pos      = pos1
  76          , state_indent   = ""
  77          , state_unindent = 1
  78          }
  79
  80 -- | Set the starting 'Pos' of given 'State'
  81 -- by using the first 'cell_begin'.
  82 setStart :: Roots -> State -> State
  83 setStart ts st = st
  84          { state_pos      = pos
  85          , state_unindent = pos_column pos
  86          }
  87         where pos =
  88                 case Seq.viewl ts of
  89                  EmptyL -> pos1
  90                  Tree (Cell (Span{span_begin}:|_) _) _ :< _ -> span_begin
  91
  92 -- * Class 'Plainify'
  93 class Plainify a where
  94         plainify :: a -> Plain
  95 instance Plainify () where
  96         plainify = mempty
  97 instance Plainify Char where
  98         plainify = \case
  99          '\n' -> do
 100                 S.modify' $ \s@State{state_pos=Pos line _col, state_indent, state_unindent} ->
 101                         s{state_pos=Pos (line + 1) $ state_unindent + int (TL.length state_indent)}
 102                 State{..} <- S.get
 103                 return $ TLB.singleton '\n' <> TLB.fromLazyText state_indent
 104          c -> do
 105                 S.modify' $ \s@State{state_pos=Pos line col} ->
 106                         s{state_pos=Pos line (col + 1)}
 107                 return $ TLB.singleton c
 108 instance Plainify String where
 109         plainify = foldMap plainify
 110 instance Plainify TL.Text where
 111         plainify t
 112          | TL.null t = mempty
 113          | otherwise =
 114                 let (h,ts) = TL.span (/='\n') t in
 115                 case TL.uncons ts of
 116                  Nothing -> do
 117                         S.modify' $ \s@State{state_pos=Pos line col} ->
 118                                 s{state_pos=Pos line $ col + int (TL.length h)}
 119                         return $ TLB.fromLazyText h
 120                  Just (_n,ts') ->
 121                         return (TLB.fromLazyText h) <>
 122                          -- NOTE: useless to increment the pos_column for h,
 123                          --       since the following '\n' will reset the pos_column.
 124                         plainify '\n' <>
 125                         plainify ts'
 126 instance Plainify Pos where
 127         plainify new@(Pos lineNew colNew) = do
 128                 State
 129                  { state_pos=old@(Pos lineOld colOld)
 130                  , state_indent
 131                  , state_unindent
 132                  } <- S.get
 133                 S.modify' $ \s -> s{state_pos=new}
 134                 return $ TLB.fromLazyText $
 135                         case lineNew`compare`lineOld of
 136                          GT -> lines <> state_indent <> hspaces
 137                                 where
 138                                 lines   = TL.replicate (int64 $ lineNew - lineOld) "\n"
 139                                 hspaces = TL.replicate (int64 (colNew - state_unindent) - TL.length state_indent) " "
 140                          EQ | colNew >= colOld ->
 141                                 TL.replicate (int64 $ colNew - colOld) " "
 142                          _ -> error $ "plainify: non-ascending Pos:"
 143                                  <> "\n old: " <> show old
 144                                  <> "\n new: " <> show new
 145 instance Plainify Roots where
 146         plainify = foldMap plainify
 147 instance Plainify Root where
 148         plainify (Tree (Cell (Span{span_begin=bp}:|_) nod) ts) =
 149                 plainify bp <>
 150                 case nod of
 151                 ----------------------
 152                  NodeLower n as -> "<" <> plainify n <> plainify as <> plainify ts
 153                 ----------------------
 154                  NodeHeader hdr ->
 155                         case hdr of
 156                          HeaderGreat{}    -> plainHeaderRepeated
 157                          HeaderBar{}      -> plainHeaderRepeated
 158                          HeaderDotSlash{} -> plainify hdr
 159                          _ -> plainify hdr <> plainify ts
 160                         where
 161                         plainHeaderRepeated = do
 162                                 State{..} <- S.get
 163                                 h <- plainify hdr
 164                                 S.modify' $ \s -> s{state_indent =
 165                                         state_indent <>
 166                                         TL.replicate (int64 (pos_column bp - state_unindent) - TL.length state_indent) " " <>
 167                                         TLB.toLazyText h
 168                                  }
 169                                 r <- plainify ts
 170                                 S.modify' $ \s -> s{state_indent}
 171                                 return $ h <> r
 172                 ----------------------
 173                  NodeText t -> do
 174                         State{..} <- S.get
 175                         S.modify' $ \s -> s{state_indent =
 176                                 state_indent <>
 177                                 TL.replicate (int64 (pos_column bp - state_unindent) - TL.length state_indent) " "
 178                          }
 179                         r <- plainify t
 180                         S.modify' $ \s -> s{state_indent}
 181                         return r
 182                 ----------------------
 183                  NodePara -> do
 184                         State{..} <- S.get
 185                         S.modify' $ \s -> s{state_indent =
 186                                 state_indent <>
 187                                 TL.replicate (int64 (pos_column bp - state_unindent) - TL.length state_indent) " "
 188                          }
 189                         r <- plainify ts
 190                         S.modify' $ \s -> s{state_indent}
 191                         return r
 192                 ----------------------
 193                  NodeToken t -> plainify t <> plainify ts
 194                 ----------------------
 195                  NodePair p ->
 196                         plainify o <> plainify ts <> plainify c
 197                         where (o,c) = pairBorders p ts
 198 instance Plainify Header where
 199         plainify hdr =
 200                 case hdr of
 201                  HeaderColon n wh  -> plainify n <> plainify wh <> ":"
 202                  HeaderGreat n wh  -> plainify n <> plainify wh <> ">"
 203                  HeaderEqual n wh  -> plainify n <> plainify wh <> "="
 204                  HeaderBar   n wh  -> plainify n <> plainify wh <> "|"
 205                  HeaderDot   n     -> plainify n <> "."
 206                  HeaderBrackets n  -> "[" <> plainify n <> "]"
 207                  HeaderDash        -> "- "
 208                  HeaderDashDash    -> "-- "
 209                  HeaderSection lvl -> plainify (List.replicate lvl '#')
 210                  HeaderDotSlash n  -> plainify n
 211 instance Plainify Token where
 212         plainify = \case
 213          TokenText t -> plainify t
 214          TokenTag  t -> plainify '#' <> plainify t
 215          TokenLink l -> plainify l
 216          TokenEscape c -> do
 217                 esc <- S.gets state_escape
 218                 if esc
 219                  then plainify ['\\', c]
 220                  else plainify c
 221 instance Plainify ElemAttrs where
 222         plainify = foldMap plainify
 223 instance Plainify (White,ElemAttr) where
 224         plainify (elemAttr_white,ElemAttr{..}) =
 225                 mconcat $ plainify <$>
 226                  [ elemAttr_white
 227                  , elemAttr_name
 228                  , elemAttr_open
 229                  , elemAttr_value
 230                  , elemAttr_close
 231                  ]
 232
 233 {-
 234 -- * Class 'RackUpLeft'
 235 class RackUpLeft a where
 236         rackUpLeft :: a -> S.State (Maybe Pos) a
 237 instance RackUpLeft Pos where
 238         rackUpLeft pos@Pos{..} = do
 239                 S.get >>= \case
 240                  Nothing -> return pos
 241                  Just (Pos l0 c0) ->
 242                         return Pos
 243                          { pos_line   = pos_line   - l0 + 1
 244                          , pos_column = pos_column - c0 + 1
 245                          }
 246 instance RackUpLeft (Cell a) where
 247         rackUpLeft (Cell bp ep a) = do
 248                 S.modify' $ \case
 249                  Nothing -> Just bp
 250                  p -> p
 251                 Cell
 252                  <$> rackUpLeft bp
 253                  <*> rackUpLeft ep
 254                  <*> pure a
 255 instance RackUpLeft a => RackUpLeft (Seq a) where
 256         rackUpLeft = mapM rackUpLeft
 257 instance RackUpLeft a => RackUpLeft (Tree a) where
 258         rackUpLeft (Tree n ts) =
 259                 Tree
 260                  <$> rackUpLeft n
 261                  <*> rackUpLeft ts
 262 -}