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 Data.String (IsString(..))
  11 -- import qualified Data.TreeSeq.Strict as TreeSeq
  12 import Control.Applicative (Applicative(..), Alternative(..))
  13 import Control.Monad (Monad(..), void)
  14 import Data.Bool
  15 import Data.Eq (Eq(..))
  16 import Data.Function (($), (.))
  17 import Data.Functor ((<$>), ($>), (<$))
  18 import Data.Foldable (toList)
  19 import Data.Maybe (Maybe(..))
  20 import Data.Monoid (Monoid(..))
  21 import Data.Semigroup (Semigroup(..))
  22 import Data.TreeSeq.Strict (Tree(..), Trees)
  23 import qualified Data.List as List
  24 import qualified Data.Sequence as Seq
  25 import qualified Data.Text.Lazy as TL
  26 import qualified Text.Megaparsec as P
  27 import qualified Text.Megaparsec.Char as P
  28
  29 import Language.TCT.Cell
  30 -- import Language.TCT.Token
  31 import Language.TCT.Tree
  32 import Language.TCT.Read.Cell
  33 import Language.TCT.Read.Elem
  34 import Language.TCT.Read.Token
  35
  36 p_CellHeader :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
  37 p_CellHeader row = pdbg "CellHeader" $ do
  38         P.skipMany $ P.char ' '
  39         pos <- p_Position
  40         header <- pdbg "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.string "[") (P.string "]") p_Name
  54                          <*  P.lookAhead (P.try $ P.eof <|> void (P.satisfy (=='\n')))
  55                  , P.try $
  56                         (\f -> HeaderDotSlash $ "./"<>f)
  57                          <$  P.string "./"
  58                          <*> P.many (P.satisfy (/='\n'))
  59                  , do
  60                         name <- p_Name
  61                         wh <- p_HSpaces
  62                         P.choice
  63                          [ P.try $ HeaderColon name wh
  64                                  <$ P.char ':'
  65                                  <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy $ \c -> c=='\n'||c==' '))
  66                          , P.char '>' $> HeaderGreat name wh
  67                          , P.char '=' $> HeaderEqual name wh
  68                          , P.char '|' $> HeaderBar   name wh
  69                          ]
  70                  ]
  71         posEnd <- p_Position
  72         let row' = Tree (Cell pos posEnd $ NodeHeader header) mempty : row
  73         case header of
  74          HeaderSection{}  -> p_CellEnd  row'
  75          HeaderDash{}     -> p_Row      row'
  76          HeaderDashDash{} -> p_CellText row'
  77          HeaderDot{}      -> p_Row      row'
  78          HeaderColon{}    -> p_Row      row'
  79          HeaderBrackets{} -> p_Row      row'
  80          HeaderGreat{}    -> p_Row      row'
  81          HeaderEqual{}    -> p_CellEnd  row'
  82          HeaderBar{}      -> p_CellEnd  row'
  83          HeaderDotSlash{} -> p_CellEnd  row'
  84          -- HeaderLower{}    -> undefined -- NOTE: handled in 'p_CellLower'
  85          -- TODO: move to a NodeLower
  86          -- HeaderPara       -> undefined -- NOTE: only introduced later in 'appendRow'
  87
  88 p_Name :: P.Tokens s ~ TL.Text => Parser e s Name
  89 p_Name = p_AlphaNums
  90         {-
  91         (\h t -> Text.pack (h:t))
  92          <$> (P.satisfy $ \c -> Char.isAlphaNum c || c=='_')
  93          <*> P.takeWhile1P (P.satisfy $ \c -> Char.isAlphaNum c || c=='-' || c=='_')
  94         -}
  95
  96 p_Line :: P.Tokens s ~ TL.Text => Parser e s TL.Text
  97 p_Line = P.takeWhileP (Just "Line") (/='\n')
  98
  99 p_Line1 :: P.Tokens s ~ TL.Text => Parser e s TL.Text
 100 p_Line1 = P.takeWhile1P (Just "Line") (/='\n')
 101
 102 p_CellLower :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
 103 p_CellLower row = pdbg "CellLower" $ do
 104         indent   <- p_HSpaces
 105         pos      <- p_Position
 106         void     $  P.char '<'
 107         name     <- p_Name
 108         attrs    <- p_ElemAttrs
 109         posClose <- p_Position
 110         let treeHere =
 111                 Tree (Cell pos posClose $ NodeLower name attrs) .
 112                 Seq.singleton . Tree0 . (NodeText <$>)
 113         let treeElem hasContent nod (Cell _ p t) =
 114                 let (o,_) = bs $ PairElem name attrs in
 115                 Tree0 $ Cell pos p $ nod $ o<>t
 116                 where
 117                 bs | hasContent = pairBorders
 118                    | otherwise  = pairBordersWithoutContent
 119         tree <-
 120                 P.try (P.char '>' >> treeElem True NodeText <$> p_CellLinesUntilElemEnd indent name) <|>
 121                 P.try (P.char '\n' >> P.tokens (==) indent >> treeHere <$> p_CellLines indent) <|>
 122                 P.try (P.tokens (==) "/>" >> treeElem False NodeText <$> p_CellLine) <|>
 123                 (P.eof $> treeHere (Cell posClose posClose ""))
 124         return $ tree : row
 125         where
 126         p_CellLine :: P.Tokens s ~ TL.Text => Parser e s (Cell TL.Text)
 127         p_CellLine = p_Cell p_Line
 128         p_CellLines :: P.Tokens s ~ TL.Text => P.Tokens TL.Text -> Parser e s (Cell TL.Text)
 129         p_CellLines indent =
 130                 -- TODO: optimize special case indent == "" ?
 131                 p_Cell $
 132                         TL.intercalate "\n"
 133                          <$> P.sepBy (P.try p_Line)
 134                                  (P.try $ P.char '\n' >> P.tokens (==) indent)
 135         p_CellLinesUntilElemEnd :: P.Tokens s ~ TL.Text => P.Tokens TL.Text -> Name -> Parser e s (Cell TL.Text)
 136         p_CellLinesUntilElemEnd indent name =
 137                 p_Cell $ TL.intercalate "\n" . List.reverse <$> go []
 138                 -- TODO: optimize merging, and maybe case indent == ""
 139                 where
 140                 go :: P.Tokens s ~ TL.Text => [TL.Text] -> Parser e s [TL.Text]
 141                 go ls =
 142                         let end = "</" <> name in
 143                         P.try ((\w l -> w <> end <> l : ls)
 144                          <$> p_HSpaces
 145                          <*  P.tokens (==) end
 146                          <*> p_Line) <|>
 147                         (p_Line >>= \l -> P.try $
 148                                 P.char '\n'
 149                                  >> P.tokens (==) indent
 150                                  >> go (l:ls))
 151
 152 p_CellText :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
 153 p_CellText row = pdbg "CellText" $ do
 154         P.skipMany $ P.char ' '
 155         n <- p_Cell $ NodeText <$> p_Line1
 156         return $ Tree0 n : row
 157
 158 p_CellSpaces :: Row -> Parser e s Row
 159 p_CellSpaces row = pdbg "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 = pdbg "CellEnd" $
 166         P.try (p_CellLower row) <|>
 167         P.try (p_CellText row) <|>
 168         p_CellSpaces row <|>
 169         return row
 170
 171 p_Row :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
 172 p_Row row = pdbg "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' = appendRow rows (List.reverse row) in
 180                 (P.eof $> rows') <|>
 181                 (P.newline >> P.eof $> rows' <|> p_Rows rows')
 182
 183 p_Trees :: P.Tokens s ~ TL.Text => Parser e s (Trees (Cell Node))
 184 p_Trees = unNodePara . subTrees . collapseRows <$> p_Rows [root]
 185         where
 186         root = Tree (cell0 $ NodeHeader HeaderDashDash) mempty
 187         unNodePara :: Trees (Cell Node) -> Trees (Cell Node)
 188         unNodePara (toList -> [(Tree (unCell -> NodePara) ts)]) = ts
 189         unNodePara ts = ts