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