Language/TCT/Read/Tree.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE Rank2Types #-}
   4 {-# LANGUAGE ScopedTypeVariables #-}
   5 {-# LANGUAGE TupleSections #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7 {-# LANGUAGE ViewPatterns #-}
   8 module Language.TCT.Read.Tree where
   9
  10 import Control.Applicative (Applicative(..), Alternative(..))
  11 import Control.Monad (Monad(..), void)
  12 import Data.Bool
  13 import Data.Eq (Eq(..))
  14 import Data.Function (($), (.))
  15 import Data.Functor ((<$>), ($>), (<$))
  16 import Data.Maybe (Maybe(..))
  17 import Data.Monoid (Monoid(..))
  18 import Data.Semigroup (Semigroup(..))
  19 import Data.TreeSeq.Strict (Tree(..), Trees)
  20 import qualified Data.List as List
  21 import qualified Data.Sequence as Seq
  22 import qualified Data.Text.Lazy as TL
  23 import qualified Text.Megaparsec as P
  24 import qualified Text.Megaparsec.Char as P
  25
  26 import Language.TCT.Debug
  27 import Language.TCT.Cell
  28 import Language.TCT.Tree
  29 import Language.TCT.Read.Cell
  30 import Language.TCT.Read.Elem
  31 import Language.TCT.Read.Token
  32
  33 p_CellHeader :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
  34 p_CellHeader row = debugParser "CellHeader" $ do
  35         P.skipMany $ P.char ' '
  36         pos <- p_Position
  37         header <- debugParser "Header" $
  38                 P.choice $
  39                  [ P.try $ P.char '-' >>
  40                         P.char ' ' $> HeaderDash <|>
  41                         P.string "- " $> HeaderDashDash
  42                  , P.try $ HeaderDot
  43                          <$> p_Digits
  44                          <* P.char '.'
  45                          <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy $ \c -> c=='\n'||c==' '))
  46                  , P.try $ P.some (P.char '#') <* P.lookAhead (P.try $ P.char ' ') >>= \hs ->
  47                         return $ HeaderSection $ List.length hs
  48                  , P.try $
  49                         HeaderBrackets
  50                          <$> P.between (P.string "[") (P.string "]") p_Name
  51                          <*  P.lookAhead (P.try $ P.eof <|> void (P.satisfy (=='\n')))
  52                  , P.try $
  53                         (\f -> HeaderDotSlash $ "./"<>f)
  54                          <$  P.string "./"
  55                          <*> P.many (P.satisfy (/='\n'))
  56                  , do
  57                         name <- p_Name
  58                         wh <- p_HSpaces
  59                         P.choice
  60                          [ P.try $ HeaderColon name wh
  61                                  <$ P.char ':'
  62                                  <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy $ \c -> c=='\n'||c==' '))
  63                          , P.char '>' $> HeaderGreat name wh
  64                          , P.char '=' $> HeaderEqual name wh
  65                          , P.char '|' $> HeaderBar   name wh
  66                          ]
  67                  ]
  68         posEnd <- p_Position
  69         let row' = Tree (Cell pos posEnd $ NodeHeader header) mempty : row
  70         case header of
  71          HeaderSection{}  -> p_CellEnd  row'
  72          HeaderDash{}     -> p_Row      row'
  73          HeaderDashDash{} -> p_CellText row'
  74          HeaderDot{}      -> p_Row      row'
  75          HeaderColon{}    -> p_Row      row'
  76          HeaderBrackets{} -> p_Row      row'
  77          HeaderGreat{}    -> p_Row      row'
  78          HeaderEqual{}    -> p_CellEnd  row'
  79          HeaderBar{}      -> p_CellEnd  row'
  80          HeaderDotSlash{} -> p_CellEnd  row'
  81          -- HeaderLower{}    -> undefined -- NOTE: handled in 'p_CellLower'
  82          -- TODO: move to a NodeLower
  83          -- HeaderPara       -> undefined -- NOTE: only introduced later in 'appendRow'
  84
  85 p_Name :: P.Tokens s ~ TL.Text => Parser e s Name
  86 p_Name = p_AlphaNums
  87         {-
  88         (\h t -> Text.pack (h:t))
  89          <$> (P.satisfy $ \c -> Char.isAlphaNum c || c=='_')
  90          <*> P.takeWhile1P (P.satisfy $ \c -> Char.isAlphaNum c || c=='-' || c=='_')
  91         -}
  92
  93 p_Line :: P.Tokens s ~ TL.Text => Parser e s TL.Text
  94 p_Line = P.takeWhileP (Just "Line") (/='\n')
  95
  96 p_Line1 :: P.Tokens s ~ TL.Text => Parser e s TL.Text
  97 p_Line1 = P.takeWhile1P (Just "Line") (/='\n')
  98
  99 p_CellLower :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
 100 p_CellLower row = debugParser "CellLower" $ do
 101         indent   <- p_HSpaces
 102         pos      <- p_Position
 103         void     $  P.char '<'
 104         name     <- p_Name
 105         attrs    <- p_ElemAttrs
 106         posClose <- p_Position
 107         let treeHere =
 108                 Tree (Cell pos posClose $ NodeLower name attrs) .
 109                 Seq.singleton . Tree0 . (NodeText <$>)
 110         let treeElem hasContent nod (Cell _ p t) =
 111                 let (o,_) = bs $ PairElem name attrs in
 112                 Tree0 $ Cell pos p $ nod $ o<>t
 113                 where
 114                 bs | hasContent = pairBordersDouble
 115                    | otherwise  = pairBordersSingle
 116         cel <-
 117                 P.try (P.char '>' >> treeElem True NodeText <$> p_CellLinesUntilElemEnd indent name) <|>
 118                 P.try (P.char '\n' >> P.tokens (==) indent >> treeHere <$> p_CellLines indent) <|>
 119                 P.try (P.tokens (==) "/>" >> treeElem False NodeText <$> p_CellLine) <|>
 120                 (P.eof $> treeHere (Cell posClose posClose ""))
 121         return $ cel : row
 122         where
 123         p_CellLine :: P.Tokens s ~ TL.Text => Parser e s (Cell TL.Text)
 124         p_CellLine = p_Cell p_Line
 125         p_CellLines :: P.Tokens s ~ TL.Text => P.Tokens TL.Text -> Parser e s (Cell TL.Text)
 126         p_CellLines indent =
 127                 -- TODO: optimize special case indent == "" ?
 128                 p_Cell $
 129                         TL.intercalate "\n"
 130                          <$> P.sepBy (P.try p_Line)
 131                                  (P.try $ P.char '\n' >> P.tokens (==) indent)
 132         p_CellLinesUntilElemEnd :: P.Tokens s ~ TL.Text => P.Tokens TL.Text -> Name -> Parser e s (Cell TL.Text)
 133         p_CellLinesUntilElemEnd indent name =
 134                 p_Cell $ TL.intercalate "\n" . List.reverse <$> go []
 135                 -- TODO: optimize merging, and maybe case indent == ""
 136                 where
 137                 go :: P.Tokens s ~ TL.Text => [TL.Text] -> Parser e s [TL.Text]
 138                 go ls =
 139                         let end = "</" <> name in
 140                         P.try ((\w l -> w <> end <> l : ls)
 141                          <$> p_HSpaces
 142                          <*  P.tokens (==) end
 143                          <*> p_Line) <|>
 144                         (p_Line >>= \l -> P.try $
 145                                 P.char '\n'
 146                                  >> P.tokens (==) indent
 147                                  >> go (l:ls))
 148
 149 p_CellText :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
 150 p_CellText row = debugParser "CellText" $ do
 151         P.skipMany $ P.char ' '
 152         n <- p_Cell $ NodeText <$> p_Line1
 153         return $ Tree0 n : row
 154
 155 p_CellSpaces :: Row -> Parser e s Row
 156 p_CellSpaces row = debugParser "CellSpaces" $ do
 157         P.skipSome $ P.char ' '
 158         pos <- p_Position
 159         return $ Tree0 (Cell pos pos $ NodeText "") : row
 160
 161 p_CellEnd :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
 162 p_CellEnd row = debugParser "CellEnd" $
 163         P.try (p_CellLower row) <|>
 164         P.try (p_CellText row) <|>
 165         p_CellSpaces row <|>
 166         return row
 167
 168 p_Row :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
 169 p_Row row = debugParser "Row" $
 170         P.try (p_CellHeader row) <|>
 171         p_CellEnd row
 172
 173 p_Rows :: P.Tokens s ~ TL.Text => Rows -> Parser e s Rows
 174 p_Rows rows =
 175         p_Row [] >>= \row ->
 176                 let rows' = rows `appendRow` List.reverse row in
 177                 (P.eof $> rows') <|>
 178                 (P.newline >> P.eof $> rows' <|> p_Rows rows')
 179
 180 p_Trees :: P.Tokens s ~ TL.Text => Parser e s (Trees (Cell Node))
 181 p_Trees = collapseRows <$> p_Rows initRows