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 <-
  86                 Text.pack
  87                  <$> many (P.satisfy $ \c ->
  88                         Char.isAlphaNum c || c=='-' || c=='_')
  89         attrs <- P.many $ P.try $ (,) <$> (Text.pack <$> P.some (P.char ' ')) <*> p_Attr
  90         posClose <- p_Position
  91         let treeHere =
  92                 TreeN (Cell pos posClose $ KeyLower name attrs) .
  93                 Seq.singleton . Tree0
  94         let treeElem m (Cell _ p c) =
  95                 let (o,_) = pairBorders (PairElem name attrs) m in
  96                 Tree0 $ Cell pos p (o<>c)
  97         let indent = List.replicate (columnPos pos - 1) ' '
  98         tree <-
  99                 P.try (P.char '>' >> treeElem mempty <$> p_lines indent) <|>
 100                 P.try (P.char '\n' >> P.string indent >> treeHere <$> p_lines indent) <|>
 101                 P.try (P.string "/>" >> treeElem (Tokens mempty) <$> p_line) <|>
 102                 (P.eof $> treeHere (Cell posClose posClose ""))
 103         return (tree:row)
 104         where
 105         p_line :: Parser e s (Cell Text)
 106         p_line = do
 107                 pos <- p_Position
 108                 content <- Text.pack <$> P.many (P.satisfy (/='\n'))
 109                 posEnd <- p_Position
 110                 return $ Cell pos posEnd content
 111         p_lines :: String -> Parser e s (Cell Text)
 112         p_lines indent = do
 113                 pos <- p_Position
 114                 content <-
 115                         Text.intercalate "\n"
 116                          <$> P.sepBy
 117                                  (P.try $ Text.pack <$> P.many (P.satisfy (/='\n')))
 118                                  (P.try $ P.char '\n' >> P.string indent)
 119                 posEnd <- p_Position
 120                 return $ Cell pos posEnd content
 121
 122 p_CellText :: Row -> Parser e s Row
 123 p_CellText row = pdbg "CellText" $ do
 124         P.skipMany $ P.char ' '
 125         pos <- p_Position
 126         line <- Text.pack <$> P.some (P.satisfy (/='\n'))
 127         posEnd <- p_Position
 128         return $ Tree0 (Cell pos posEnd line) : row
 129
 130 p_CellSpaces :: Row -> Parser e s Row
 131 p_CellSpaces row = pdbg "CellSpaces" $ do
 132         P.skipSome $ P.char ' '
 133         pos <- p_Position
 134         return $ Tree0 (Cell pos pos "") : row
 135
 136 p_CellEnd :: Row -> Parser e s Row
 137 p_CellEnd row = pdbg "Row" $
 138         P.try (p_CellLower row) <|>
 139         P.try (p_CellText row) <|>
 140         p_CellSpaces row <|>
 141         return row
 142
 143 p_Row :: Row -> Parser e s Row
 144 p_Row row = pdbg "Row" $
 145         P.try (p_CellKey row) <|>
 146         p_CellEnd row
 147
 148 p_Rows :: Rows -> Parser e s Rows
 149 p_Rows rows =
 150         p_Row [] >>= \row ->
 151                 let rows' = appendRow rows (List.reverse row) in
 152                 (P.eof $> rows') <|>
 153                 (P.newline >> p_Rows rows')
 154
 155 p_Trees :: Parser e s (Trees (Cell Key) (Cell Text))
 156 p_Trees = unRoot . collapseRows <$> p_Rows [root]
 157         where
 158         root = TreeN (Cell (0,0) (0,0) KeyDash) mempty
 159         unRoot (TreeN (unCell -> KeyDash) roots) = roots
 160         unRoot _ = undefined