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(..))
  20 import Data.String (String)
  21 import Data.Text (Text)
  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.Token
  32 import Language.TCT.Elem hiding (trac,dbg)
  33
  34 import Debug.Trace (trace)
  35 trac :: String -> a -> a
  36 -- trac _m x = x
  37 trac m x = trace m x
  38 dbg :: Show a => String -> a -> a
  39 dbg m x = trac (m <> ": " <> show x) x
  40
  41 tl :: Text -> TL.Text
  42 tl = TL.fromStrict
  43
  44 -- * Type 'Config_Text'
  45 data Config_Text
  46  =   Config_Text
  47  {   config_text_escape :: Bool
  48  } deriving (Eq, Show)
  49
  50 config_text :: Config_Text
  51 config_text =
  52         Config_Text
  53          { config_text_escape = True
  54          }
  55
  56 text :: Config_Text -> Trees (Cell Key) (Cell Tokens) -> TL.Text
  57 text cfg = t_TreesCell cfg . treePosLastCell
  58
  59 treeRackUpLeft :: Tree (Cell k) (Cell a) -> Tree (Cell k) (Cell a)
  60 treeRackUpLeft t = go t
  61         where
  62         Pos l0 c0 = posTree t
  63         rackUpLeft pos =
  64                 Pos
  65                  (linePos pos - l0 + 1)
  66                  (columnPos pos - c0 + 1)
  67         go :: Tree (Cell k) (Cell a) -> Tree (Cell k) (Cell a)
  68         go (Tree0 (Cell pos posEnd c)) =
  69                 Tree0 $ Cell (rackUpLeft pos) (rackUpLeft posEnd) c
  70         go (TreeN (Cell pos posEnd c) ts) =
  71                 TreeN
  72                  (Cell (rackUpLeft pos) (rackUpLeft posEnd) c)
  73                  (go <$> ts)
  74
  75 treePosLastCell :: Trees (Cell k) (Cell a) -> Trees (Pos,Cell k) (Pos,Cell a)
  76 treePosLastCell t = S.evalState (go`mapM`t) (Pos 1 1)
  77         where
  78         go :: Tree (Cell k) (Cell a) ->
  79               S.State Pos (Tree (Pos, Cell k) (Pos, Cell a))
  80         go (Tree0 cell) = do
  81                 lastPos <- S.get
  82                 S.put $ posEndCell cell
  83                 return $ Tree0 (lastPos,cell)
  84         go (TreeN cell ts) = do
  85                 lastPos <- S.get
  86                 S.put $ posEndCell cell
  87                 ts' <- go`mapM`ts
  88                 return $ TreeN (lastPos,cell) ts'
  89
  90 int64 :: Integral i => i -> Int64
  91 int64 = fromInteger . toInteger
  92
  93 t_TreeCell ::
  94  Config_Text ->
  95  Tree (Pos,Cell Key) (Pos,Cell Tokens) ->
  96  TL.Text
  97 t_TreeCell cfg (TreeN c@(_, unCell -> KeySection lvl) ts) =
  98         t_IndentCell c <>
  99         TL.replicate (int64 lvl) "#" <> " " <>
 100         (case Seq.viewl ts of
 101          Tree0 (_,Cell posTitle _ title) :< _ -> t_IndentToken cfg posTitle title
 102          _ -> "") <>
 103         t_TreesCell cfg
 104          (case Seq.viewl ts of
 105                  Tree0{} :< ts' -> ts'
 106                  _ -> ts)
 107 t_TreeCell cfg (Tree0 c@(_,cell)) =
 108         t_IndentCell c <>
 109         t_CellToken cfg cell
 110 t_TreeCell cfg (TreeN c@(_,cell) cs) =
 111         t_IndentCell c <>
 112         t_CellKey cfg cell cs
 113
 114 t_IndentCell :: (Pos,Cell a) -> TL.Text
 115 t_IndentCell (Pos lineLast colLast,posCell -> 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 t_CellKey ::
 124  Config_Text ->
 125  Cell Key ->
 126  Trees (Pos,Cell Key) (Pos,Cell Tokens) ->
 127  TL.Text
 128 t_CellKey cfg (Cell _pos _posEnd key) cells = do
 129         case key of
 130          KeyColon n wh -> t_Key n wh ":"
 131          KeyGreat n wh -> t_Key n wh ">"
 132          KeyEqual n wh -> t_Key n wh "="
 133          KeyBar   n wh -> t_Key n wh "|"
 134          KeyDash       -> t_Key "" "" "- "
 135          KeyDashDash   -> t_Key "" "" "-- "
 136          KeyLower name attrs ->
 137                 "<" <> tl name <> t_Attrs attrs <>
 138                 t_TreesCell cfg cells
 139          KeySection{} -> undefined
 140          KeyDotSlash p ->
 141                 "./" <> TL.pack p <>
 142                 t_TreesCell cfg cells
 143         where
 144         t_Key :: Text -> White -> TL.Text -> TL.Text
 145         t_Key name wh mark =
 146                 tl name <> tl wh <> mark <>
 147                 t_TreesCell cfg cells
 148
 149 t_TreesCell ::
 150  Config_Text ->
 151  Trees (Pos,Cell Key) (Pos,Cell Tokens) ->
 152  TL.Text
 153 t_TreesCell cfg = foldMap (t_TreeCell cfg)
 154
 155 t_CellToken :: Config_Text -> Cell Tokens -> TL.Text
 156 t_CellToken cfg (Cell pos _posEnd tok) =
 157         t_IndentToken cfg pos tok
 158
 159 t_IndentToken :: Config_Text -> Pos -> Tokens -> TL.Text
 160 t_IndentToken cfg pos toks = goTokens toks `S.evalState` linePos pos
 161         where
 162         indent = TL.replicate (int64 $ columnPos pos - 1) " "
 163         go :: Token -> S.State Int TL.Text
 164         go (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         go (TokenTag v) = return $ "#"<>tl v
 173         go (TokenEscape c) =
 174                 return $
 175                         if config_text_escape cfg
 176                         then tl $ Text.pack ['\\',c]
 177                         else TL.singleton c
 178         go (TokenLink lnk) = return $ tl lnk
 179         go (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 (Tokens ts) = do
 185                 ts' <- go`mapM`ts
 186                 return $ foldr (<>) mempty ts'
 187
 188 t_Attrs :: Attrs -> TL.Text
 189 t_Attrs = foldMap t_Attr
 190
 191 t_Attr :: (Text,Attr) -> TL.Text
 192 t_Attr (attr_white,Attr{..}) =
 193         mconcat $ tl <$>
 194          [ attr_white
 195          , attr_name
 196          , attr_open
 197          , attr_value
 198          , attr_close
 199          ]
 200
 201 t_Token :: Token -> TL.Text
 202 t_Token (TokenPlain txt)  = tl txt
 203 t_Token (TokenTag v)      = "#"<>tl v
 204 t_Token (TokenEscape c)   = TL.singleton c -- tl $ Text.pack ['\\',c]
 205 t_Token (TokenLink lnk)   = tl lnk
 206 t_Token (TokenPair grp t) = tl o<>t_Tokens t<>tl c
 207         where (o,c) = pairBorders grp t
 208
 209 t_Tokens :: Tokens -> TL.Text
 210 t_Tokens (Tokens ts) = foldMap t_Token ts