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