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_Line :: Parser e s Line
  38 p_Line = intOfPos . P.sourceLine <$> P.getPosition
  39
  40 p_Column :: Parser e s Column
  41 p_Column = 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                  , do
  62                         name <- p_Name
  63                         wh <- Text.pack <$> P.many (P.char ' ')
  64                         P.choice
  65                          [ P.try $ KeyColon name wh
  66                                  <$ P.char ':'
  67                                  <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy $ \c -> c=='\n'||c==' '))
  68                          , P.char '>' $> KeyGreat name wh
  69                          , P.char '=' $> KeyEqual name wh
  70                          , P.char '|' $> KeyBar   name wh
  71                          -- TODO: KeyAt
  72                          ]
  73                  ]
  74         posEnd <- p_Position
  75         let row' = TreeN (Cell pos posEnd key) mempty : row
  76         case key of
  77          KeySection{}  -> p_CellEnd  row'
  78          KeyDash{}     -> p_Row      row'
  79          KeyDashDash{} -> p_CellText row'
  80          KeyDot{}      -> p_Row      row'
  81          KeyColon{}    -> p_Row      row'
  82          KeyBrackets{} -> p_Row      row'
  83          KeyGreat{}    -> p_Row      row'
  84          KeyEqual{}    -> p_CellEnd  row'
  85          KeyBar{}      -> p_CellEnd  row'
  86          KeyLower{}    -> undefined -- NOTE: handled in 'p_CellLower'
  87
  88 p_Name :: Parser e s Name
  89 p_Name =
  90         (\h t -> Text.pack (h:t))
  91          <$> (P.satisfy $ \c ->
  92                 Char.isAlphaNum c || c=='_')
  93          <*> many (P.satisfy $ \c ->
  94                 Char.isAlphaNum c || c=='-' || c=='_')
  95
  96 p_CellLower :: 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 = List.replicate (columnPos pos - 1) ' '
 111         tree <-
 112                 P.try (P.char '>' >> treeElem (tokens [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_line :: Parser e s Text
 123         p_line = Text.pack <$> P.many (P.satisfy (/='\n'))
 124         p_CellLine :: Parser e s (Cell Text)
 125         p_CellLine = do
 126                 pos     <- p_Position
 127                 content <- p_line
 128                 posEnd  <- p_Position
 129                 return $ Cell pos posEnd content
 130         p_CellLines :: String -> Parser e s (Cell Text)
 131         p_CellLines indent = do
 132                 pos <- p_Position
 133                 content <-
 134                         Text.intercalate "\n"
 135                          <$> P.sepBy (P.try p_line) (P.try $ P.char '\n' >> P.string indent)
 136                 posEnd <- p_Position
 137                 return $ Cell pos posEnd content
 138         p_CellLinesUntilElemEnd :: String -> Text -> Parser e s (Cell Text)
 139         p_CellLinesUntilElemEnd indent name = do
 140                 pos     <- p_Position
 141                 content <- Text.intercalate "\n" . List.reverse <$> go []
 142                 posEnd  <- p_Position
 143                 return $ Cell pos posEnd content
 144                 where
 145                 go :: [Text] -> Parser e s [Text]
 146                 go ls =
 147                         P.try ((\w p l -> Text.pack w <> Text.pack p <> l : ls)
 148                          <$> P.many (P.char ' ')
 149                          <*> P.string ("</"<>Text.unpack name)
 150                          <*> p_line) <|>
 151                         (p_line >>= \l -> P.try $
 152                                 P.char '\n' >>
 153                                 P.string indent >>
 154                                 go (l:ls))
 155
 156 p_CellText :: Row -> Parser e s Row
 157 p_CellText row = pdbg "CellText" $ do
 158         P.skipMany $ P.char ' '
 159         pos <- p_Position
 160         line <- Text.pack <$> P.some (P.satisfy (/='\n'))
 161         posEnd <- p_Position
 162         return $ Tree0 (Cell pos posEnd line) : row
 163
 164 p_CellSpaces :: Row -> Parser e s Row
 165 p_CellSpaces row = pdbg "CellSpaces" $ do
 166         P.skipSome $ P.char ' '
 167         pos <- p_Position
 168         return $ Tree0 (Cell pos pos "") : row
 169
 170 p_CellEnd :: Row -> Parser e s Row
 171 p_CellEnd row = pdbg "Row" $
 172         P.try (p_CellLower row) <|>
 173         P.try (p_CellText row) <|>
 174         p_CellSpaces row <|>
 175         return row
 176
 177 p_Row :: Row -> Parser e s Row
 178 p_Row row = pdbg "Row" $
 179         P.try (p_CellKey row) <|>
 180         p_CellEnd row
 181
 182 p_Rows :: Rows -> Parser e s Rows
 183 p_Rows rows =
 184         p_Row [] >>= \row ->
 185                 let rows' = appendRow rows (List.reverse row) in
 186                 (P.eof $> rows') <|>
 187                 (P.newline >> p_Rows rows')
 188
 189 p_Trees :: Parser e s (Trees (Cell Key) (Cell Text))
 190 p_Trees = unRoot . collapseRows <$> p_Rows [root]
 191         where
 192         root = TreeN (cell0 KeyDashDash) mempty
 193         unRoot (TreeN (unCell -> KeyDashDash) roots) = roots
 194         unRoot _ = undefined