Language/TCT/Write/Plain.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE ViewPatterns #-}
   4 {-# OPTIONS_GHC -fno-warn-orphans #-}
   5 module Language.TCT.Write.Plain where
   6
   7 import Control.Applicative (Applicative(..), liftA2)
   8 import Control.Monad (Monad(..), mapM)
   9 import Data.Bool
  10 import Data.Char (Char)
  11 import Data.Default.Class (Default(..))
  12 import Data.Eq (Eq(..))
  13 import Data.Foldable (Foldable(..))
  14 import Data.Function (($), (.))
  15 import Data.Functor ((<$>))
  16 import Data.Int (Int64)
  17 import Data.Maybe (Maybe(..))
  18 import Data.Monoid (Monoid(..))
  19 import Data.Ord (Ord(..))
  20 import Data.Semigroup (Semigroup(..))
  21 import Data.Sequence (Seq, ViewL(..))
  22 import Data.String (String, IsString(..))
  23 import Data.Text (Text)
  24 import Data.TreeSeq.Strict (Tree(..),Trees)
  25 import Data.Tuple (fst)
  26 import Prelude (Num(..), undefined, Integral(..))
  27 import Text.Show (Show(..))
  28 import qualified Control.Monad.Trans.State as S
  29 import qualified Data.Sequence as Seq
  30 import qualified Data.Text as Text
  31 import qualified Data.Text.Lazy as TL
  32 import qualified Data.Text.Lazy.Builder as TLB
  33
  34 -- import Language.TCT.Tree
  35 import Language.TCT.Token
  36 import Language.TCT.Cell
  37 import Language.TCT.Elem
  38 import Language.TCT.Read.Token
  39
  40 -- * Type 'Plain'
  41 type Plain = S.State State TLB.Builder
  42  -- NOTE: To get maximum performance when building lazy Text values using a builder,
  43  --       associate mappend calls to the right.
  44  -- NOTE: (Semigroup.<>) associates to the right.
  45 instance IsString Plain where
  46         fromString = return . fromString
  47 instance Semigroup Plain where
  48         (<>) = liftA2 (<>)
  49 instance Monoid Plain where
  50         mempty  = return ""
  51         mappend = (<>)
  52
  53 runPlain :: Plain -> State -> TL.Text
  54 runPlain p s = TLB.toLazyText $ fst $ S.runState p s
  55
  56 text :: Plainify a => State -> a -> TL.Text
  57 text st a = runPlain (plainify a) st
  58
  59 -- ** Type 'State'
  60 data State
  61  =   State
  62  {   state_escape :: Bool -- FIXME: useful?
  63  ,   state_pos    :: Pos
  64  } deriving (Eq, Show)
  65 instance Default State where
  66         def = State
  67          { state_escape = True
  68          , state_pos    = pos1
  69          }
  70
  71 -- * Class 'Plainify'
  72 class Plainify a where
  73         plainify :: a -> Plain
  74 instance Plainify () where
  75         plainify = mempty
  76 instance Plainify Char where
  77         plainify = return . TLB.singleton
  78 instance Plainify String where
  79         plainify = return . fromString
  80 instance Plainify Text where
  81         plainify = plainify . TL.fromStrict
  82 instance Plainify TL.Text where
  83         plainify = return . TLB.fromLazyText
  84 instance Plainify a => Plainify (Cell a) where
  85         plainify (Cell _bp@(Pos line col) ep a) = do
  86                 Pos lineLast colLast <- S.gets state_pos
  87                 case () of
  88                  _ | lineLast < line -> do
  89                         S.modify $ \s -> s{state_pos=ep}
  90                         plainify (Text.replicate (line - lineLast - 1) "\n")
  91                          <> plainify (Text.replicate (col - 1) " ")
  92                          <> plainify a
  93                  _ | lineLast == line && colLast <= col -> do
  94                         S.modify $ \s -> s{state_pos=ep}
  95                         plainify (Text.replicate (col - colLast) " ")
  96                          <> plainify a
  97                  _ -> undefined
  98 instance Plainify (Trees (Cell Key) Tokens) where
  99         plainify = foldMap plainify
 100 instance Plainify (Tree (Cell Key) Tokens) where
 101         plainify = \case
 102          TreeN (Cell bp ep k) ts -> plainify (Cell bp ep (k,ts))
 103          Tree0 ts -> plainify ts
 104 instance Plainify (Key, Trees (Cell Key) Tokens) where
 105         plainify (key, ts) =
 106                 case key of
 107                  KeyColon n wh -> textKey n wh ":"
 108                  KeyGreat n wh -> textKey n wh ">"
 109                  KeyEqual n wh -> textKey n wh "="
 110                  KeyBar   n wh -> textKey n wh "|"
 111                  KeyDash       -> textKey "" "" "- "
 112                  KeyDashDash   -> textKey "" "" "-- "
 113                  KeyLower name attrs ->
 114                         "<" <>
 115                         plainify name <>
 116                         plainify attrs <>
 117                         plainify ts
 118                  KeySection lvl ->
 119                         plainify (TL.replicate (int64 lvl) "#") <>
 120                         case Seq.viewl ts of
 121                          Tree0 title :< ts' ->
 122                                 plainify title <>
 123                                 plainify ts'
 124                          _ -> plainify ts
 125                  KeyDotSlash p ->
 126                         plainify ("./"::TL.Text) <>
 127                         plainify p <>
 128                         plainify ts
 129                 where
 130                 textKey :: Text -> White -> TL.Text -> Plain
 131                 textKey name wh mark =
 132                         plainify name <>
 133                         plainify wh <>
 134                         plainify mark <>
 135                         plainify ts
 136 instance Plainify Tokens where
 137         plainify = foldMap plainify
 138 instance Plainify Token where
 139         plainify = \case
 140          TreeN (Cell bp ep k) ts ->
 141                 plainify (Cell bp ep ()) <>
 142                 plainify o <> plainify ts <> plainify c
 143                 where (o,c) = pairBorders k ts
 144          Tree0 tok ->
 145                 -- plainify (Cell bp ep ()) <>
 146                 case tok of
 147                  TokenPhrases p -> plainify p
 148                  TokenRaw t -> plainify t
 149                         {- TODO: remove
 150                         lnum <- S.get
 151                         let lines = Text.splitOn "\n" txt
 152                         S.put (lnum - 1 + List.length lines)
 153                         return $
 154                                 case lines of
 155                                  [] -> undefined
 156                                  (l0:ls) -> plainify l0 <> mconcat ((\l -> "\n"<>indent<>plainify l)<$>ls)
 157                         -}
 158                  TokenTag v -> plainify $ ("#"<>) <$> v
 159                  TokenEscape c -> do
 160                         esc <- S.gets state_escape
 161                         if esc
 162                          then plainify $ (('\\' :) . pure) <$> c
 163                          else plainify c
 164                  TokenLink lnk -> plainify lnk
 165 instance Plainify Phrases where
 166         plainify = foldMap plainify
 167 instance Plainify Phrase where
 168         plainify p =
 169                 case p of
 170                  PhraseWord  t -> plainify t
 171                  PhraseWhite t -> plainify t
 172                  PhraseOther t -> plainify t
 173 instance Plainify ElemAttrs where
 174         plainify = foldMap plainify
 175 instance Plainify (Text,ElemAttr) where
 176         plainify (elemAttr_white,ElemAttr{..}) =
 177                 mconcat $ plainify <$>
 178                  [ elemAttr_white
 179                  , elemAttr_name
 180                  , elemAttr_open
 181                  , elemAttr_value
 182                  , elemAttr_close
 183                  ]
 184
 185 {-
 186 -- * Class 'Textify'
 187 class Textify a where
 188         plainify :: a -> TL.Text
 189 instance Textify Text where
 190         plainify = TL.fromStrict
 191 instance Textify TL.Text where
 192         plainify = id
 193 instance Textify Tokens where
 194         plainify = foldMap plainify
 195 instance Textify Token where
 196         plainify = \case
 197          TreeN (unCell -> p) ts -> plainify o<>plainify ts<>plainify c
 198                 where (o,c) = pairBorders p ts
 199          Tree0 (unCell -> t) ->
 200                 case t of
 201                  TokenPlain txt -> plainify txt
 202                  TokenTag v     -> "#"<>plainify v
 203                  TokenEscape c  -> TL.singleton c -- plainify $ Text.pack ['\\',c]
 204                  TokenLink lnk  -> plainify lnk
 205 -}
 206
 207 -- * Class 'RackUpLeft'
 208 class RackUpLeft a where
 209         rackUpLeft :: a -> S.State (Maybe Pos) a
 210 instance RackUpLeft Pos where
 211         rackUpLeft pos@Pos{..} = do
 212                 S.get >>= \case
 213                  Nothing -> return pos
 214                  Just (Pos l0 c0) ->
 215                         return Pos
 216                          { linePos   = linePos   - l0 + 1
 217                          , columnPos = columnPos - c0 + 1
 218                          }
 219 instance RackUpLeft (Cell a) where
 220         rackUpLeft (Cell bp ep a) = do
 221                 S.modify $ \case
 222                  Nothing -> Just bp
 223                  p -> p
 224                 Cell
 225                  <$> rackUpLeft bp
 226                  <*> rackUpLeft ep
 227                  <*> pure a
 228 instance RackUpLeft a => RackUpLeft (Seq a) where
 229         rackUpLeft = mapM rackUpLeft
 230 instance (RackUpLeft k, RackUpLeft a) => RackUpLeft (Tree k a) where
 231         rackUpLeft = \case
 232          Tree0 a    -> Tree0 <$> rackUpLeft a
 233          TreeN k ts -> TreeN <$> rackUpLeft k <*> rackUpLeft ts
 234
 235 {-
 236 -- * Utilities
 237 plainifyIndentCell :: (Pos,Pos) -> Plain
 238 plainifyIndentCell (Pos lineLast colLast,Pos line col)
 239  | lineLast < line =
 240         return $
 241         TL.replicate (int64 $ line - (lineLast+1)) "\n" <>
 242         TL.replicate (int64 $ col - 1) " "
 243  | lineLast == line && colLast <= col =
 244         return $
 245         TL.replicate (int64 $ col - colLast) " "
 246  | otherwise = undefined
 247
 248 -- ** 'Tree'
 249
 250 treePosLastCell ::
 251  Trees (Cell k) Tokens ->
 252  Trees (Pos,Cell k) (Pos,Tokens)
 253 treePosLastCell t = S.evalState (go`mapM`t) (Pos 1 1)
 254         where
 255         go :: Tree (Cell k) Tokens ->
 256               S.State Pos (Tree (Pos,Cell k) (Pos,Tokens))
 257         go (Tree0 ts) = do
 258                 lastPos <- S.get
 259                 case Seq.viewr ts of
 260                  EmptyR ->
 261                         return $ Tree0 (lastPos,ts)
 262                  _ :> r -> do
 263                         S.put $ posEndTree r
 264                         return $ Tree0 (lastPos,ts)
 265         go (TreeN p ts) = do
 266                 lastPos <- S.get
 267                 S.put $ posEndCell p
 268                 ts' <- go`mapM`ts
 269                 return $ TreeN (lastPos,p) ts'
 270 -}
 271
 272 -- ** 'Int64'
 273 int64 :: Integral i => i -> Int64
 274 int64 = fromInteger . toInteger