Language/TCT/Write/Plain.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE ViewPatterns #-}
   4 {-# OPTIONS_GHC -fno-warn-orphans #-}
   5 module Language.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.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 Data.Tuple (fst)
  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.Text.Lazy as TL
  29 import qualified Data.Text.Lazy.Builder as TLB
  30 import qualified Data.Sequence as Seq
  31
  32 import Language.TCT
  33 import Language.TCT.Utils
  34 -- import Language.TCT.Debug
  35
  36 -- * Type 'Plain'
  37 type Plain = S.State State TLB.Builder
  38  -- NOTE: To get maximum performance when building lazy Text values using a builder,
  39  --       associate mappend calls to the right.
  40  -- NOTE: (Semigroup.<>) associates to the right.
  41 instance IsString Plain where
  42         fromString = plainify
  43 instance Semigroup Plain where
  44         (<>) = liftA2 (<>)
  45 instance Monoid Plain where
  46         mempty  = return ""
  47         mappend = (<>)
  48
  49 runPlain :: Plain -> State -> TL.Text
  50 runPlain p s = TLB.toLazyText $ fst $ S.runState p s
  51
  52 text :: Plainify a => State -> a -> TL.Text
  53 text s a = runPlain (plainify a) s
  54
  55 plainDocument :: Roots -> TL.Text
  56 plainDocument doc = text (setStart doc def) doc
  57
  58 -- ** Type 'State'
  59 data State
  60  =   State
  61  {   state_escape   :: Bool -- FIXME: useful?
  62  ,   state_pos      :: Pos
  63      -- ^ current position,
  64      -- always in sync annotated 'Pos' 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 'pos_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 'Pos' 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 = pos_column pos
  87          }
  88         where pos =
  89                 case Seq.viewl ts of
  90                  EmptyL -> pos1
  91                  Tree Cell{cell_begin} _ :< _ -> cell_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=Pos line _col, state_indent, state_unindent} ->
 102                         s{state_pos=Pos (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=Pos line col} ->
 107                         s{state_pos=Pos 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=Pos line col} ->
 119                                 s{state_pos=Pos 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 pos_column for h,
 124                          --       since the following '\n' will reset the pos_column.
 125                         plainify '\n' <>
 126                         plainify ts'
 127 instance Plainify Pos where
 128         plainify new@(Pos lineNew colNew) = do
 129                 State
 130                  { state_pos=old@(Pos 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 Pos:"
 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 (Cell bp _ep nod) ts) =
 150                 plainify bp <>
 151                 case nod of
 152                 ----------------------
 153                  NodeGroup -> plainify ts
 154                 ----------------------
 155                  NodeLower n as -> "<" <> plainify n <> plainify as <> plainify ts
 156                 ----------------------
 157                  NodeHeader hdr ->
 158                         case hdr of
 159                          HeaderGreat{} -> plainHeaderRepeated
 160                          HeaderBar{}   -> plainHeaderRepeated
 161                          _ -> plainify hdr <> plainify ts
 162                         where
 163                         plainHeaderRepeated = do
 164                                 State{..} <- S.get
 165                                 h <- plainify hdr
 166                                 S.modify' $ \s -> s{state_indent =
 167                                         state_indent <>
 168                                         TL.replicate (int64 (pos_column bp - state_unindent) - TL.length state_indent) " " <>
 169                                         TLB.toLazyText h
 170                                  }
 171                                 r <- plainify ts
 172                                 S.modify' $ \s -> s{state_indent}
 173                                 return $ h <> r
 174                 ----------------------
 175                  NodeText t -> do
 176                         State{..} <- S.get
 177                         S.modify' $ \s -> s{state_indent =
 178                                 state_indent <>
 179                                 TL.replicate (int64 (pos_column bp - state_unindent) - TL.length state_indent) " "
 180                          }
 181                         r <- plainify t
 182                         S.modify' $ \s -> s{state_indent}
 183                         return r
 184                 ----------------------
 185                  NodePara -> do
 186                         State{..} <- S.get
 187                         S.modify' $ \s -> s{state_indent =
 188                                 state_indent <>
 189                                 TL.replicate (int64 (pos_column bp - state_unindent) - TL.length state_indent) " "
 190                          }
 191                         r <- plainify ts
 192                         S.modify' $ \s -> s{state_indent}
 193                         return r
 194                 ----------------------
 195                  NodeToken t -> plainify t <> plainify ts
 196                 ----------------------
 197                  NodePair p ->
 198                         plainify o <> plainify ts <> plainify c
 199                         where (o,c) = pairBorders p ts
 200 instance Plainify Header where
 201         plainify hdr =
 202                 case hdr of
 203                  HeaderColon n wh  -> plainify n <> plainify wh <> ":"
 204                  HeaderGreat n wh  -> plainify n <> plainify wh <> ">"
 205                  HeaderEqual n wh  -> plainify n <> plainify wh <> "="
 206                  HeaderBar   n wh  -> plainify n <> plainify wh <> "|"
 207                  HeaderDot   n     -> plainify n <> "."
 208                  HeaderBrackets n  -> "[" <> plainify n <> "]"
 209                  HeaderDash        -> "- "
 210                  HeaderDashDash    -> "-- "
 211                  HeaderSection lvl -> plainify (List.replicate lvl '#')
 212                  HeaderDotSlash n  -> "./" <> plainify n
 213 instance Plainify Token where
 214         plainify = \case
 215          TokenText t -> plainify t
 216          TokenTag  t -> plainify '#' <> plainify t
 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 ElemAttrs where
 224         plainify = foldMap plainify
 225 instance Plainify (White,ElemAttr) where
 226         plainify (elemAttr_white,ElemAttr{..}) =
 227                 mconcat $ plainify <$>
 228                  [ elemAttr_white
 229                  , elemAttr_name
 230                  , elemAttr_open
 231                  , elemAttr_value
 232                  , elemAttr_close
 233                  ]
 234
 235 {-
 236 -- * Class 'RackUpLeft'
 237 class RackUpLeft a where
 238         rackUpLeft :: a -> S.State (Maybe Pos) a
 239 instance RackUpLeft Pos where
 240         rackUpLeft pos@Pos{..} = do
 241                 S.get >>= \case
 242                  Nothing -> return pos
 243                  Just (Pos l0 c0) ->
 244                         return Pos
 245                          { pos_line   = pos_line   - l0 + 1
 246                          , pos_column = pos_column - c0 + 1
 247                          }
 248 instance RackUpLeft (Cell a) where
 249         rackUpLeft (Cell bp ep a) = do
 250                 S.modify' $ \case
 251                  Nothing -> Just bp
 252                  p -> p
 253                 Cell
 254                  <$> rackUpLeft bp
 255                  <*> rackUpLeft ep
 256                  <*> pure a
 257 instance RackUpLeft a => RackUpLeft (Seq a) where
 258         rackUpLeft = mapM rackUpLeft
 259 instance RackUpLeft a => RackUpLeft (Tree a) where
 260         rackUpLeft (Tree n ts) =
 261                 Tree
 262                  <$> rackUpLeft n
 263                  <*> rackUpLeft ts
 264 -}