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