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
  35 -- * Type 'Plain'
  36 type Plain = S.State State TLB.Builder
  37  -- NOTE: To get maximum performance when building lazy Text values using a builder,
  38  --       associate mappend calls to the right.
  39  -- NOTE: (Semigroup.<>) associates to the right.
  40 instance IsString Plain where
  41         fromString = plainify
  42 instance Semigroup Plain where
  43         (<>) = liftA2 (<>)
  44 instance Monoid Plain where
  45         mempty  = return ""
  46         mappend = (<>)
  47
  48 runPlain :: Plain -> State -> TL.Text
  49 runPlain p s = TLB.toLazyText $ fst $ S.runState p s
  50
  51 text :: Plainify a => State -> a -> TL.Text
  52 text s a = runPlain (plainify a) s
  53
  54 plainDocument :: Roots -> TL.Text
  55 plainDocument doc = text (setStart doc def) doc
  56
  57 -- ** Type 'State'
  58 data State
  59  =   State
  60  {   state_escape   :: Bool -- FIXME: useful?
  61  ,   state_pos      :: Pos
  62  ,   state_indent   :: Int
  63  ,   state_unindent :: Int
  64  } deriving (Eq, Show)
  65 instance Default State where
  66         def = State
  67          { state_escape   = True
  68          , state_pos      = pos1
  69          , state_indent   = 1
  70          , state_unindent = 0
  71          }
  72
  73 -- | Set the starting 'Pos' of given 'State'
  74 -- by using the first 'cell_begin'.
  75 setStart :: Roots -> State -> State
  76 setStart ts st = st
  77          { state_unindent = pos_column - 1
  78          , state_pos      = pos1{pos_line}
  79          }
  80         where
  81         Pos{..} =
  82                 case Seq.viewl ts of
  83                  EmptyL -> pos1
  84                  Tree Cell{cell_begin} _ :< _ -> cell_begin
  85
  86 -- * Class 'Plainify'
  87 class Plainify a where
  88         plainify :: a -> Plain
  89 instance Plainify () where
  90         plainify = mempty
  91 instance Plainify Char where
  92         plainify = \case
  93          '\n' -> do
  94                 S.modify' $ \s@State{state_pos=Pos line _col, state_indent} ->
  95                         s{state_pos=Pos (line + 1) state_indent}
  96                 State{..} <- S.get
  97                 let indent = state_indent - 1 - state_unindent
  98                 return $ TLB.singleton '\n' <> fromString (List.replicate indent ' ')
  99          c -> do
 100                 S.modify' $ \s@State{state_pos=Pos line col} ->
 101                         s{state_pos=Pos line (col + 1)}
 102                 return $ TLB.singleton c
 103 instance Plainify String where
 104         plainify = foldMap plainify
 105 instance Plainify TL.Text where
 106         plainify t
 107          | TL.null t = mempty
 108          | otherwise =
 109                 let (h,ts) = TL.span (/='\n') t in
 110                 case TL.uncons ts of
 111                  Nothing -> do
 112                         S.modify' $ \s@State{state_pos=Pos line col} ->
 113                                 s{state_pos=Pos line (col + int (TL.length h))}
 114                         return $ TLB.fromLazyText h
 115                  Just (_n,ts') ->
 116                         return (TLB.fromLazyText h) <>
 117                          -- NOTE: useless to increment the pos_column for h,
 118                          --       since the following '\n' will reset the pos_column.
 119                         plainify '\n' <>
 120                         plainify ts'
 121 instance Plainify Pos where
 122         plainify new@(Pos lineNew colNew) = do
 123                 State
 124                  { state_pos=old@(Pos lineOld colOld)
 125                  , state_unindent
 126                  } <- S.get
 127                 S.modify' $ \s -> s{state_pos=new}
 128                 return $
 129                         case lineOld`compare`lineNew of
 130                          LT ->
 131                                 fromString (List.replicate (lineNew - lineOld) '\n') <>
 132                                 fromString (List.replicate indent ' ')
 133                                 where indent = colNew - 1 - state_unindent
 134                          EQ | colOld <= colNew ->
 135                                 fromString (List.replicate indent ' ')
 136                                 where indent = (colNew - colOld) - state_unindent
 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                  NodePara -> do
 147                         State{..} <- S.get
 148                         S.modify' $ \s -> s{state_indent = pos_column bp}
 149                         r <- plainify ts
 150                         S.modify' $ \s -> s{state_indent}
 151                         return r
 152                  NodeGroup -> plainify ts
 153                  NodeHeader h -> plainify h <> plainify ts
 154                  NodeToken t -> plainify t
 155                  NodeText t -> do
 156                         State{..} <- S.get
 157                         S.modify' $ \s -> s{state_indent = pos_column bp}
 158                         r <- plainify t
 159                         S.modify' $ \s -> s{state_indent}
 160                         return r
 161                  NodePair p ->
 162                         plainify o <> plainify ts <> plainify c
 163                         where (o,c) = pairBorders p ts
 164                  NodeLower n as ->
 165                         "<" <> plainify n <> plainify as <> plainify ts
 166 instance Plainify Header where
 167         plainify hdr =
 168                 case hdr of
 169                  HeaderColon n wh  -> plainify n <> plainify wh <> ":"
 170                  HeaderGreat n wh  -> plainify n <> plainify wh <> ">"
 171                  HeaderEqual n wh  -> plainify n <> plainify wh <> "="
 172                  HeaderBar   n wh  -> plainify n <> plainify wh <> "|"
 173                  HeaderDot   n     -> plainify n <> "."
 174                  HeaderBrackets n  -> "[" <> plainify n <> "]"
 175                  HeaderDash        -> "- "
 176                  HeaderDashDash    -> "-- "
 177                  HeaderSection lvl -> plainify (List.replicate lvl '#')
 178                  HeaderDotSlash n  -> "./" <> plainify n
 179 instance Plainify Token where
 180         plainify = \case
 181          TokenText t -> plainify t
 182          TokenTag  t -> plainify '#' <> plainify t
 183          TokenLink l -> plainify l
 184          TokenEscape c -> do
 185                 esc <- S.gets state_escape
 186                 if esc
 187                  then plainify ['\\', c]
 188                  else plainify c
 189 instance Plainify ElemAttrs where
 190         plainify = foldMap plainify
 191 instance Plainify (White,ElemAttr) where
 192         plainify (elemAttr_white,ElemAttr{..}) =
 193                 mconcat $ plainify <$>
 194                  [ elemAttr_white
 195                  , elemAttr_name
 196                  , elemAttr_open
 197                  , elemAttr_value
 198                  , elemAttr_close
 199                  ]
 200
 201 {-
 202 -- * Class 'RackUpLeft'
 203 class RackUpLeft a where
 204         rackUpLeft :: a -> S.State (Maybe Pos) a
 205 instance RackUpLeft Pos where
 206         rackUpLeft pos@Pos{..} = do
 207                 S.get >>= \case
 208                  Nothing -> return pos
 209                  Just (Pos l0 c0) ->
 210                         return Pos
 211                          { pos_line   = pos_line   - l0 + 1
 212                          , pos_column = pos_column - c0 + 1
 213                          }
 214 instance RackUpLeft (Cell a) where
 215         rackUpLeft (Cell bp ep a) = do
 216                 S.modify' $ \case
 217                  Nothing -> Just bp
 218                  p -> p
 219                 Cell
 220                  <$> rackUpLeft bp
 221                  <*> rackUpLeft ep
 222                  <*> pure a
 223 instance RackUpLeft a => RackUpLeft (Seq a) where
 224         rackUpLeft = mapM rackUpLeft
 225 instance RackUpLeft a => RackUpLeft (Tree a) where
 226         rackUpLeft (Tree n ts) =
 227                 Tree
 228                  <$> rackUpLeft n
 229                  <*> rackUpLeft ts
 230 -}