Language/TCT/Read/Tree.hs

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