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