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                  NodeGroup -> plainify ts
 152                 ----------------------
 153                  NodeLower n as -> "<" <> plainify n <> plainify as <> plainify ts
 154                 ----------------------
 155                  NodeHeader hdr ->
 156                         case hdr of
 157                          HeaderGreat{} -> plainHeaderRepeated
 158                          HeaderBar{}   -> plainHeaderRepeated
 159                          _ -> plainify hdr <> plainify ts
 160                         where
 161                         plainHeaderRepeated = do
 162                                 State{..} <- S.get
 163                                 h <- plainify hdr
 164                                 S.modify' $ \s -> s{state_indent =
 165                                         state_indent <>
 166                                         TL.replicate (int64 (pos_column bp - state_unindent) - TL.length state_indent) " " <>
 167                                         TLB.toLazyText h
 168                                  }
 169                                 r <- plainify ts
 170                                 S.modify' $ \s -> s{state_indent}
 171                                 return $ h <> r
 172                 ----------------------
 173                  NodeText t -> do
 174                         State{..} <- S.get
 175                         S.modify' $ \s -> s{state_indent =
 176                                 state_indent <>
 177                                 TL.replicate (int64 (pos_column bp - state_unindent) - TL.length state_indent) " "
 178                          }
 179                         r <- plainify t
 180                         S.modify' $ \s -> s{state_indent}
 181                         return r
 182                 ----------------------
 183                  NodePara -> do
 184                         State{..} <- S.get
 185                         S.modify' $ \s -> s{state_indent =
 186                                 state_indent <>
 187                                 TL.replicate (int64 (pos_column bp - state_unindent) - TL.length state_indent) " "
 188                          }
 189                         r <- plainify ts
 190                         S.modify' $ \s -> s{state_indent}
 191                         return r
 192                 ----------------------
 193                  NodeToken t -> plainify t <> plainify ts
 194                 ----------------------
 195                  NodePair p ->
 196                         plainify o <> plainify ts <> plainify c
 197                         where (o,c) = pairBorders p ts
 198 instance Plainify Header where
 199         plainify hdr =
 200                 case hdr of
 201                  HeaderColon n wh  -> plainify n <> plainify wh <> ":"
 202                  HeaderGreat n wh  -> plainify n <> plainify wh <> ">"
 203                  HeaderEqual n wh  -> plainify n <> plainify wh <> "="
 204                  HeaderBar   n wh  -> plainify n <> plainify wh <> "|"
 205                  HeaderDot   n     -> plainify n <> "."
 206                  HeaderBrackets n  -> "[" <> plainify n <> "]"
 207                  HeaderDash        -> "- "
 208                  HeaderDashDash    -> "-- "
 209                  HeaderSection lvl -> plainify (List.replicate lvl '#')
 210                  HeaderDotSlash n  -> "./" <> plainify n
 211 instance Plainify Token where
 212         plainify = \case
 213          TokenText t -> plainify t
 214          TokenTag  t -> plainify '#' <> plainify t
 215          TokenLink l -> plainify l
 216          TokenEscape c -> do
 217                 esc <- S.gets state_escape
 218                 if esc
 219                  then plainify ['\\', c]
 220                  else plainify c
 221 instance Plainify ElemAttrs where
 222         plainify = foldMap plainify
 223 instance Plainify (White,ElemAttr) where
 224         plainify (elemAttr_white,ElemAttr{..}) =
 225                 mconcat $ plainify <$>
 226                  [ elemAttr_white
 227                  , elemAttr_name
 228                  , elemAttr_open
 229                  , elemAttr_value
 230                  , elemAttr_close
 231                  ]
 232
 233 {-
 234 -- * Class 'RackUpLeft'
 235 class RackUpLeft a where
 236         rackUpLeft :: a -> S.State (Maybe Pos) a
 237 instance RackUpLeft Pos where
 238         rackUpLeft pos@Pos{..} = do
 239                 S.get >>= \case
 240                  Nothing -> return pos
 241                  Just (Pos l0 c0) ->
 242                         return Pos
 243                          { pos_line   = pos_line   - l0 + 1
 244                          , pos_column = pos_column - c0 + 1
 245                          }
 246 instance RackUpLeft (Cell a) where
 247         rackUpLeft (Cell bp ep a) = do
 248                 S.modify' $ \case
 249                  Nothing -> Just bp
 250                  p -> p
 251                 Cell
 252                  <$> rackUpLeft bp
 253                  <*> rackUpLeft ep
 254                  <*> pure a
 255 instance RackUpLeft a => RackUpLeft (Seq a) where
 256         rackUpLeft = mapM rackUpLeft
 257 instance RackUpLeft a => RackUpLeft (Tree a) where
 258         rackUpLeft (Tree n ts) =
 259                 Tree
 260                  <$> rackUpLeft n
 261                  <*> rackUpLeft ts
 262 -}