Language/TCT/Write/Text.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE RecordWildCards #-}
   3 {-# LANGUAGE ViewPatterns #-}
   4 {-# OPTIONS_GHC -fno-warn-orphans #-}
   5 -- | Render a TCT file in plain Text.
   6 module Language.TCT.Write.Text where
   7
   8 import Control.Monad (Monad(..), mapM)
   9 import Data.Bool
  10 import Data.Eq (Eq(..))
  11 import Data.Foldable (Foldable(..))
  12 import Data.Function (($), (.))
  13 import Data.Functor ((<$>))
  14 import Data.Int (Int)
  15 import Data.Int (Int64)
  16 import Data.Monoid (Monoid(..))
  17 import Data.Ord (Ord(..))
  18 import Data.Semigroup (Semigroup(..))
  19 import Data.Sequence (ViewL(..), ViewR(..))
  20 import Data.String (String)
  21 import Data.Text (Text)
  22 import Data.TreeSeq.Strict (Tree(..),Trees)
  23 import Prelude (Num(..), undefined, Integral(..))
  24 import Text.Show (Show(..))
  25 import qualified Control.Monad.Trans.State as S
  26 import qualified Data.List as L
  27 import qualified Data.Sequence as Seq
  28 import qualified Data.Text as Text
  29 import qualified Data.Text.Lazy as TL
  30
  31 import Language.TCT.Tree
  32 import Language.TCT.Cell
  33 import Language.TCT.Token
  34 import Language.TCT.Elem hiding (trac,dbg)
  35
  36 import Debug.Trace (trace)
  37 trac :: String -> a -> a
  38 -- trac _m x = x
  39 trac m x = trace m x
  40 dbg :: Show a => String -> a -> a
  41 dbg m x = trac (m <> ": " <> show x) x
  42
  43 tl :: Text -> TL.Text
  44 tl = TL.fromStrict
  45
  46 -- * Type 'Config_Text'
  47 data Config_Text
  48  =   Config_Text
  49  {   config_text_escape :: Bool
  50  } deriving (Eq, Show)
  51
  52 config_text :: Config_Text
  53 config_text =
  54         Config_Text
  55          { config_text_escape = True
  56          }
  57
  58 text :: Config_Text -> Trees (Cell Key) Tokens -> TL.Text
  59 text cfg = textTreesCell cfg . treePosLastCell
  60
  61 treeRackUpLeft :: Tree (Cell k) (Cell a) -> Tree (Cell k) (Cell a)
  62 treeRackUpLeft t = go t
  63         where
  64         Pos l0 c0 = posTree t
  65         rackUpLeft pos =
  66                 Pos
  67                  (linePos pos - l0 + 1)
  68                  (columnPos pos - c0 + 1)
  69         go :: Tree (Cell k) (Cell a) -> Tree (Cell k) (Cell a)
  70         go (Tree0 (Cell pos posEnd c)) =
  71                 Tree0 $ Cell (rackUpLeft pos) (rackUpLeft posEnd) c
  72         go (TreeN (Cell pos posEnd c) ts) =
  73                 TreeN
  74                  (Cell (rackUpLeft pos) (rackUpLeft posEnd) c)
  75                  (go <$> ts)
  76
  77 treePosLastCell ::
  78  Trees (Cell k) Tokens ->
  79  Trees (Pos,Cell k) (Pos,Tokens)
  80 treePosLastCell t = S.evalState (go`mapM`t) (Pos 1 1)
  81         where
  82         go :: Tree (Cell k) Tokens ->
  83               S.State Pos (Tree (Pos,Cell k) (Pos,Tokens))
  84         go (Tree0 ts) = do
  85                 lastPos <- S.get
  86                 case Seq.viewr ts of
  87                  EmptyR ->
  88                         return $ Tree0 (lastPos,ts)
  89                  _ :> cell -> do
  90                         S.put $ posEndCell cell
  91                         return $ Tree0 (lastPos,ts)
  92         go (TreeN cell ts) = do
  93                 lastPos <- S.get
  94                 S.put $ posEndCell cell
  95                 ts' <- go`mapM`ts
  96                 return $ TreeN (lastPos,cell) ts'
  97
  98 int64 :: Integral i => i -> Int64
  99 int64 = fromInteger . toInteger
 100
 101 textTreeCell ::
 102  Config_Text ->
 103  Tree (Pos,Cell Key) (Pos,Tokens) ->
 104  TL.Text
 105 textTreeCell cfg (TreeN (posEnd, Cell pos _ (KeySection lvl)) ts) =
 106         textIndentCell (posEnd,pos) <>
 107         TL.replicate (int64 lvl) "#" <> " " <>
 108         (case Seq.viewl ts of
 109          Tree0 (_,title) :< _ ->
 110                 textIndentToken cfg title
 111          _ -> "") <>
 112         textTreesCell cfg
 113          (case Seq.viewl ts of
 114                  Tree0{} :< ts' -> ts'
 115                  _ -> ts)
 116 textTreeCell cfg (Tree0 (posEnd,toks)) =
 117         case Seq.viewl toks of
 118          EmptyL -> textIndentToken cfg toks
 119          t0:<_  -> textIndentCell (posEnd,posCell t0) <> textIndentToken cfg toks
 120 textTreeCell cfg (TreeN (posEnd,cell@(Cell pos _ _)) cs) =
 121         textIndentCell (posEnd,pos) <>
 122         textCellKey cfg cell cs
 123
 124 textIndentCell :: (Pos,Pos) -> TL.Text
 125 textIndentCell (Pos lineLast colLast,Pos line col)
 126  | lineLast < line =
 127         TL.replicate (int64 $ line - (lineLast+1)) "\n" <>
 128         TL.replicate (int64 $ col - 1) " "
 129  | lineLast == line && colLast <= col =
 130         TL.replicate (int64 $ col - colLast) " "
 131  | otherwise = undefined
 132
 133 textCellKey ::
 134  Config_Text ->
 135  Cell Key ->
 136  Trees (Pos,Cell Key) (Pos,Tokens) ->
 137  TL.Text
 138 textCellKey cfg (Cell _pos _posEnd key) cells = do
 139         case key of
 140          KeyColon n wh -> textKey n wh ":"
 141          KeyGreat n wh -> textKey n wh ">"
 142          KeyEqual n wh -> textKey n wh "="
 143          KeyBar   n wh -> textKey n wh "|"
 144          KeyDash       -> textKey "" "" "- "
 145          KeyDashDash   -> textKey "" "" "-- "
 146          KeyLower name attrs ->
 147                 "<" <> tl name <> textAttrs attrs <>
 148                 textTreesCell cfg cells
 149          KeySection{} -> undefined
 150          KeyDotSlash p ->
 151                 "./" <> TL.pack p <>
 152                 textTreesCell cfg cells
 153         where
 154         textKey :: Text -> White -> TL.Text -> TL.Text
 155         textKey name wh mark =
 156                 tl name <> tl wh <> mark <>
 157                 textTreesCell cfg cells
 158
 159 textTreesCell ::
 160  Config_Text ->
 161  Trees (Pos,Cell Key) (Pos,Tokens) ->
 162  TL.Text
 163 textTreesCell cfg = foldMap (textTreeCell cfg)
 164
 165 textIndentToken :: Config_Text -> Tokens -> TL.Text
 166 textIndentToken _cfg (Seq.viewl -> EmptyL) = ""
 167 textIndentToken cfg toks@(Seq.viewl -> Cell pos _ _ :< _) =
 168         goTokens toks `S.evalState` linePos pos
 169         where
 170         indent = TL.replicate (int64 $ columnPos pos - 1) " "
 171         go :: Cell Token -> S.State Int TL.Text
 172         go tok =
 173                 case unCell tok of
 174                  TokenPlain txt -> do
 175                         lnum <- S.get
 176                         let lines = Text.splitOn "\n" txt
 177                         S.put (lnum - 1 + L.length lines)
 178                         return $
 179                                 case lines of
 180                                  [] -> undefined
 181                                  (l0:ls) -> tl l0 <> mconcat ((\l -> "\n"<>indent<>tl l)<$>ls)
 182                  TokenTag v -> return $ "#"<>tl v
 183                  TokenEscape c ->
 184                         return $
 185                                 if config_text_escape cfg
 186                                 then tl $ Text.pack ['\\',c]
 187                                 else TL.singleton c
 188                  TokenLink lnk -> return $ tl lnk
 189                  TokenPair grp ts -> do
 190                         ts' <- goTokens ts
 191                         return $ tl o<>ts'<>tl c
 192                         where (o,c) = pairBorders grp ts
 193         goTokens :: Tokens -> S.State Int TL.Text
 194         goTokens ts = do
 195                 ts' <- go`mapM`ts
 196                 return $ foldr (<>) mempty ts'
 197
 198 textAttrs :: Attrs -> TL.Text
 199 textAttrs = foldMap textAttr
 200
 201 textAttr :: (Text,Attr) -> TL.Text
 202 textAttr (attr_white,Attr{..}) =
 203         mconcat $ tl <$>
 204          [ attr_white
 205          , attr_name
 206          , attr_open
 207          , attr_value
 208          , attr_close
 209          ]
 210
 211 textToken :: Token -> TL.Text
 212 textToken (TokenPlain txt)  = tl txt
 213 textToken (TokenTag v)      = "#"<>tl v
 214 textToken (TokenEscape c)   = TL.singleton c -- tl $ Text.pack ['\\',c]
 215 textToken (TokenLink lnk)   = tl lnk
 216 textToken (TokenPair grp t) = tl o<>textTokens t<>tl c
 217         where (o,c) = pairBorders grp t
 218
 219 textTokens :: Tokens -> TL.Text
 220 textTokens ts = foldMap (textToken . unCell) ts