Hdoc/TCT/Write/Plain.hs

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