Language/TCT/Read/Tree.hs

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