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,_) = groupBorders (GroupElem 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_lines indent) <|>
 102                 (P.eof $> treeHere (Cell posClose posClose ""))
 103         return (tree:row)
 104         where
 105         p_lines :: String -> Parser e s (Cell Text)
 106         p_lines indent = do
 107                 pos <- p_Position
 108                 content <-
 109                         Text.intercalate "\n"
 110                          <$> P.sepBy
 111                                  (P.try $ Text.pack <$> P.many (P.satisfy (/='\n')))
 112                                  (P.try $ P.char '\n' >> P.string indent)
 113                 posEnd <- p_Position
 114                 return $ Cell pos posEnd content
 115
 116 p_CellText :: Row -> Parser e s Row
 117 p_CellText row = pdbg "CellText" $ do
 118         P.skipMany $ P.char ' '
 119         pos <- p_Position
 120         line <- Text.pack <$> P.some (P.satisfy (/='\n'))
 121         posEnd <- p_Position
 122         return $ Tree0 (Cell pos posEnd line) : row
 123
 124 p_CellSpaces :: Row -> Parser e s Row
 125 p_CellSpaces row = pdbg "CellSpaces" $ do
 126         P.skipSome $ P.char ' '
 127         pos <- p_Position
 128         return $ Tree0 (Cell pos pos "") : row
 129
 130 p_CellEnd :: Row -> Parser e s Row
 131 p_CellEnd row = pdbg "Row" $
 132         P.try (p_CellLower row) <|>
 133         P.try (p_CellText row) <|>
 134         p_CellSpaces row <|>
 135         return row
 136
 137 p_Row :: Row -> Parser e s Row
 138 p_Row row = pdbg "Row" $
 139         P.try (p_CellKey row) <|>
 140         p_CellEnd row
 141
 142 p_Rows :: Rows -> Parser e s Rows
 143 p_Rows rows =
 144         p_Row [] >>= \row ->
 145                 let rows' = appendRow rows (List.reverse row) in
 146                 (P.eof $> rows') <|>
 147                 (P.newline >> p_Rows rows')
 148
 149 p_Trees :: Parser e s (Trees (Cell Key) (Cell Text))
 150 p_Trees = unRoot . collapseRows <$> p_Rows [root]
 151         where
 152         root = TreeN (Cell (0,0) (0,0) KeyDash) mempty
 153         unRoot (TreeN (unCell -> KeyDash) roots) = roots
 154         unRoot _ = undefined