src/Textphile/TCT/Read/Tree.hs

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