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.Maybe (Maybe(..))
  15 import Data.Monoid (Monoid(..))
  16 import Data.Semigroup (Semigroup(..))
  17 import Data.TreeSeq.Strict (Tree(..), Trees)
  18 import qualified Data.List as List
  19 import qualified Data.Sequence as Seq
  20 import qualified Data.Text.Lazy as TL
  21 import qualified Text.Megaparsec as P
  22 import qualified Text.Megaparsec.Char as P
  23
  24 import Language.TCT.Debug
  25 import Language.TCT.Cell
  26 import Language.TCT.Tree
  27 import Language.TCT.Read.Cell
  28 import Language.TCT.Read.Elem
  29 import Language.TCT.Read.Token
  30
  31 p_CellHeader :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
  32 p_CellHeader row = debugParser "CellHeader" $ do
  33         P.skipMany $ P.char ' '
  34         pos <- p_Position
  35         header <- debugParser "Header" $
  36                 P.choice $
  37                  [ P.try $ P.char '-' >>
  38                         P.char ' ' $> HeaderDash <|>
  39                         P.string "- " $> HeaderDashDash
  40                  , P.try $ HeaderDot
  41                          <$> p_Digits
  42                          <* P.char '.'
  43                          <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy $ \c -> c=='\n'||c==' '))
  44                  , P.try $ P.some (P.char '#') <* P.lookAhead (P.try $ P.char ' ') >>= \hs ->
  45                         return $ HeaderSection $ List.length hs
  46                  , P.try $
  47                         HeaderBrackets
  48                          <$> P.between (P.string "[") (P.string "]") p_Name
  49                          <*  P.lookAhead (P.try $ P.eof <|> void (P.satisfy (=='\n')))
  50                  , P.try $
  51                         (\f -> HeaderDotSlash $ "./"<>f)
  52                          <$  P.string "./"
  53                          <*> P.many (P.satisfy (/='\n'))
  54                  , do
  55                         name <- p_Name
  56                         wh <- p_HSpaces
  57                         P.choice
  58                          [ P.try $ HeaderColon name wh
  59                                  <$ P.char ':'
  60                                  <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy $ \c -> c=='\n'||c==' '))
  61                          , P.char '>' $> HeaderGreat name wh
  62                          , P.char '=' $> HeaderEqual name wh
  63                          , P.char '|' $> HeaderBar   name wh
  64                          ]
  65                  ]
  66         posEnd <- p_Position
  67         let row' = Tree (Cell pos posEnd $ NodeHeader header) mempty : row
  68         case header 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         pos      <- p_Position
  98         void     $  P.char '<'
  99         name     <- p_Name
 100         attrs    <- p_ElemAttrs
 101         posClose <- p_Position
 102         let treeHere =
 103                 Tree (Cell pos posClose $ NodeLower name attrs) .
 104                 Seq.singleton . Tree0 . (NodeText <$>)
 105         let treeElem hasContent nod (Cell _ p t) =
 106                 let (o,_) = bs $ PairElem name attrs in
 107                 Tree0 $ Cell pos p $ nod $ o<>t
 108                 where
 109                 bs | hasContent = pairBordersDouble
 110                    | otherwise  = pairBordersSingle
 111         cel <-
 112                 P.try (P.char '>' >> treeElem True NodeText <$> p_CellLinesUntilElemEnd indent name) <|>
 113                 P.try (P.char '\n' >> P.tokens (==) indent >> treeHere <$> p_CellLines indent) <|>
 114                 P.try (P.tokens (==) "/>" >> treeElem False NodeText <$> p_CellLine) <|>
 115                 (P.eof $> treeHere (Cell posClose posClose ""))
 116         return $ cel : row
 117         where
 118         p_CellLine :: P.Tokens s ~ TL.Text => Parser e s (Cell TL.Text)
 119         p_CellLine = p_Cell p_Line
 120         p_CellLines :: P.Tokens s ~ TL.Text => P.Tokens TL.Text -> Parser e s (Cell TL.Text)
 121         p_CellLines indent =
 122                 -- TODO: optimize special case indent == "" ?
 123                 p_Cell $
 124                         TL.intercalate "\n"
 125                          <$> P.sepBy (P.try p_Line)
 126                                  (P.try $ P.char '\n' >> P.tokens (==) indent)
 127         p_CellLinesUntilElemEnd :: P.Tokens s ~ TL.Text => P.Tokens TL.Text -> Name -> Parser e s (Cell TL.Text)
 128         p_CellLinesUntilElemEnd indent name =
 129                 p_Cell $ TL.intercalate "\n" . List.reverse <$> go []
 130                 -- TODO: optimize merging, and maybe case indent == ""
 131                 where
 132                 go :: P.Tokens s ~ TL.Text => [TL.Text] -> Parser e s [TL.Text]
 133                 go ls =
 134                         let end = "</" <> name in
 135                         P.try ((\w l -> w <> end <> l : ls)
 136                          <$> p_HSpaces
 137                          <*  P.tokens (==) end
 138                          <*> p_Line) <|>
 139                         (p_Line >>= \l -> P.try $
 140                                 P.char '\n'
 141                                  >> P.tokens (==) indent
 142                                  >> go (l:ls))
 143
 144 p_CellText1 :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
 145 p_CellText1 row = debugParser "CellText" $ do
 146         P.skipMany $ P.char ' '
 147         n <- p_Cell $ NodeText <$> p_Line1
 148         return $ Tree0 n : row
 149
 150 p_CellRaw :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
 151 p_CellRaw row = debugParser "CellRaw" $ do
 152         P.skipMany $ P.char ' '
 153         n <- p_Cell $ NodeText <$> p_Line
 154         return $ Tree0 n : row
 155
 156 p_CellSpaces1 :: Row -> Parser e s Row
 157 p_CellSpaces1 row = debugParser "CellSpaces" $ do
 158         P.skipSome $ P.char ' '
 159         pos <- p_Position
 160         return $ Tree0 (Cell pos pos $ NodeText "") : row
 161
 162 p_CellEnd :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
 163 p_CellEnd row = debugParser "CellEnd" $
 164         P.try (p_CellLower row) <|>
 165         P.try (p_CellText1 row) <|>
 166         p_CellSpaces1 row <|>
 167         return row
 168
 169 p_Row :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
 170 p_Row row = debugParser "Row" $
 171         P.try (p_CellHeader row) <|>
 172         p_CellEnd row
 173
 174 p_Rows :: P.Tokens s ~ TL.Text => Rows -> Parser e s Rows
 175 p_Rows rows =
 176         p_Row [] >>= \row ->
 177                 let rows' = rows `mergeRow` row in
 178                 (P.eof $> rows') <|>
 179                 (P.newline >> {- USELESS: P.eof $> rows' <|>-} p_Rows rows')
 180
 181 p_Trees :: P.Tokens s ~ TL.Text => Parser e s (Trees (Cell Node))
 182 p_Trees = collapseRows <$> p_Rows initRows