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