Language/TCT/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.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 text :: Trees (Cell Key) (Cell Token) -> TL.Text
  45 text tct = foldMap t_TreeCell (treePosLastCell tct)
  46
  47 t_Value :: Text -> TL.Text
  48 t_Value v = tl v
  49
  50 int64 :: Integral i => i -> Int64
  51 int64 = fromInteger . toInteger
  52
  53 t_TreeCell :: Tree (Pos,Cell Key) (Pos,Cell Token) -> TL.Text
  54 t_TreeCell (TreeN c@(_, unCell -> KeySection lvl) ts) =
  55         t_IndentCell c <>
  56         TL.replicate (int64 lvl) "#" <> " " <>
  57         (case Seq.viewl ts of
  58          Tree0 (_,Cell posTitle _ title) :< _ -> t_IndentToken posTitle title
  59          _ -> "") <>
  60         foldMap t_TreeCell (case Seq.viewl ts of {Tree0{} :< ts' -> ts'; _ -> ts})
  61 t_TreeCell (Tree0 c@(_,cell)) =
  62         t_IndentCell c <>
  63         t_CellToken cell
  64 t_TreeCell (TreeN c@(_,cell) cs) =
  65         t_IndentCell c <>
  66         t_CellKey cell cs
  67
  68 t_IndentCell :: (Pos,Cell a) -> TL.Text
  69 t_IndentCell ((lineLast,colLast),posCell -> (line,col))
  70  | lineLast < line =
  71         TL.replicate (int64 $ line - (lineLast+1)) "\n" <>
  72         TL.replicate (int64 $ col - 1) " "
  73  | lineLast == line
  74  && colLast <= col = TL.replicate (int64 $ col - colLast) " "
  75  | otherwise = undefined
  76
  77 t_CellKey :: Cell Key -> Trees (Pos,Cell Key) (Pos,Cell Token) -> TL.Text
  78 t_CellKey (Cell _pos _posEnd key) cells = do
  79         case key of
  80          KeyColon n wh -> t_Key n wh ":"
  81          KeyGreat n wh -> t_Key n wh ">"
  82          KeyEqual n wh -> t_Key n wh "="
  83          KeyBar   n wh -> t_Key n wh "|"
  84          KeyDash -> "- " <> foldMap t_TreeCell cells
  85          KeyLower name attrs ->
  86                 "<" <> tl name <> t_Attrs attrs <>
  87                 foldMap t_TreeCell cells
  88         where
  89         t_Key :: Text -> White -> TL.Text -> TL.Text
  90         t_Key name wh mark = tl name <> tl wh <> mark <> foldMap t_TreeCell cells
  91
  92 t_CellToken :: Cell Token -> TL.Text
  93 t_CellToken (Cell pos _posEnd tok) =
  94         t_IndentToken pos tok
  95
  96 t_Token :: Token -> TL.Text
  97 t_Token (TokenPlain txt) = tl txt
  98 t_Token (TokenTag v) = "#"<>tl v
  99 t_Token (TokenEscape c) = tl $ Text.pack ['\\',c]
 100 t_Token (TokenLink lnk) = tl lnk
 101 t_Token (TokenGroup grp t) = tl o<>t_Token t<>tl c
 102         where (o,c) = groupBorders grp t
 103 t_Token (Tokens ts) = foldMap t_Token ts
 104
 105 t_IndentToken :: Pos -> Token -> TL.Text
 106 t_IndentToken pos tok = go tok `S.evalState` linePos pos
 107         where
 108         indent = TL.replicate (int64 $ columnPos pos - 1) " "
 109         go :: Token -> S.State Int TL.Text
 110         go (TokenPlain txt) = do
 111                 lin <- S.get
 112                 let lines = Text.splitOn "\n" txt
 113                 let lnums = tl : -- TODO: fmap
 114                          [ \line -> "\n"<>indent<>tl line
 115                          | _lnum <- [lin+1..]
 116                          ]
 117                 S.put (lin - 1 + L.length lines)
 118                 return $ mconcat $ L.zipWith ($) lnums lines
 119         go (TokenTag v) = return $ "#"<>tl v
 120         go (TokenEscape c) = return $ tl $ Text.pack ['\\',c]
 121         go (TokenLink lnk) = return $ tl lnk
 122         go (TokenGroup grp t) = do
 123                 t' <- go t
 124                 return $ tl o<>t'<>tl c
 125                 where (o,c) = groupBorders grp t
 126         go (Tokens ts) = do
 127                 ts' <- go`mapM`ts
 128                 return $ foldr (<>) mempty ts'
 129
 130 t_Attrs :: Attrs -> TL.Text
 131 t_Attrs = foldMap t_Attr
 132
 133 t_Attr :: (Text,Attr) -> TL.Text
 134 t_Attr (attr_white,Attr{..}) =
 135         mconcat $ tl <$>
 136          [ attr_white
 137          , attr_name
 138          , attr_open
 139          , attr_value
 140          , attr_close
 141          ]
 142
 143 treePosLastCell :: Trees (Cell k) (Cell a) -> Trees (Pos,Cell k) (Pos,Cell a)
 144 treePosLastCell t = S.evalState (go`mapM`t) (1,1)
 145         where
 146         go :: Tree (Cell k) (Cell a) ->
 147               S.State (Int, Int) (Tree (Pos, Cell k) (Pos, Cell a))
 148         go (Tree0 cell) = do
 149                 lastPos <- S.get
 150                 S.put $ posEndCell cell
 151                 return $ Tree0 (lastPos,cell)
 152         go (TreeN cell ts) = do
 153                 lastPos <- S.get
 154                 S.put $ posEndCell cell
 155                 ts' <- go`mapM`ts
 156                 return $ TreeN (lastPos,cell) ts'
 157
 158 {-
 159 t_TreeCell :: [Key] -> Tree (Cell Key) (Cell Token) -> TL.Text
 160 t_TreeCell path (TreeN (unCell -> key@KeySection{}) ts) =
 161         case Seq.viewl ts of
 162          Tree0 (Cell _posTitle _ (TokenPlain title)) :< _ ->
 163                 D.section ! DA.name (attrValue title) $
 164                         d_content
 165          Tree0 (Cell _posTitle _ title) :< _ ->
 166                 D.section $ do
 167                         D.name $ d_Token (key:path) title
 168                         d_content
 169          _ -> D.section d_content
 170         where
 171         d_content = forM_ (case Seq.viewl ts of {Tree0{} :< ts' -> ts'; _ -> ts}) $ d_TreeCell (key:path)
 172 t_TreeCell path (Tree0 cell) = d_CellToken path cell
 173 t_TreeCell path (TreeN cell ts) = d_CellKey path cell ts
 174
 175 t_CellKey :: [Key] -> Cell Key -> Trees (Cell Key) (Cell Token) -> TL.Text
 176 t_CellKey path (Cell _pos _posEnd key) cells = do
 177         case key of
 178          KeyColon n _wh -> d_Key n
 179          KeyGreat n _wh -> d_Key n
 180          KeyEqual n _wh -> d_Key n
 181          KeyBar   n _wh -> d_Key n
 182          KeyDash -> "- " <> foldMap (d_TreeCell (key:path)) cells
 183          {-
 184          KeyLower name attrs -> do
 185                 B.Content $ "<"<>B.toMarkup name
 186                 d_Attrs attrs
 187                 forM_ cells $ d_TreeCell path
 188          -}
 189         where
 190         d_Key :: Text -> TL.Text
 191         d_Key name = do
 192                 B.CustomParent (B.Text name) $
 193                         forM_ cells $ d_TreeCell (key:path)
 194
 195 t_CellToken :: [Key] -> Cell Token -> TL.Text
 196 t_CellToken path (Cell _pos _posEnd tok) =
 197         -- case L.find (\case KeySection{} -> True; _ -> False) $ dbg "d_CellToken: path:" path of
 198         case dbg "d_CellToken: path" path of
 199          KeySection{}:_ ->
 200                 case tok of
 201                  TokenGroup GroupElem{} _t -> d_Token path tok
 202                  _ -> D.para $ d_Token path tok
 203          _ -> d_Token path tok
 204 -}