Language/TCT/Write/Plain.hs

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