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                  -- TODO: KeyComment
  57                  , P.try $ P.some (P.char '#') <* P.lookAhead (P.try $ P.char ' ') >>= \hs ->
  58                         return $ KeySection $ List.length hs
  59                  , do
  60                         name <- p_Name
  61                         wh <- Text.pack <$> P.many (P.char ' ')
  62                         P.choice
  63                          [ P.try $ KeyColon name wh
  64                                  <$ P.char ':'
  65                                  <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy $ \c -> c=='\n'||c==' '))
  66                          , P.char '>' $> KeyGreat name wh
  67                          , P.char '=' $> KeyEqual name wh
  68                          , P.char '|' $> KeyBar   name wh
  69                          -- TODO: KeyAt
  70                          ]
  71                  ]
  72         posEnd <- p_Position
  73         let row' = TreeN (Cell pos posEnd key) mempty : row
  74         case key of
  75          KeySection{}  -> p_CellEnd  row'
  76          KeyDash{}     -> p_Row      row'
  77          KeyDashDash{} -> p_CellText row'
  78          KeyDot{}      -> p_Row      row'
  79          KeyColon{}    -> p_Row      row'
  80          KeyGreat{}    -> p_Row      row'
  81          KeyEqual{}    -> p_CellEnd  row'
  82          KeyBar{}      -> 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_CellLower :: Row -> Parser e s Row
  94 p_CellLower row = pdbg "CellLower" $ do
  95         P.skipMany $ P.char ' '
  96         pos <- p_Position
  97         void $ P.char '<'
  98         name <- p_Name
  99         attrs <- p_attrs
 100         posClose <- p_Position
 101         let treeHere =
 102                 TreeN (Cell pos posClose $ KeyLower name attrs) .
 103                 Seq.singleton . Tree0
 104         let treeElem toks (Cell _ p c) =
 105                 let (o,_) = pairBorders (PairElem name attrs) toks in
 106                 Tree0 $ Cell pos p (o<>c)
 107         let indent = List.replicate (columnPos pos - 1) ' '
 108         tree <-
 109                 P.try (P.char '>' >> treeElem (tokens [TokenPlain ""]) <$> p_CellLinesUntilElemEnd indent name) <|>
 110                 P.try (P.char '\n' >> P.string indent >> treeHere <$> p_CellLines indent) <|>
 111                 P.try (P.string "/>" >> treeElem mempty <$> p_CellLine) <|>
 112                 (P.eof $> treeHere (Cell posClose posClose ""))
 113         return (tree:row)
 114         where
 115         p_attrs = P.many $ P.try $
 116                 (,)
 117                  <$> (Text.pack <$> P.some (P.char ' '))
 118                  <*> p_Attr
 119         p_line :: Parser e s Text
 120         p_line = Text.pack <$> P.many (P.satisfy (/='\n'))
 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 :: String -> 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 :: String -> 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 p l -> Text.pack w <> Text.pack p <> l : ls)
 145                          <$> P.many (P.char ' ')
 146                          <*> P.string ("</"<>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