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,posCell 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                  Cell pos _ _ :< _ -> do
 126                         st <- R.ask
 127                         return $ goTokens st toks `S.evalState` linePos pos
 128                         where
 129                         indent = TL.replicate (int64 $ columnPos pos - 1) " "
 130                         go :: State -> Cell Token -> S.State Int TL.Text
 131                         go st@State{..} tok =
 132                                 case unCell tok of
 133                                  TokenPlain txt -> do
 134                                         lnum <- S.get
 135                                         let lines = Text.splitOn "\n" txt
 136                                         S.put (lnum - 1 + L.length lines)
 137                                         return $
 138                                                 case lines of
 139                                                  [] -> undefined
 140                                                  (l0:ls) -> textify l0 <> mconcat ((\l -> "\n"<>indent<>textify l)<$>ls)
 141                                  TokenTag v -> return $ "#"<>textify v
 142                                  TokenEscape c -> do
 143                                         return $
 144                                                 if state_escape
 145                                                 then textify $ Text.pack ['\\',c]
 146                                                 else TL.singleton c
 147                                  TokenLink lnk -> return $ textify lnk
 148                                  TokenPair grp ts -> do
 149                                         ts' <- goTokens st ts
 150                                         return $ textify o<>ts'<>textify c
 151                                         where (o,c) = pairBorders grp ts
 152                         goTokens :: State -> Tokens -> S.State Int TL.Text
 153                         goTokens st ts = do
 154                                 ts' <- go st`mapM`ts
 155                                 return $ foldr (<>) mempty ts'
 156 instance Plainify Attrs where
 157         plainify = plainify . textify
 158
 159 -- * Class 'Textify'
 160 class Textify a where
 161         textify :: a -> TL.Text
 162 instance Textify Text where
 163         textify = TL.fromStrict
 164 instance Textify TL.Text where
 165         textify = id
 166 instance Textify Attrs where
 167         textify = foldMap textify
 168 instance Textify (Text,Attr) where
 169         textify (attr_white,Attr{..}) =
 170                 mconcat $ textify <$>
 171                  [ attr_white
 172                  , attr_name
 173                  , attr_open
 174                  , attr_value
 175                  , attr_close
 176                  ]
 177 instance Textify Token where
 178         textify (TokenPlain txt)  = textify txt
 179         textify (TokenTag v)      = "#"<>textify v
 180         textify (TokenEscape c)   = TL.singleton c -- textify $ Text.pack ['\\',c]
 181         textify (TokenLink lnk)   = textify lnk
 182         textify (TokenPair grp t) = textify o<>textify t<>textify c
 183                 where (o,c) = pairBorders grp t
 184 instance Textify Tokens where
 185         textify ts = foldMap (textify . unCell) ts
 186
 187 -- * Utilities
 188
 189 plainifyIndentCell :: (Pos,Pos) -> Plain
 190 plainifyIndentCell (Pos lineLast colLast,Pos line col)
 191  | lineLast < line =
 192         return $
 193         TL.replicate (int64 $ line - (lineLast+1)) "\n" <>
 194         TL.replicate (int64 $ col - 1) " "
 195  | lineLast == line && colLast <= col =
 196         return $
 197         TL.replicate (int64 $ col - colLast) " "
 198  | otherwise = undefined
 199
 200 -- ** 'Tree'
 201 treeRackUpLeft :: Tree (Cell k) (Cell a) -> Tree (Cell k) (Cell a)
 202 treeRackUpLeft t = go t
 203         where
 204         Pos l0 c0 = posTree t
 205         rackUpLeft pos =
 206                 Pos
 207                  (linePos pos - l0 + 1)
 208                  (columnPos pos - c0 + 1)
 209         go :: Tree (Cell k) (Cell a) -> Tree (Cell k) (Cell a)
 210         go (Tree0 (Cell pos posEnd c)) =
 211                 Tree0 $ Cell (rackUpLeft pos) (rackUpLeft posEnd) c
 212         go (TreeN (Cell pos posEnd c) ts) =
 213                 TreeN
 214                  (Cell (rackUpLeft pos) (rackUpLeft posEnd) c)
 215                  (go <$> ts)
 216
 217 treePosLastCell ::
 218  Trees (Cell k) Tokens ->
 219  Trees (Pos,Cell k) (Pos,Tokens)
 220 treePosLastCell t = S.evalState (go`mapM`t) (Pos 1 1)
 221         where
 222         go :: Tree (Cell k) Tokens ->
 223               S.State Pos (Tree (Pos,Cell k) (Pos,Tokens))
 224         go (Tree0 ts) = do
 225                 lastPos <- S.get
 226                 case Seq.viewr ts of
 227                  EmptyR ->
 228                         return $ Tree0 (lastPos,ts)
 229                  _ :> cell -> do
 230                         S.put $ posEndCell cell
 231                         return $ Tree0 (lastPos,ts)
 232         go (TreeN cell ts) = do
 233                 lastPos <- S.get
 234                 S.put $ posEndCell cell
 235                 ts' <- go`mapM`ts
 236                 return $ TreeN (lastPos,cell) ts'
 237
 238 -- ** 'Int64'
 239 int64 :: Integral i => i -> Int64
 240 int64 = fromInteger . toInteger