Language/TCT/Read/Tree.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE Rank2Types #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5 module Language.TCT.Read.Tree where
   6
   7 import Control.Applicative (Applicative(..), Alternative(..))
   8 import Control.Monad (Monad(..))
   9 import Data.Bool
  10 import Data.Eq (Eq(..))
  11 import Data.Function (($), (.))
  12 import Data.Functor ((<$>), ($>))
  13 import Data.Monoid (Monoid(..))
  14 import Data.Char (Char)
  15 import Data.String (String)
  16 import Data.Text (Text)
  17 import Prelude (undefined, Int, Num(..), toInteger)
  18 -- import Text.Megaparsec.Text
  19 import Text.Show (Show(..))
  20 import qualified Data.Char as Char
  21 import qualified Data.List as List
  22 import qualified Data.Text as Text
  23 import qualified Text.Megaparsec as P
  24
  25 import Language.TCT.Tree
  26
  27 pdbg :: ( Show a
  28         , P.ErrorComponent e
  29         , P.Stream s
  30         , P.Token s ~ Char
  31         , P.ShowToken (P.Token s)
  32         , P.Stream s
  33         ) => String -> P.ParsecT e s m a -> P.ParsecT e s m a
  34 -- pdbg m p = P.dbg m p
  35 pdbg _m p = p
  36
  37 type Parser e s a = (P.ErrorComponent e, P.Stream s, P.Token s ~ Char) => P.Parsec e s a
  38
  39 p_Position :: Parser e s (Line,Column)
  40 p_Position = (<$> P.getPosition) $ \p ->
  41         ( intOfPos $ P.sourceLine p
  42         , intOfPos $ P.sourceColumn p)
  43 intOfPos :: P.Pos -> Int
  44 intOfPos = fromInteger . toInteger . P.unPos
  45
  46 p_Line :: Parser e s Line
  47 p_Line = intOfPos . P.sourceLine <$> P.getPosition
  48
  49 p_Column :: Parser e s Column
  50 p_Column = intOfPos . P.sourceColumn <$> P.getPosition
  51
  52 p_CellKey :: Row -> Parser e s Row
  53 p_CellKey row = pdbg "CellKey" $ do
  54         P.skipMany $ P.char ' '
  55         pos <- p_Position
  56         key <- pdbg "Key" $
  57                 P.choice $
  58                  [ P.try $ P.string "- " $> KeyDash
  59                  -- TODO: KeyNum
  60                  -- TODO: KeyComment
  61                  , P.try $ P.some (P.char '#') <* P.char ' ' >>= \hs ->
  62                         return (KeySection $ List.length hs)
  63                  , do
  64                         name <- Text.pack <$> some (P.satisfy $ \c ->
  65                                 Char.isAlphaNum c || c=='-' || c=='_')
  66                         P.skipMany $ P.char ' '
  67                         P.choice
  68                          [ P.char ':' $> KeyColon name
  69                          , P.char '>' $> KeyGreat name
  70                          , P.char '=' $> KeyEqual name
  71                          , P.char '|' $> KeyBar   name
  72                          -- TODO: KeyAt
  73                          ]
  74                  ]
  75         posEnd <- p_Position
  76         let row' = TreeN (Cell pos posEnd key) mempty : row
  77         case key of
  78          KeySection{} -> p_CellEnd row'
  79          KeyDash{}    -> p_Row     row'
  80          KeyColon{}   -> p_Row     row'
  81          KeyGreat{}   -> p_Row     row'
  82          KeyEqual{}   -> p_CellEnd row'
  83          KeyBar{}     -> p_CellEnd row'
  84
  85 p_CellText :: Row -> Parser e s Row
  86 p_CellText row = pdbg "CellText" $ do
  87         P.skipMany $ P.char ' '
  88         pos <- p_Position
  89         line <- Text.pack <$> P.some (P.satisfy (/='\n'))
  90         posEnd <- p_Position
  91         return $ Tree0 (Cell pos posEnd line) : row
  92
  93 p_CellSpaces :: Row -> Parser e s Row
  94 p_CellSpaces row = pdbg "CellEnd" $ do
  95         P.skipSome $ P.char ' '
  96         pos <- p_Position
  97         return $ Tree0 (Cell pos pos "") : row
  98
  99 p_CellEnd :: Row -> Parser e s Row
 100 p_CellEnd row = pdbg "Row" $
 101         P.try (p_CellText row) <|>
 102         p_CellSpaces row <|>
 103         return row
 104
 105 p_Row :: Row -> Parser e s Row
 106 p_Row row = pdbg "Row" $
 107         P.try (p_CellKey row) <|>
 108         p_CellEnd row
 109
 110 p_Rows :: Rows -> Parser e s Rows
 111 p_Rows rows =
 112         p_Row [] >>= \row ->
 113                 (P.eof $> rows) <|>
 114                 (P.newline >> p_Rows (appendRow rows (List.reverse row)))
 115
 116 p_Trees :: Parser e s (Trees (Cell Key) (Cell Text))
 117 p_Trees = unRoot . collapseRows <$> p_Rows [root]
 118         where
 119         root = TreeN (Cell (0,0) (0,0) KeyDash) mempty
 120         unRoot (TreeN (unCell -> KeyDash) roots) = roots
 121         unRoot _ = undefined