Language/TCT/Write/Text.hs

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