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 (TokenPair grp t) = tl o<>t_Token t<>tl c
 102         where (o,c) = pairBorders 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 (TokenPair grp t) = do
 123                 t' <- go t
 124                 return $ tl o<>t'<>tl c
 125                 where (o,c) = pairBorders 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'