Language/TCT/Read.hs

   1 module Language.TCT.Read
   2  ( module Language.TCT.Read.Tree
   3  , module Language.TCT.Read.Token
   4  , module Language.TCT.Read.Cell
   5  , module Language.TCT.Read
   6  ) where
   7
   8 import Control.Applicative (Applicative(..))
   9 import Control.Monad (Monad(..))
  10 import Data.Either (Either(..))
  11 import Data.Foldable (Foldable(..))
  12 import Data.Function (($))
  13 import Data.Functor ((<$>))
  14 import Data.Traversable (Traversable(..))
  15 import Data.TreeSeq.Strict (Tree(..), Trees)
  16 import Data.Void (Void)
  17 import System.IO (FilePath)
  18 import qualified Data.Text.Lazy as TL
  19 import qualified Text.Megaparsec as P
  20
  21 import Language.TCT.Debug
  22 import Language.TCT.Tree
  23 import Language.TCT.Cell
  24 import Language.TCT.Read.Cell
  25 import Language.TCT.Read.Tree
  26 import Language.TCT.Read.Token
  27
  28 -- | Parsing is done in two phases:
  29 --
  30 -- 1. indentation-sensitive parsing on 'TL.Text'
  31 -- 2. Pair-sensitive parsing on some 'NodeText's resulting of 1.
  32 readTrees ::
  33  FilePath -> TL.Text ->
  34  Either (P.ParseError (P.Token TL.Text) (P.ErrorFancy Void)) (Trees (Cell Node))
  35 readTrees inp txt = do
  36         trs <- P.runParser (p_Trees <* P.eof) inp txt
  37         traverse (go NodeGroup) $ debug0 "readTrees" trs
  38         where
  39         go :: Node -> Tree (Cell Node) ->
  40          Either (P.ParseError (P.Token TL.Text) (P.ErrorFancy Void))
  41                 (Tree (Cell Node))
  42         go parent t@(Tree c@(Cell bn en nod) ts) =
  43                 case nod of
  44                  NodeLower{} -> Right t
  45                  -- NOTE: preserve NodeText ""
  46                  NodeText n | TL.null n -> Right t
  47                  NodeText n ->
  48                         case parent of
  49                          NodeHeader HeaderBar{}      -> Right t
  50                          NodeHeader HeaderEqual{}    -> Right t
  51                          NodeHeader HeaderDashDash{} -> Right t
  52                          _ -> do
  53                                 toks <- parseTokens <$> parseLexemes inp (Cell bn en n)
  54                                 return $
  55                                         case toList toks of
  56                                          [tok] -> tok
  57                                          _ -> Tree (Cell bn en NodeGroup) toks
  58                  _ -> Tree c <$> traverse (go nod') ts
  59                         where
  60                         -- NOTE: skip parent 'Node's whose semantic does not change 'NodeText'
  61                         nod' = case nod of
  62                          NodeGroup -> parent
  63                          NodePara  -> parent
  64                          _ -> nod