Language/TCT/Write/Plain.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE ViewPatterns #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4 -- | Render a TCT file in plain Text.
   5 module Language.TCT.Write.Plain where
   6
   7 import Control.Monad (Monad(..), mapM)
   8 import Data.Bool
   9 import Data.Default.Class (Default(..))
  10 import Data.Eq (Eq(..))
  11 import Data.Foldable (Foldable(..))
  12 import Data.Function (($), (.))
  13 import Data.Functor ((<$>))
  14 import Data.Int (Int,Int64)
  15 import Data.Monoid (Monoid(..))
  16 import Data.Ord (Ord(..))
  17 import Data.Semigroup (Semigroup(..))
  18 import Data.Sequence (ViewL(..), ViewR(..))
  19 import Data.Text (Text)
  20 import Data.TreeSeq.Strict (Tree(..),Trees)
  21 import Prelude (Num(..), undefined, Integral(..))
  22 import Text.Show (Show(..))
  23 import qualified Control.Monad.Trans.State as S
  24 import qualified Data.List as L
  25 import qualified Data.Sequence as Seq
  26 import qualified Data.Text as Text
  27 import qualified Data.Text.Lazy as TL
  28
  29 import Language.TCT.Tree
  30 import Language.TCT.Cell
  31 import Language.TCT.Token
  32 import Language.TCT.Elem
  33
  34 tl :: Text -> TL.Text
  35 tl = TL.fromStrict
  36
  37 -- * Type 'Inh'
  38 data Inh
  39  =   Inh
  40  {   inh_escape :: Bool
  41  } deriving (Eq, Show)
  42 instance Default Inh where
  43         def = Inh
  44          { inh_escape = True
  45          }
  46
  47 plainify :: Inh -> Trees (Cell Key) Tokens -> TL.Text
  48 plainify inh = plainifyTreesCell inh . treePosLastCell
  49
  50 treeRackUpLeft :: Tree (Cell k) (Cell a) -> Tree (Cell k) (Cell a)
  51 treeRackUpLeft t = go t
  52         where
  53         Pos l0 c0 = posTree t
  54         rackUpLeft pos =
  55                 Pos
  56                  (linePos pos - l0 + 1)
  57                  (columnPos pos - c0 + 1)
  58         go :: Tree (Cell k) (Cell a) -> Tree (Cell k) (Cell a)
  59         go (Tree0 (Cell pos posEnd c)) =
  60                 Tree0 $ Cell (rackUpLeft pos) (rackUpLeft posEnd) c
  61         go (TreeN (Cell pos posEnd c) ts) =
  62                 TreeN
  63                  (Cell (rackUpLeft pos) (rackUpLeft posEnd) c)
  64                  (go <$> ts)
  65
  66 treePosLastCell ::
  67  Trees (Cell k) Tokens ->
  68  Trees (Pos,Cell k) (Pos,Tokens)
  69 treePosLastCell t = S.evalState (go`mapM`t) (Pos 1 1)
  70         where
  71         go :: Tree (Cell k) Tokens ->
  72               S.State Pos (Tree (Pos,Cell k) (Pos,Tokens))
  73         go (Tree0 ts) = do
  74                 lastPos <- S.get
  75                 case Seq.viewr ts of
  76                  EmptyR ->
  77                         return $ Tree0 (lastPos,ts)
  78                  _ :> cell -> do
  79                         S.put $ posEndCell cell
  80                         return $ Tree0 (lastPos,ts)
  81         go (TreeN cell ts) = do
  82                 lastPos <- S.get
  83                 S.put $ posEndCell cell
  84                 ts' <- go`mapM`ts
  85                 return $ TreeN (lastPos,cell) ts'
  86
  87 int64 :: Integral i => i -> Int64
  88 int64 = fromInteger . toInteger
  89
  90 plainifyTreeCell ::
  91  Inh ->
  92  Tree (Pos,Cell Key) (Pos,Tokens) ->
  93  TL.Text
  94 plainifyTreeCell inh (TreeN (posEnd, Cell pos _ (KeySection lvl)) ts) =
  95         plainifyIndentCell (posEnd,pos) <>
  96         TL.replicate (int64 lvl) "#" <> " " <>
  97         (case Seq.viewl ts of
  98          Tree0 (_,title) :< _ ->
  99                 plainifyIndentToken inh title
 100          _ -> "") <>
 101         plainifyTreesCell inh
 102          (case Seq.viewl ts of
 103                  Tree0{} :< ts' -> ts'
 104                  _ -> ts)
 105 plainifyTreeCell inh (Tree0 (posEnd,toks)) =
 106         case Seq.viewl toks of
 107          EmptyL -> plainifyIndentToken inh toks
 108          t0:<_  -> plainifyIndentCell (posEnd,posCell t0) <> plainifyIndentToken inh toks
 109 plainifyTreeCell inh (TreeN (posEnd,cell@(Cell pos _ _)) cs) =
 110         plainifyIndentCell (posEnd,pos) <>
 111         plainifyCellKey inh cell cs
 112
 113 plainifyIndentCell :: (Pos,Pos) -> TL.Text
 114 plainifyIndentCell (Pos lineLast colLast,Pos line col)
 115  | lineLast < line =
 116         TL.replicate (int64 $ line - (lineLast+1)) "\n" <>
 117         TL.replicate (int64 $ col - 1) " "
 118  | lineLast == line && colLast <= col =
 119         TL.replicate (int64 $ col - colLast) " "
 120  | otherwise = undefined
 121
 122 plainifyCellKey ::
 123  Inh ->
 124  Cell Key ->
 125  Trees (Pos,Cell Key) (Pos,Tokens) ->
 126  TL.Text
 127 plainifyCellKey inh (Cell _pos _posEnd key) cells = do
 128         case key of
 129          KeyColon n wh -> textKey n wh ":"
 130          KeyGreat n wh -> textKey n wh ">"
 131          KeyEqual n wh -> textKey n wh "="
 132          KeyBar   n wh -> textKey n wh "|"
 133          KeyDash       -> textKey "" "" "- "
 134          KeyDashDash   -> textKey "" "" "-- "
 135          KeyLower name attrs ->
 136                 "<" <> tl name <> plainifyAttrs attrs <>
 137                 plainifyTreesCell inh cells
 138          KeySection{} -> undefined
 139          KeyDotSlash p ->
 140                 "./" <> TL.pack p <>
 141                 plainifyTreesCell inh cells
 142         where
 143         textKey :: Text -> White -> TL.Text -> TL.Text
 144         textKey name wh mark =
 145                 tl name <> tl wh <> mark <>
 146                 plainifyTreesCell inh cells
 147
 148 plainifyTreesCell ::
 149  Inh ->
 150  Trees (Pos,Cell Key) (Pos,Tokens) ->
 151  TL.Text
 152 plainifyTreesCell inh = foldMap (plainifyTreeCell inh)
 153
 154 plainifyIndentToken :: Inh -> Tokens -> TL.Text
 155 plainifyIndentToken _cfg (Seq.viewl -> EmptyL) = ""
 156 plainifyIndentToken inh toks@(Seq.viewl -> Cell pos _ _ :< _) =
 157         goTokens toks `S.evalState` linePos pos
 158         where
 159         indent = TL.replicate (int64 $ columnPos pos - 1) " "
 160         go :: Cell Token -> S.State Int TL.Text
 161         go tok =
 162                 case unCell tok of
 163                  TokenPlain txt -> do
 164                         lnum <- S.get
 165                         let lines = Text.splitOn "\n" txt
 166                         S.put (lnum - 1 + L.length lines)
 167                         return $
 168                                 case lines of
 169                                  [] -> undefined
 170                                  (l0:ls) -> tl l0 <> mconcat ((\l -> "\n"<>indent<>tl l)<$>ls)
 171                  TokenTag v -> return $ "#"<>tl v
 172                  TokenEscape c ->
 173                         return $
 174                                 if inh_escape inh
 175                                 then tl $ Text.pack ['\\',c]
 176                                 else TL.singleton c
 177                  TokenLink lnk -> return $ tl lnk
 178                  TokenPair grp ts -> do
 179                         ts' <- goTokens ts
 180                         return $ tl o<>ts'<>tl c
 181                         where (o,c) = pairBorders grp ts
 182         goTokens :: Tokens -> S.State Int TL.Text
 183         goTokens ts = do
 184                 ts' <- go`mapM`ts
 185                 return $ foldr (<>) mempty ts'
 186
 187 plainifyAttrs :: Attrs -> TL.Text
 188 plainifyAttrs = foldMap plainifyAttr
 189
 190 plainifyAttr :: (Text,Attr) -> TL.Text
 191 plainifyAttr (attr_white,Attr{..}) =
 192         mconcat $ tl <$>
 193          [ attr_white
 194          , attr_name
 195          , attr_open
 196          , attr_value
 197          , attr_close
 198          ]
 199
 200 plainifyToken :: Token -> TL.Text
 201 plainifyToken (TokenPlain txt)  = tl txt
 202 plainifyToken (TokenTag v)      = "#"<>tl v
 203 plainifyToken (TokenEscape c)   = TL.singleton c -- tl $ Text.pack ['\\',c]
 204 plainifyToken (TokenLink lnk)   = tl lnk
 205 plainifyToken (TokenPair grp t) = tl o<>plainifyTokens t<>tl c
 206         where (o,c) = pairBorders grp t
 207
 208 plainifyTokens :: Tokens -> TL.Text
 209 plainifyTokens ts = foldMap (plainifyToken . unCell) ts