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_CellRaw  row'
  74          HeaderDot{}      -> p_Row      row'
  75          HeaderColon{}    -> p_Row      row'
  76          HeaderBrackets{} -> p_Row      row'
  77          HeaderGreat{}    -> p_Row      row'
  78          HeaderEqual{}    -> p_CellRaw  row'
  79          HeaderBar{}      -> p_CellRaw  row'
  80          HeaderDotSlash{} -> p_CellEnd  row'
  81
  82 p_Name :: P.Tokens s ~ TL.Text => Parser e s Name
  83 p_Name = p_AlphaNums
  84         {-
  85         (\h t -> Text.pack (h:t))
  86          <$> (P.satisfy $ \c -> Char.isAlphaNum c || c=='_')
  87          <*> P.takeWhile1P (P.satisfy $ \c -> Char.isAlphaNum c || c=='-' || c=='_')
  88         -}
  89
  90 p_Line :: P.Tokens s ~ TL.Text => Parser e s TL.Text
  91 p_Line = P.takeWhileP (Just "Line") (/='\n')
  92
  93 p_Line1 :: P.Tokens s ~ TL.Text => Parser e s TL.Text
  94 p_Line1 = P.takeWhile1P (Just "Line") (/='\n')
  95
  96 p_CellLower :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
  97 p_CellLower row = debugParser "CellLower" $ do
  98         indent   <- p_HSpaces
  99         pos      <- p_Position
 100         void     $  P.char '<'
 101         name     <- p_Name
 102         attrs    <- p_ElemAttrs
 103         posClose <- p_Position
 104         let treeHere =
 105                 Tree (Cell pos posClose $ NodeLower name attrs) .
 106                 Seq.singleton . Tree0 . (NodeText <$>)
 107         let treeElem hasContent nod (Cell _ p t) =
 108                 let (o,_) = bs $ PairElem name attrs in
 109                 Tree0 $ Cell pos p $ nod $ o<>t
 110                 where
 111                 bs | hasContent = pairBordersDouble
 112                    | otherwise  = pairBordersSingle
 113         cel <-
 114                 P.try (P.char '>' >> treeElem True NodeText <$> p_CellLinesUntilElemEnd indent name) <|>
 115                 P.try (P.char '\n' >> P.tokens (==) indent >> treeHere <$> p_CellLines indent) <|>
 116                 P.try (P.tokens (==) "/>" >> treeElem False NodeText <$> p_CellLine) <|>
 117                 (P.eof $> treeHere (Cell posClose posClose ""))
 118         return $ cel : row
 119         where
 120         p_CellLine :: P.Tokens s ~ TL.Text => Parser e s (Cell TL.Text)
 121         p_CellLine = p_Cell p_Line
 122         p_CellLines :: P.Tokens s ~ TL.Text => P.Tokens TL.Text -> Parser e s (Cell TL.Text)
 123         p_CellLines indent =
 124                 -- TODO: optimize special case indent == "" ?
 125                 p_Cell $
 126                         TL.intercalate "\n"
 127                          <$> P.sepBy (P.try p_Line)
 128                                  (P.try $ P.char '\n' >> P.tokens (==) indent)
 129         p_CellLinesUntilElemEnd :: P.Tokens s ~ TL.Text => P.Tokens TL.Text -> Name -> Parser e s (Cell TL.Text)
 130         p_CellLinesUntilElemEnd indent name =
 131                 p_Cell $ TL.intercalate "\n" . List.reverse <$> go []
 132                 -- TODO: optimize merging, and maybe case indent == ""
 133                 where
 134                 go :: P.Tokens s ~ TL.Text => [TL.Text] -> Parser e s [TL.Text]
 135                 go ls =
 136                         let end = "</" <> name in
 137                         P.try ((\w l -> w <> end <> l : ls)
 138                          <$> p_HSpaces
 139                          <*  P.tokens (==) end
 140                          <*> p_Line) <|>
 141                         (p_Line >>= \l -> P.try $
 142                                 P.char '\n'
 143                                  >> P.tokens (==) indent
 144                                  >> go (l:ls))
 145
 146 p_CellText1 :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
 147 p_CellText1 row = debugParser "CellText" $ do
 148         P.skipMany $ P.char ' '
 149         n <- p_Cell $ NodeText <$> p_Line1
 150         return $ Tree0 n : row
 151
 152 p_CellRaw :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
 153 p_CellRaw row = debugParser "CellRaw" $ do
 154         P.skipMany $ P.char ' '
 155         n <- p_Cell $ NodeText <$> p_Line
 156         return $ Tree0 n : row
 157
 158 p_CellSpaces1 :: Row -> Parser e s Row
 159 p_CellSpaces1 row = debugParser "CellSpaces" $ do
 160         P.skipSome $ P.char ' '
 161         pos <- p_Position
 162         return $ Tree0 (Cell pos pos $ NodeText "") : row
 163
 164 p_CellEnd :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
 165 p_CellEnd row = debugParser "CellEnd" $
 166         P.try (p_CellLower row) <|>
 167         P.try (p_CellText1 row) <|>
 168         p_CellSpaces1 row <|>
 169         return row
 170
 171 p_Row :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
 172 p_Row row = debugParser "Row" $
 173         P.try (p_CellHeader row) <|>
 174         p_CellEnd row
 175
 176 p_Rows :: P.Tokens s ~ TL.Text => Rows -> Parser e s Rows
 177 p_Rows rows =
 178         p_Row [] >>= \row ->
 179                 let rows' = rows `mergeRow` row in
 180                 (P.eof $> rows') <|>
 181                 (P.newline >> {- USELESS: P.eof $> rows' <|>-} p_Rows rows')
 182
 183 p_Trees :: P.Tokens s ~ TL.Text => Parser e s (Trees (Cell Node))
 184 p_Trees = collapseRows <$> p_Rows initRows