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 tct = foldMap (t_TreeCell cfg) (treePosLastCell tct)
  58
  59 treeRackUpLeft :: Tree (Cell k) (Cell a) -> Tree (Cell k) (Cell a)
  60 treeRackUpLeft t = go t
  61         where
  62         (l0,c0) = posTree t
  63         rackUpLeft pos = (linePos pos - l0 + 1, columnPos pos - c0 + 1)
  64         go :: Tree (Cell k) (Cell a) -> Tree (Cell k) (Cell a)
  65         go (Tree0 (Cell pos posEnd c)) =
  66                 Tree0 $ Cell (rackUpLeft pos) (rackUpLeft posEnd) c
  67         go (TreeN (Cell pos posEnd c) ts) =
  68                 TreeN
  69                  (Cell (rackUpLeft pos) (rackUpLeft posEnd) c)
  70                  (go <$> ts)
  71
  72 treePosLastCell :: Trees (Cell k) (Cell a) -> Trees (Pos,Cell k) (Pos,Cell a)
  73 treePosLastCell t = S.evalState (go`mapM`t) (1,1)
  74         where
  75         go :: Tree (Cell k) (Cell a) ->
  76               S.State (Int, Int) (Tree (Pos, Cell k) (Pos, Cell a))
  77         go (Tree0 cell) = do
  78                 lastPos <- S.get
  79                 S.put $ posEndCell cell
  80                 return $ Tree0 (lastPos,cell)
  81         go (TreeN cell ts) = do
  82                 lastPos <- S.get
  83                 S.put $ posEndCell cell
  84                 ts' <- go`mapM`ts
  85                 return $ TreeN (lastPos,cell) ts'
  86
  87 t_Value :: Text -> TL.Text
  88 t_Value v = tl v
  89
  90 int64 :: Integral i => i -> Int64
  91 int64 = fromInteger . toInteger
  92
  93 t_TreeCell :: Config_Text -> Tree (Pos,Cell Key) (Pos,Cell Tokens) -> TL.Text
  94 t_TreeCell cfg (TreeN c@(_, unCell -> KeySection lvl) ts) =
  95         t_IndentCell c <>
  96         TL.replicate (int64 lvl) "#" <> " " <>
  97         (case Seq.viewl ts of
  98          Tree0 (_,Cell posTitle _ title) :< _ -> t_IndentToken cfg posTitle title
  99          _ -> "") <>
 100         foldMap (t_TreeCell cfg) (case Seq.viewl ts of {Tree0{} :< ts' -> ts'; _ -> ts})
 101 t_TreeCell cfg (Tree0 c@(_,cell)) =
 102         t_IndentCell c <>
 103         t_CellToken cfg cell
 104 t_TreeCell cfg (TreeN c@(_,cell) cs) =
 105         t_IndentCell c <>
 106         t_CellKey cfg cell cs
 107
 108 t_IndentCell :: (Pos,Cell a) -> TL.Text
 109 t_IndentCell ((lineLast,colLast),posCell -> (line,col))
 110  | lineLast < line =
 111         TL.replicate (int64 $ line - (lineLast+1)) "\n" <>
 112         TL.replicate (int64 $ col - 1) " "
 113  | lineLast == line
 114  && colLast <= col = TL.replicate (int64 $ col - colLast) " "
 115  | otherwise = undefined
 116
 117 t_CellKey :: Config_Text -> Cell Key -> Trees (Pos,Cell Key) (Pos,Cell Tokens) -> TL.Text
 118 t_CellKey cfg (Cell _pos _posEnd key) cells = do
 119         case key of
 120          KeyColon n wh -> t_Key n wh ":"
 121          KeyGreat n wh -> t_Key n wh ">"
 122          KeyEqual n wh -> t_Key n wh "="
 123          KeyBar   n wh -> t_Key n wh "|"
 124          KeyDash -> "- " <> foldMap (t_TreeCell cfg) cells
 125          KeyLower name attrs ->
 126                 "<" <> tl name <> t_Attrs attrs <>
 127                 foldMap (t_TreeCell cfg) cells
 128          KeySection{} -> undefined
 129         where
 130         t_Key :: Text -> White -> TL.Text -> TL.Text
 131         t_Key name wh mark = tl name <> tl wh <> mark <> foldMap (t_TreeCell cfg) cells
 132
 133 t_CellToken :: Config_Text -> Cell Tokens -> TL.Text
 134 t_CellToken cfg (Cell pos _posEnd tok) =
 135         t_IndentToken cfg pos tok
 136
 137 t_IndentToken :: Config_Text -> Pos -> Tokens -> TL.Text
 138 t_IndentToken cfg pos toks = goTokens toks `S.evalState` linePos pos
 139         where
 140         indent = TL.replicate (int64 $ columnPos pos - 1) " "
 141         go :: Token -> S.State Int TL.Text
 142         go (TokenPlain txt) = do
 143                 lnum <- S.get
 144                 let lines = Text.splitOn "\n" txt
 145                 S.put (lnum - 1 + L.length lines)
 146                 return $
 147                         case lines of
 148                          [] -> undefined
 149                          (l0:ls) -> tl l0 <> mconcat ((\l -> "\n"<>indent<>tl l)<$>ls)
 150         go (TokenTag v) = return $ "#"<>tl v
 151         go (TokenEscape c) =
 152                 return $
 153                         if config_text_escape cfg
 154                         then tl $ Text.pack ['\\',c]
 155                         else TL.singleton c
 156         go (TokenLink lnk) = return $ tl lnk
 157         go (TokenPair grp ts) = do
 158                 ts' <- goTokens ts
 159                 return $ tl o<>ts'<>tl c
 160                 where (o,c) = pairBorders grp ts
 161         goTokens :: Tokens -> S.State Int TL.Text
 162         goTokens (Tokens ts) = do
 163                 ts' <- go`mapM`ts
 164                 return $ foldr (<>) mempty ts'
 165
 166 t_Attrs :: Attrs -> TL.Text
 167 t_Attrs = foldMap t_Attr
 168
 169 t_Attr :: (Text,Attr) -> TL.Text
 170 t_Attr (attr_white,Attr{..}) =
 171         mconcat $ tl <$>
 172          [ attr_white
 173          , attr_name
 174          , attr_open
 175          , attr_value
 176          , attr_close
 177          ]
 178
 179
 180 t_Token :: Token -> TL.Text
 181 t_Token (TokenPlain txt)  = tl txt
 182 t_Token (TokenTag v)      = "#"<>tl v
 183 t_Token (TokenEscape c)   = TL.singleton c -- tl $ Text.pack ['\\',c]
 184 t_Token (TokenLink lnk)   = tl lnk
 185 t_Token (TokenPair grp t) = tl o<>t_Tokens t<>tl c
 186         where (o,c) = pairBorders grp t
 187
 188 t_Tokens :: Tokens -> TL.Text
 189 t_Tokens (Tokens ts) = foldMap t_Token ts