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 (Applicative(..), liftA2)
   8 import Control.Monad (Monad(..), mapM)
   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 (Seq)
  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
  31 import Language.TCT
  32 import Language.TCT.Utils
  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 $ fst $ S.runState p s
  49
  50 text :: Plainify a => State -> a -> TL.Text
  51 text st a = runPlain (plainify a) st
  52
  53 plainDocument :: Roots -> TL.Text
  54 plainDocument = text def
  55
  56 -- ** Type 'State'
  57 data State
  58  =   State
  59  {   state_escape :: Bool -- FIXME: useful?
  60  ,   state_pos    :: Pos
  61  ,   state_indent :: Int
  62  } deriving (Eq, Show)
  63 instance Default State where
  64         def = State
  65          { state_escape = True
  66          , state_pos    = pos1
  67          , state_indent = 1
  68          }
  69
  70 -- * Class 'Plainify'
  71 class Plainify a where
  72         plainify :: a -> Plain
  73 instance Plainify () where
  74         plainify = mempty
  75 instance Plainify Char where
  76         plainify = \case
  77          '\n' -> do
  78                 S.modify $ \s@State{state_pos=Pos line _col, state_indent} ->
  79                         s{state_pos=Pos (line + 1) state_indent}
  80                 indent <- S.gets state_indent
  81                 return $ TLB.singleton '\n' <> fromString (List.replicate (indent - 1) ' ')
  82          c -> do
  83                 S.modify $ \s@State{state_pos=Pos line col} ->
  84                         s{state_pos=Pos line (col + 1)}
  85                 return $ TLB.singleton c
  86 instance Plainify String where
  87         plainify = foldMap plainify
  88 instance Plainify TL.Text where
  89         plainify t
  90          | TL.null t = mempty
  91          | otherwise =
  92                 let (h,ts) = TL.span (/='\n') t in
  93                 case TL.uncons ts of
  94                  Nothing -> do
  95                         S.modify $ \s@State{state_pos=Pos line col} ->
  96                                 s{state_pos=Pos line (col + int (TL.length h))}
  97                         return $ TLB.fromLazyText h
  98                  Just (_n,ts') ->
  99                         return (TLB.fromLazyText h) <>
 100                          -- NOTE: useless to increment the pos_column for h,
 101                          --       since the following '\n' will reset the pos_column.
 102                         plainify '\n' <>
 103                         plainify ts'
 104 instance Plainify Pos where
 105         plainify new@(Pos lineNew colNew) = do
 106                 old@(Pos lineOld colOld) <- S.gets state_pos
 107                 S.modify $ \s -> s{state_pos=new}
 108                 case lineOld`compare`lineNew of
 109                  LT ->
 110                         return $
 111                                 fromString (List.replicate (lineNew - lineOld) '\n') <>
 112                                 fromString (List.replicate (colNew - 1) ' ')
 113                  EQ | colOld <= colNew ->
 114                         return $
 115                                 fromString (List.replicate (colNew - colOld) ' ')
 116                  _ -> error $ "plainify: non-ascending Pos:"
 117                          <> "\n old: " <> show old
 118                          <> "\n new: " <> show new
 119 instance Plainify Roots where
 120         plainify = foldMap plainify
 121 instance Plainify Root where
 122         plainify (Tree (Cell bp _ep nod) ts) =
 123                 plainify bp <>
 124                 case nod of
 125                  NodePara -> do
 126                         ind <- S.gets state_indent
 127                         S.modify $ \s -> s{state_indent = pos_column bp}
 128                         r <- plainify ts
 129                         S.modify $ \s -> s{state_indent=ind}
 130                         return r
 131                  NodeGroup -> plainify ts
 132                  NodeHeader h -> plainify h <> plainify ts
 133                  NodeToken t -> plainify t
 134                  NodeText t -> do
 135                         ind <- S.gets state_indent
 136                         S.modify $ \s -> s{state_indent = pos_column bp}
 137                         r <- plainify t
 138                         S.modify $ \s -> s{state_indent=ind}
 139                         return r
 140                  NodePair p ->
 141                         plainify o <> plainify ts <> plainify c
 142                         where (o,c) | null ts   = pairBordersWithoutContent p
 143                                     | otherwise = pairBorders p
 144                  NodeLower n as ->
 145                         "<" <> plainify n <> plainify as <> plainify ts
 146 instance Plainify Header where
 147         plainify hdr =
 148                 case hdr of
 149                  HeaderColon n wh  -> plainify n <> plainify wh <> ":"
 150                  HeaderGreat n wh  -> plainify n <> plainify wh <> ">"
 151                  HeaderEqual n wh  -> plainify n <> plainify wh <> "="
 152                  HeaderBar   n wh  -> plainify n <> plainify wh <> "|"
 153                  HeaderDot   n     -> plainify n <> "."
 154                  HeaderBrackets n  -> "[" <> plainify n <> "]"
 155                  HeaderDash        -> "- "
 156                  HeaderDashDash    -> "-- "
 157                  HeaderSection lvl -> plainify (List.replicate lvl '#')
 158                  HeaderDotSlash n  -> "./" <> plainify n
 159 instance Plainify Token where
 160         plainify = \case
 161          TokenText t -> plainify t
 162          TokenTag  t -> plainify '#' <> plainify t
 163          TokenLink l -> plainify l
 164          TokenEscape c -> do
 165                 esc <- S.gets state_escape
 166                 if esc
 167                  then plainify ['\\', c]
 168                  else plainify c
 169 instance Plainify ElemAttrs where
 170         plainify = foldMap plainify
 171 instance Plainify (White,ElemAttr) where
 172         plainify (elemAttr_white,ElemAttr{..}) =
 173                 mconcat $ plainify <$>
 174                  [ elemAttr_white
 175                  , elemAttr_name
 176                  , elemAttr_open
 177                  , elemAttr_value
 178                  , elemAttr_close
 179                  ]
 180
 181 -- * Class 'RackUpLeft'
 182 class RackUpLeft a where
 183         rackUpLeft :: a -> S.State (Maybe Pos) a
 184 instance RackUpLeft Pos where
 185         rackUpLeft pos@Pos{..} = do
 186                 S.get >>= \case
 187                  Nothing -> return pos
 188                  Just (Pos l0 c0) ->
 189                         return Pos
 190                          { pos_line   = pos_line   - l0 + 1
 191                          , pos_column = pos_column - c0 + 1
 192                          }
 193 instance RackUpLeft (Cell a) where
 194         rackUpLeft (Cell bp ep a) = do
 195                 S.modify $ \case
 196                  Nothing -> Just bp
 197                  p -> p
 198                 Cell
 199                  <$> rackUpLeft bp
 200                  <*> rackUpLeft ep
 201                  <*> pure a
 202 instance RackUpLeft a => RackUpLeft (Seq a) where
 203         rackUpLeft = mapM rackUpLeft
 204 instance RackUpLeft a => RackUpLeft (Tree a) where
 205         rackUpLeft (Tree n ts) =
 206                 Tree
 207                  <$> rackUpLeft n
 208                  <*> rackUpLeft ts