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.Monoid (Monoid(..))
  17 import Data.Semigroup (Semigroup(..))
  18 import Data.String (IsString(..))
  19 import Data.Text (Text)
  20 import Data.TreeSeq.Strict (Tree(..), Trees)
  21 import Prelude (undefined, Num(..))
  22 import qualified Data.Char as Char
  23 import qualified Data.List as List
  24 import qualified Data.Sequence as Seq
  25 import qualified Data.Text as Text
  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
  35 p_CellKey :: Row -> Parser e s Row
  36 p_CellKey row = pdbg "CellKey" $ do
  37         P.skipMany $ P.char ' '
  38         pos <- p_Position
  39         key <- pdbg "Key" $
  40                 P.choice $
  41                  [ P.try $ P.char '-' >>
  42                         P.char ' ' $> KeyDash <|>
  43                         P.string "- " $> KeyDashDash
  44                  , P.try $ KeyDot . Text.pack
  45                          <$> P.some (P.satisfy Char.isDigit)
  46                          <* P.char '.'
  47                          <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy $ \c -> c=='\n'||c==' '))
  48                  , P.try $ P.some (P.char '#') <* P.lookAhead (P.try $ P.char ' ') >>= \hs ->
  49                         return $ KeySection $ List.length hs
  50                  , P.try $
  51                         KeyBrackets
  52                          <$> P.between (P.string "[") (P.string "]") p_Name
  53                          <*  P.lookAhead (P.try $ P.eof <|> void (P.satisfy (=='\n')))
  54                  , P.try $
  55                         (\f -> KeyDotSlash $ "./"<>f)
  56                          <$  P.string "./"
  57                          <*> P.many (P.satisfy (/='\n'))
  58                  , do
  59                         name <- p_Name
  60                         wh <- Text.pack <$> P.many (P.char ' ')
  61                         P.choice
  62                          [ P.try $ KeyColon name wh
  63                                  <$ P.char ':'
  64                                  <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy $ \c -> c=='\n'||c==' '))
  65                          , P.char '>' $> KeyGreat name wh
  66                          , P.char '=' $> KeyEqual name wh
  67                          , P.char '|' $> KeyBar   name wh
  68                          ]
  69                  ]
  70         posEnd <- p_Position
  71         let row' = TreeN (Cell pos posEnd key) mempty : row
  72         case key of
  73          KeySection{}  -> p_CellEnd  row'
  74          KeyDash{}     -> p_Row      row'
  75          KeyDashDash{} -> p_CellText row'
  76          KeyDot{}      -> p_Row      row'
  77          KeyColon{}    -> p_Row      row'
  78          KeyBrackets{} -> p_Row      row'
  79          KeyGreat{}    -> p_Row      row'
  80          KeyEqual{}    -> p_CellEnd  row'
  81          KeyBar{}      -> p_CellEnd  row'
  82          KeyDotSlash{} -> p_CellEnd  row'
  83          KeyLower{}    -> undefined -- NOTE: handled in 'p_CellLower'
  84
  85 p_Name :: Parser e s Name
  86 p_Name =
  87         (\h t -> Text.pack (h:t))
  88          <$> (P.satisfy $ \c ->
  89                 Char.isAlphaNum c || c=='_')
  90          <*> many (P.satisfy $ \c ->
  91                 Char.isAlphaNum c || c=='-' || c=='_')
  92
  93 p_Line :: Parser e s Text
  94 p_Line = Text.pack <$> P.many (P.satisfy (/='\n'))
  95
  96 p_CellLower :: forall e s. Row -> Parser e s Row
  97 p_CellLower row = pdbg "CellLower" $ do
  98         P.skipMany $ P.char ' '
  99         pos <- p_Position
 100         void $ P.char '<'
 101         name <- p_Name
 102         attrs <- p_attrs
 103         posClose <- p_Position
 104         let treeHere =
 105                 TreeN (Cell pos posClose $ KeyLower name attrs) .
 106                 Seq.singleton . Tree0
 107         let treeElem toks (Cell _ p c) =
 108                 let (o,_) = pairBorders (PairElem name attrs) toks in
 109                 Tree0 $ Cell pos p (o<>c)
 110         let indent = fromString $ List.replicate (columnPos pos - 1) ' '
 111         tree <-
 112                 P.try (P.char '>' >> treeElem (tokens [cell0 $ TokenPlain ""]) <$> p_CellLinesUntilElemEnd indent name) <|>
 113                 P.try (P.char '\n' >> P.string indent >> treeHere <$> p_CellLines indent) <|>
 114                 P.try (P.string "/>" >> treeElem mempty <$> p_CellLine) <|>
 115                 (P.eof $> treeHere (Cell posClose posClose ""))
 116         return (tree:row)
 117         where
 118         p_attrs = P.many $ P.try $
 119                 (,)
 120                  <$> (Text.pack <$> P.some (P.char ' '))
 121                  <*> p_Attr
 122         p_CellLine :: Parser e s (Cell Text)
 123         p_CellLine = do
 124                 pos     <- p_Position
 125                 content <- p_Line
 126                 posEnd  <- p_Position
 127                 return $ Cell pos posEnd content
 128         p_CellLines :: P.Tokens s -> Parser e s (Cell Text)
 129         p_CellLines indent = do
 130                 pos <- p_Position
 131                 content <-
 132                         Text.intercalate "\n"
 133                          <$> P.sepBy (P.try p_Line) (P.try $ P.char '\n' >> P.string indent)
 134                 posEnd <- p_Position
 135                 return $ Cell pos posEnd content
 136         p_CellLinesUntilElemEnd :: P.Tokens s -> Text -> Parser e s (Cell Text)
 137         p_CellLinesUntilElemEnd indent name = do
 138                 pos     <- p_Position
 139                 content <- Text.intercalate "\n" . List.reverse <$> go []
 140                 posEnd  <- p_Position
 141                 return $ Cell pos posEnd content
 142                 where
 143                 go :: [Text] -> Parser e s [Text]
 144                 go ls =
 145                         P.try ((\w l -> Text.pack w <> "</" <> name <> l : ls)
 146                          <$> P.many (P.char ' ')
 147                          <*  P.string (fromString $ "</"<>Text.unpack name)
 148                          <*> p_Line) <|>
 149                         (p_Line >>= \l -> P.try $
 150                                 P.char '\n' >>
 151                                 P.string indent >>
 152                                 go (l:ls))
 153
 154 p_CellText :: Row -> Parser e s Row
 155 p_CellText row = pdbg "CellText" $ do
 156         P.skipMany $ P.char ' '
 157         pos <- p_Position
 158         line <- Text.pack <$> P.some (P.satisfy (/='\n'))
 159         posEnd <- p_Position
 160         return $ Tree0 (Cell pos posEnd line) : row
 161
 162 p_CellSpaces :: Row -> Parser e s Row
 163 p_CellSpaces row = pdbg "CellSpaces" $ do
 164         P.skipSome $ P.char ' '
 165         pos <- p_Position
 166         return $ Tree0 (Cell pos pos "") : row
 167
 168 p_CellEnd :: Row -> Parser e s Row
 169 p_CellEnd row = pdbg "Row" $
 170         P.try (p_CellLower row) <|>
 171         P.try (p_CellText row) <|>
 172         p_CellSpaces row <|>
 173         return row
 174
 175 p_Row :: Row -> Parser e s Row
 176 p_Row row = pdbg "Row" $
 177         P.try (p_CellKey row) <|>
 178         p_CellEnd row
 179
 180 p_Rows :: Rows -> Parser e s Rows
 181 p_Rows rows =
 182         p_Row [] >>= \row ->
 183                 let rows' = appendRow rows (List.reverse row) in
 184                 (P.eof $> rows') <|>
 185                 (P.newline >> p_Rows rows')
 186
 187 p_Trees :: Parser e s (Trees (Cell Key) (Cell Text))
 188 p_Trees = unRoot . collapseRows <$> p_Rows [root]
 189         where
 190         root = TreeN (cell0 KeyDashDash) mempty
 191         unRoot (TreeN (unCell -> KeyDashDash) roots) = roots
 192         unRoot _ = undefined