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