Language/TCT/Write/Plain.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4 module Language.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.Maybe (Maybe(..))
  17 import Data.Monoid (Monoid(..))
  18 import Data.Ord (Ord(..), Ordering(..))
  19 import Data.Semigroup (Semigroup(..))
  20 import Data.Sequence (ViewL(..))
  21 import Data.String (String, IsString(..))
  22 import Prelude (Num(..), error)
  23 import Text.Show (Show(..))
  24 import qualified Control.Monad.Trans.State as S
  25 import qualified Data.List as List
  26 import qualified Data.Text.Lazy as TL
  27 import qualified Data.Text.Lazy.Builder as TLB
  28 import qualified Data.Sequence as Seq
  29
  30 import Language.TCT
  31 import Language.TCT.Utils
  32 -- import Language.TCT.Debug
  33
  34 -- * Type 'Plain'
  35 type Plain = S.State State TLB.Builder
  36  -- NOTE: To get maximum performance when building lazy Text values using a builder,
  37  --       associate mappend calls to the right.
  38  -- NOTE: (Semigroup.<>) associates to the right.
  39 instance IsString Plain where
  40         fromString = plainify
  41 instance Semigroup Plain where
  42         (<>) = liftA2 (<>)
  43 instance Monoid Plain where
  44         mempty  = return ""
  45         mappend = (<>)
  46
  47 runPlain :: Plain -> State -> TL.Text
  48 runPlain p s = TLB.toLazyText $ S.evalState p s
  49
  50 text :: Plainify a => State -> a -> TL.Text
  51 text s a = runPlain (plainify a) s
  52
  53 document :: Roots -> TL.Text
  54 document doc = text (setStart doc def) doc
  55
  56 -- ** Type 'State'
  57 data State
  58  =   State
  59  {   state_escape   :: Bool -- FIXME: useful?
  60  ,   state_pos      :: Pos
  61      -- ^ current position,
  62      -- always in sync annotated 'Pos' of the input,
  63      -- not with the output (whose colmuns may be shifted left by 'state_unindent')
  64  ,   state_indent   :: TL.Text
  65      -- ^ indentation, which contain horizontal spaces,
  66      -- but also any repeated prefix introduced by 'HeaderBar' or 'HeaderGreat'
  67  ,   state_unindent :: Int
  68      -- ^ initial 'pos_column' set by 'setStart',
  69      -- useful to shift everything to the left
  70  } deriving (Eq, Show)
  71 instance Default State where
  72         def = State
  73          { state_escape   = True
  74          , state_pos      = pos1
  75          , state_indent   = ""
  76          , state_unindent = 1
  77          }
  78
  79 -- | Set the starting 'Pos' of given 'State'
  80 -- by using the first 'cell_begin'.
  81 setStart :: Roots -> State -> State
  82 setStart ts st = st
  83          { state_pos      = pos
  84          , state_unindent = pos_column pos
  85          }
  86         where pos =
  87                 case Seq.viewl ts of
  88                  EmptyL -> pos1
  89                  Tree Cell{cell_begin} _ :< _ -> cell_begin
  90
  91 -- * Class 'Plainify'
  92 class Plainify a where
  93         plainify :: a -> Plain
  94 instance Plainify () where
  95         plainify = mempty
  96 instance Plainify Char where
  97         plainify = \case
  98          '\n' -> do
  99                 S.modify' $ \s@State{state_pos=Pos line _col, state_indent, state_unindent} ->
 100                         s{state_pos=Pos (line + 1) $ state_unindent + int (TL.length state_indent)}
 101                 State{..} <- S.get
 102                 return $ TLB.singleton '\n' <> TLB.fromLazyText state_indent
 103          c -> do
 104                 S.modify' $ \s@State{state_pos=Pos line col} ->
 105                         s{state_pos=Pos line (col + 1)}
 106                 return $ TLB.singleton c
 107 instance Plainify String where
 108         plainify = foldMap plainify
 109 instance Plainify TL.Text where
 110         plainify t
 111          | TL.null t = mempty
 112          | otherwise =
 113                 let (h,ts) = TL.span (/='\n') t in
 114                 case TL.uncons ts of
 115                  Nothing -> do
 116                         S.modify' $ \s@State{state_pos=Pos line col} ->
 117                                 s{state_pos=Pos line $ col + int (TL.length h)}
 118                         return $ TLB.fromLazyText h
 119                  Just (_n,ts') ->
 120                         return (TLB.fromLazyText h) <>
 121                          -- NOTE: useless to increment the pos_column for h,
 122                          --       since the following '\n' will reset the pos_column.
 123                         plainify '\n' <>
 124                         plainify ts'
 125 instance Plainify Pos where
 126         plainify new@(Pos lineNew colNew) = do
 127                 State
 128                  { state_pos=old@(Pos lineOld colOld)
 129                  , state_indent
 130                  , state_unindent
 131                  } <- S.get
 132                 S.modify' $ \s -> s{state_pos=new}
 133                 return $ TLB.fromLazyText $
 134                         case lineNew`compare`lineOld of
 135                          GT -> lines <> state_indent <> hspaces
 136                                 where
 137                                 lines   = TL.replicate (int64 $ lineNew - lineOld) "\n"
 138                                 hspaces = TL.replicate (int64 (colNew - state_unindent) - TL.length state_indent) " "
 139                          EQ | colNew >= colOld ->
 140                                 TL.replicate (int64 $ colNew - colOld) " "
 141                          _ -> error $ "plainify: non-ascending Pos:"
 142                                  <> "\n old: " <> show old
 143                                  <> "\n new: " <> show new
 144 instance Plainify Roots where
 145         plainify = foldMap plainify
 146 instance Plainify Root where
 147         plainify (Tree (Cell bp _ep nod) ts) =
 148                 plainify bp <>
 149                 case nod of
 150                 ----------------------
 151                  NodeLower n as -> "<" <> plainify n <> plainify as <> plainify ts
 152                 ----------------------
 153                  NodeHeader hdr ->
 154                         case hdr of
 155                          HeaderGreat{} -> plainHeaderRepeated
 156                          HeaderBar{}   -> plainHeaderRepeated
 157                          _ -> plainify hdr <> plainify ts
 158                         where
 159                         plainHeaderRepeated = do
 160                                 State{..} <- S.get
 161                                 h <- plainify hdr
 162                                 S.modify' $ \s -> s{state_indent =
 163                                         state_indent <>
 164                                         TL.replicate (int64 (pos_column bp - state_unindent) - TL.length state_indent) " " <>
 165                                         TLB.toLazyText h
 166                                  }
 167                                 r <- plainify ts
 168                                 S.modify' $ \s -> s{state_indent}
 169                                 return $ h <> r
 170                 ----------------------
 171                  NodeText t -> do
 172                         State{..} <- S.get
 173                         S.modify' $ \s -> s{state_indent =
 174                                 state_indent <>
 175                                 TL.replicate (int64 (pos_column bp - state_unindent) - TL.length state_indent) " "
 176                          }
 177                         r <- plainify t
 178                         S.modify' $ \s -> s{state_indent}
 179                         return r
 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 - state_unindent) - 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 -}