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  ,   state_indent   :: TL.Text
  64  ,   state_unindent :: Int
  65      -- ^ useful to shift everything to the left
  66  } deriving (Eq, Show)
  67 instance Default State where
  68         def = State
  69          { state_escape   = True
  70          , state_pos      = pos1
  71          , state_indent   = ""
  72          , state_unindent = 0
  73          }
  74
  75 -- | Set the starting 'Pos' of given 'State'
  76 -- by using the first 'cell_begin'.
  77 setStart :: Roots -> State -> State
  78 setStart ts st = st
  79          { state_unindent = pos_column - 1
  80          , state_pos      = pos1{pos_line}
  81          }
  82         where
  83         Pos{..} =
  84                 case Seq.viewl ts of
  85                  EmptyL -> pos1
  86                  Tree Cell{cell_begin} _ :< _ -> cell_begin
  87
  88 -- * Class 'Plainify'
  89 class Plainify a where
  90         plainify :: a -> Plain
  91 instance Plainify () where
  92         plainify = mempty
  93 instance Plainify Char where
  94         plainify = \case
  95          '\n' -> do
  96                 S.modify' $ \s@State{state_pos=Pos line _col, state_indent} ->
  97                         s{state_pos=Pos (line + 1) $ int $ TL.length state_indent + 1}
  98                 State{..} <- S.get
  99                 return $ TLB.singleton '\n' <> TLB.fromLazyText state_indent
 100          c -> do
 101                 S.modify' $ \s@State{state_pos=Pos line col} ->
 102                         s{state_pos=Pos line (col + 1)}
 103                 return $ TLB.singleton c
 104 instance Plainify String where
 105         plainify = foldMap plainify
 106 instance Plainify TL.Text where
 107         plainify t
 108          | TL.null t = mempty
 109          | otherwise =
 110                 let (h,ts) = TL.span (/='\n') t in
 111                 case TL.uncons ts of
 112                  Nothing -> do
 113                         S.modify' $ \s@State{state_pos=Pos line col} ->
 114                                 s{state_pos=Pos line (col + int (TL.length h))}
 115                         return $ TLB.fromLazyText h
 116                  Just (_n,ts') ->
 117                         return (TLB.fromLazyText h) <>
 118                          -- NOTE: useless to increment the pos_column for h,
 119                          --       since the following '\n' will reset the pos_column.
 120                         plainify '\n' <>
 121                         plainify ts'
 122 instance Plainify Pos where
 123         plainify new@(Pos lineNew colNew) = do
 124                 State
 125                  { state_pos=old@(Pos lineOld colOld)
 126                  , state_indent
 127                  } <- S.get
 128                 S.modify' $ \s -> s{state_pos=new}
 129                 return $ TLB.fromLazyText $
 130                         case lineNew`compare`lineOld of
 131                          GT -> lines <> state_indent <> hspaces
 132                                 where
 133                                 lines   = TL.replicate (int64 $ lineNew - lineOld) "\n"
 134                                 hspaces = TL.replicate (int64 (colNew - 1) - TL.length state_indent) " "
 135                          EQ | colNew >= colOld ->
 136                                 TL.replicate (int64 $ colNew - colOld) " "
 137                          _ -> error $ "plainify: non-ascending Pos:"
 138                                  <> "\n old: " <> show old
 139                                  <> "\n new: " <> show new
 140 instance Plainify Roots where
 141         plainify = foldMap plainify
 142 instance Plainify Root where
 143         plainify (Tree (Cell bp _ep nod) ts) =
 144                 plainify bp <>
 145                 case nod of
 146                  NodeGroup -> plainify ts
 147                 --
 148                  NodeLower n as -> "<" <> plainify n <> plainify as <> plainify ts
 149                 --
 150                  NodeHeader hdr ->
 151                         case hdr of
 152                          HeaderGreat{} -> repeatHeader
 153                          HeaderBar{}   -> repeatHeader
 154                          _ -> plainify hdr <> plainify ts
 155                         where
 156                         repeatHeader = do
 157                                 State{..} <- S.get
 158                                 h <- plainify hdr
 159                                 S.modify' $ \s -> s{state_indent =
 160                                         state_indent <>
 161                                         TL.replicate (int64 (pos_column bp - 1) - TL.length state_indent) " " <>
 162                                         TLB.toLazyText h
 163                                  }
 164                                 r <- plainify ts
 165                                 S.modify' $ \s -> s{state_indent}
 166                                 return $ h <> r
 167                 --
 168                  NodeText t -> do
 169                         State{..} <- S.get
 170                         S.modify' $ \s -> s{state_indent =
 171                                 state_indent <>
 172                                 TL.replicate (int64 (pos_column bp - 1) - TL.length state_indent) " "
 173                          }
 174                         r <- plainify t
 175                         S.modify' $ \s -> s{state_indent}
 176                         return r
 177                  {-
 178                  NodeText t -> plainify t
 179                  -}
 180                 --
 181                  NodePara -> do
 182                         State{..} <- S.get
 183                         S.modify' $ \s -> s{state_indent =
 184                                 state_indent <>
 185                                 TL.replicate (int64 (pos_column bp - 1) - TL.length state_indent) " "
 186                          }
 187                         r <- plainify ts
 188                         S.modify' $ \s -> s{state_indent}
 189                         return r
 190                 --
 191                  NodeToken t -> plainify t <> plainify ts
 192                 --
 193                  NodePair p ->
 194                         plainify o <> plainify ts <> plainify c
 195                         where (o,c) = pairBorders p ts
 196 instance Plainify Header where
 197         plainify hdr =
 198                 case hdr of
 199                  HeaderColon n wh  -> plainify n <> plainify wh <> ":"
 200                  HeaderGreat n wh  -> plainify n <> plainify wh <> ">"
 201                  HeaderEqual n wh  -> plainify n <> plainify wh <> "="
 202                  HeaderBar   n wh  -> plainify n <> plainify wh <> "|"
 203                  HeaderDot   n     -> plainify n <> "."
 204                  HeaderBrackets n  -> "[" <> plainify n <> "]"
 205                  HeaderDash        -> "- "
 206                  HeaderDashDash    -> "-- "
 207                  HeaderSection lvl -> plainify (List.replicate lvl '#')
 208                  HeaderDotSlash n  -> "./" <> plainify n
 209 instance Plainify Token where
 210         plainify = \case
 211          TokenText t -> plainify t
 212          TokenTag  t -> plainify '#' <> plainify t
 213          TokenLink l -> plainify l
 214          TokenEscape c -> do
 215                 esc <- S.gets state_escape
 216                 if esc
 217                  then plainify ['\\', c]
 218                  else plainify c
 219 instance Plainify ElemAttrs where
 220         plainify = foldMap plainify
 221 instance Plainify (White,ElemAttr) where
 222         plainify (elemAttr_white,ElemAttr{..}) =
 223                 mconcat $ plainify <$>
 224                  [ elemAttr_white
 225                  , elemAttr_name
 226                  , elemAttr_open
 227                  , elemAttr_value
 228                  , elemAttr_close
 229                  ]
 230
 231 {-
 232 -- * Class 'RackUpLeft'
 233 class RackUpLeft a where
 234         rackUpLeft :: a -> S.State (Maybe Pos) a
 235 instance RackUpLeft Pos where
 236         rackUpLeft pos@Pos{..} = do
 237                 S.get >>= \case
 238                  Nothing -> return pos
 239                  Just (Pos l0 c0) ->
 240                         return Pos
 241                          { pos_line   = pos_line   - l0 + 1
 242                          , pos_column = pos_column - c0 + 1
 243                          }
 244 instance RackUpLeft (Cell a) where
 245         rackUpLeft (Cell bp ep a) = do
 246                 S.modify' $ \case
 247                  Nothing -> Just bp
 248                  p -> p
 249                 Cell
 250                  <$> rackUpLeft bp
 251                  <*> rackUpLeft ep
 252                  <*> pure a
 253 instance RackUpLeft a => RackUpLeft (Seq a) where
 254         rackUpLeft = mapM rackUpLeft
 255 instance RackUpLeft a => RackUpLeft (Tree a) where
 256         rackUpLeft (Tree n ts) =
 257                 Tree
 258                  <$> rackUpLeft n
 259                  <*> rackUpLeft ts
 260 -}