Hdoc/TCT/Read/Tree.hs

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