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 = t_TreesCell 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 t_TreeCell ::
 102  Config_Text ->
 103  Tree (Pos,Cell Key) (Pos,Tokens) ->
 104  TL.Text
 105 t_TreeCell cfg (TreeN (posEnd, Cell pos _ (KeySection lvl)) ts) =
 106         t_IndentCell (posEnd,pos) <>
 107         TL.replicate (int64 lvl) "#" <> " " <>
 108         (case Seq.viewl ts of
 109          Tree0 (_,title) :< _ ->
 110                 t_IndentToken cfg title
 111          _ -> "") <>
 112         t_TreesCell cfg
 113          (case Seq.viewl ts of
 114                  Tree0{} :< ts' -> ts'
 115                  _ -> ts)
 116 t_TreeCell cfg (Tree0 (posEnd,toks)) =
 117         case Seq.viewl toks of
 118          EmptyL -> t_IndentToken cfg toks
 119          t0:<_  -> t_IndentCell (posEnd,posCell t0) <> t_IndentToken cfg toks
 120 t_TreeCell cfg (TreeN (posEnd,cell@(Cell pos _ _)) cs) =
 121         t_IndentCell (posEnd,pos) <>
 122         t_CellKey cfg cell cs
 123
 124 t_IndentCell :: (Pos,Pos) -> TL.Text
 125 t_IndentCell (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 t_CellKey ::
 134  Config_Text ->
 135  Cell Key ->
 136  Trees (Pos,Cell Key) (Pos,Tokens) ->
 137  TL.Text
 138 t_CellKey cfg (Cell _pos _posEnd key) cells = do
 139         case key of
 140          KeyColon n wh -> t_Key n wh ":"
 141          KeyGreat n wh -> t_Key n wh ">"
 142          KeyEqual n wh -> t_Key n wh "="
 143          KeyBar   n wh -> t_Key n wh "|"
 144          KeyDash       -> t_Key "" "" "- "
 145          KeyDashDash   -> t_Key "" "" "-- "
 146          KeyLower name attrs ->
 147                 "<" <> tl name <> t_Attrs attrs <>
 148                 t_TreesCell cfg cells
 149          KeySection{} -> undefined
 150          KeyDotSlash p ->
 151                 "./" <> TL.pack p <>
 152                 t_TreesCell cfg cells
 153         where
 154         t_Key :: Text -> White -> TL.Text -> TL.Text
 155         t_Key name wh mark =
 156                 tl name <> tl wh <> mark <>
 157                 t_TreesCell cfg cells
 158
 159 t_TreesCell ::
 160  Config_Text ->
 161  Trees (Pos,Cell Key) (Pos,Tokens) ->
 162  TL.Text
 163 t_TreesCell cfg = foldMap (t_TreeCell cfg)
 164
 165 t_IndentToken :: Config_Text -> Tokens -> TL.Text
 166 t_IndentToken _cfg (Seq.viewl -> EmptyL) = ""
 167 t_IndentToken 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 t_Attrs :: Attrs -> TL.Text
 199 t_Attrs = foldMap t_Attr
 200
 201 t_Attr :: (Text,Attr) -> TL.Text
 202 t_Attr (attr_white,Attr{..}) =
 203         mconcat $ tl <$>
 204          [ attr_white
 205          , attr_name
 206          , attr_open
 207          , attr_value
 208          , attr_close
 209          ]
 210
 211 t_Token :: Token -> TL.Text
 212 t_Token (TokenPlain txt)  = tl txt
 213 t_Token (TokenTag v)      = "#"<>tl v
 214 t_Token (TokenEscape c)   = TL.singleton c -- tl $ Text.pack ['\\',c]
 215 t_Token (TokenLink lnk)   = tl lnk
 216 t_Token (TokenPair grp t) = tl o<>t_Tokens t<>tl c
 217         where (o,c) = pairBorders grp t
 218
 219 t_Tokens :: Tokens -> TL.Text
 220 t_Tokens ts = foldMap (t_Token . unCell) ts