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         where
 141         t_Key :: Text -> White -> TL.Text -> TL.Text
 142         t_Key name wh mark =
 143                 tl name <> tl wh <> mark <>
 144                 t_TreesCell cfg cells
 145
 146 t_TreesCell ::
 147  Config_Text ->
 148  Trees (Pos,Cell Key) (Pos,Cell Tokens) ->
 149  TL.Text
 150 t_TreesCell cfg = foldMap (t_TreeCell cfg)
 151
 152 t_CellToken :: Config_Text -> Cell Tokens -> TL.Text
 153 t_CellToken cfg (Cell pos _posEnd tok) =
 154         t_IndentToken cfg pos tok
 155
 156 t_IndentToken :: Config_Text -> Pos -> Tokens -> TL.Text
 157 t_IndentToken cfg pos toks = goTokens toks `S.evalState` linePos pos
 158         where
 159         indent = TL.replicate (int64 $ columnPos pos - 1) " "
 160         go :: Token -> S.State Int TL.Text
 161         go (TokenPlain txt) = do
 162                 lnum <- S.get
 163                 let lines = Text.splitOn "\n" txt
 164                 S.put (lnum - 1 + L.length lines)
 165                 return $
 166                         case lines of
 167                          [] -> undefined
 168                          (l0:ls) -> tl l0 <> mconcat ((\l -> "\n"<>indent<>tl l)<$>ls)
 169         go (TokenTag v) = return $ "#"<>tl v
 170         go (TokenEscape c) =
 171                 return $
 172                         if config_text_escape cfg
 173                         then tl $ Text.pack ['\\',c]
 174                         else TL.singleton c
 175         go (TokenLink lnk) = return $ tl lnk
 176         go (TokenPair grp ts) = do
 177                 ts' <- goTokens ts
 178                 return $ tl o<>ts'<>tl c
 179                 where (o,c) = pairBorders grp ts
 180         goTokens :: Tokens -> S.State Int TL.Text
 181         goTokens (Tokens ts) = do
 182                 ts' <- go`mapM`ts
 183                 return $ foldr (<>) mempty ts'
 184
 185 t_Attrs :: Attrs -> TL.Text
 186 t_Attrs = foldMap t_Attr
 187
 188 t_Attr :: (Text,Attr) -> TL.Text
 189 t_Attr (attr_white,Attr{..}) =
 190         mconcat $ tl <$>
 191          [ attr_white
 192          , attr_name
 193          , attr_open
 194          , attr_value
 195          , attr_close
 196          ]
 197
 198 t_Token :: Token -> TL.Text
 199 t_Token (TokenPlain txt)  = tl txt
 200 t_Token (TokenTag v)      = "#"<>tl v
 201 t_Token (TokenEscape c)   = TL.singleton c -- tl $ Text.pack ['\\',c]
 202 t_Token (TokenLink lnk)   = tl lnk
 203 t_Token (TokenPair grp t) = tl o<>t_Tokens t<>tl c
 204         where (o,c) = pairBorders grp t
 205
 206 t_Tokens :: Tokens -> TL.Text
 207 t_Tokens (Tokens ts) = foldMap t_Token ts