Language/TCT/Read/Tree.hs

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