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.string "- " $> KeyDash
  50                  , P.try $ KeyDot . Text.pack
  51                          <$> P.some (P.satisfy Char.isDigit)
  52                          <* P.char '.'
  53                          <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy $ \c -> c=='\n'||c==' '))
  54                  -- TODO: KeyComment
  55                  , P.try $ P.some (P.char '#') <* P.lookAhead (P.try $ P.char ' ') >>= \hs ->
  56                         return $ KeySection $ List.length hs
  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                          -- TODO: KeyAt
  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          KeyDot{}     -> p_Row     row'
  76          KeyColon{}   -> p_Row     row'
  77          KeyGreat{}   -> p_Row     row'
  78          KeyEqual{}   -> p_CellEnd row'
  79          KeyBar{}     -> p_CellEnd row'
  80          KeyLower{}   -> undefined -- NOTE: handled in 'p_CellLower'
  81
  82 p_Name :: Parser e s Name
  83 p_Name =
  84         (\h t -> Text.pack (h:t))
  85          <$> (P.satisfy $ \c ->
  86                 Char.isAlphaNum c || c=='_')
  87          <*> many (P.satisfy $ \c ->
  88                 Char.isAlphaNum c || c=='-' || c=='_')
  89
  90 p_CellLower :: Row -> Parser e s Row
  91 p_CellLower row = pdbg "CellLower" $ do
  92         P.skipMany $ P.char ' '
  93         pos <- p_Position
  94         void $ P.char '<'
  95         name <- p_Name
  96         attrs <- p_attrs
  97         posClose <- p_Position
  98         let treeHere =
  99                 TreeN (Cell pos posClose $ KeyLower name attrs) .
 100                 Seq.singleton . Tree0
 101         let treeElem toks (Cell _ p c) =
 102                 let (o,_) = pairBorders (PairElem name attrs) toks in
 103                 Tree0 $ Cell pos p (o<>c)
 104         let indent = List.replicate (columnPos pos - 1) ' '
 105         tree <-
 106                 P.try (P.char '>' >> treeElem (tokens [TokenPlain ""]) <$> p_CellLinesUntilElemEnd indent name) <|>
 107                 P.try (P.char '\n' >> P.string indent >> treeHere <$> p_CellLines indent) <|>
 108                 P.try (P.string "/>" >> treeElem mempty <$> p_CellLine) <|>
 109                 (P.eof $> treeHere (Cell posClose posClose ""))
 110         return (tree:row)
 111         where
 112         p_attrs = P.many $ P.try $
 113                 (,)
 114                  <$> (Text.pack <$> P.some (P.char ' '))
 115                  <*> p_Attr
 116         p_line :: Parser e s Text
 117         p_line = Text.pack <$> P.many (P.satisfy (/='\n'))
 118         p_CellLine :: Parser e s (Cell Text)
 119         p_CellLine = do
 120                 pos     <- p_Position
 121                 content <- p_line
 122                 posEnd  <- p_Position
 123                 return $ Cell pos posEnd content
 124         p_CellLines :: String -> Parser e s (Cell Text)
 125         p_CellLines indent = do
 126                 pos <- p_Position
 127                 content <-
 128                         Text.intercalate "\n"
 129                          <$> P.sepBy (P.try p_line) (P.try $ P.char '\n' >> P.string indent)
 130                 posEnd <- p_Position
 131                 return $ Cell pos posEnd content
 132         p_CellLinesUntilElemEnd :: String -> Text -> Parser e s (Cell Text)
 133         p_CellLinesUntilElemEnd indent name = do
 134                 pos     <- p_Position
 135                 content <- Text.intercalate "\n" . List.reverse <$> go []
 136                 posEnd  <- p_Position
 137                 return $ Cell pos posEnd content
 138                 where
 139                 go :: [Text] -> Parser e s [Text]
 140                 go ls =
 141                         P.try ((\w p l -> Text.pack w <> Text.pack p <> l : ls)
 142                          <$> P.many (P.char ' ')
 143                          <*> P.string ("</"<>Text.unpack name)
 144                          <*> p_line) <|>
 145                         (p_line >>= \l -> P.try $
 146                                 P.char '\n' >>
 147                                 P.string indent >>
 148                                 go (l:ls))
 149
 150 p_CellText :: Row -> Parser e s Row
 151 p_CellText row = pdbg "CellText" $ do
 152         P.skipMany $ P.char ' '
 153         pos <- p_Position
 154         line <- Text.pack <$> P.some (P.satisfy (/='\n'))
 155         posEnd <- p_Position
 156         return $ Tree0 (Cell pos posEnd line) : 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 "") : row
 163
 164 p_CellEnd :: Row -> Parser e s Row
 165 p_CellEnd row = pdbg "Row" $
 166         P.try (p_CellLower row) <|>
 167         P.try (p_CellText row) <|>
 168         p_CellSpaces row <|>
 169         return row
 170
 171 p_Row :: Row -> Parser e s Row
 172 p_Row row = pdbg "Row" $
 173         P.try (p_CellKey row) <|>
 174         p_CellEnd row
 175
 176 p_Rows :: 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_Rows rows')
 182
 183 p_Trees :: Parser e s (Trees (Cell Key) (Cell Text))
 184 p_Trees = unRoot . collapseRows <$> p_Rows [root]
 185         where
 186         root = TreeN (cell0 KeyDash) mempty
 187         unRoot (TreeN (unCell -> KeyDash) roots) = roots
 188         unRoot _ = undefined