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