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