Language/TCT/Read.hs

   1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   2 {-# LANGUAGE TypeFamilies #-}
   3 {-# LANGUAGE ViewPatterns #-}
   4 module Language.TCT.Read
   5  ( module Language.TCT.Read.Tree
   6  , module Language.TCT.Read.Token
   7  , module Language.TCT.Read.Cell
   8  , module Language.TCT.Read
   9  ) where
  10
  11 import Control.Applicative (Applicative(..))
  12 import Control.Monad (Monad(..), join)
  13 import Data.Char (Char)
  14 import Data.Either (Either(..))
  15 import Data.Eq (Eq(..))
  16 import Data.Function (($), (.))
  17 import Data.Functor ((<$>), (<$))
  18 import Data.Foldable (Foldable(..))
  19 import Data.Maybe (Maybe(..))
  20 import Data.Ord (Ord(..))
  21 import Data.Proxy (Proxy(..))
  22 import Data.Semigroup (Semigroup(..))
  23 import Data.String (IsString)
  24 import Data.Traversable (Traversable(..))
  25 import Data.TreeSeq.Strict (Tree(..), Trees)
  26 import Data.Void (Void)
  27 import System.IO (FilePath)
  28 import Text.Show (Show(..))
  29 import qualified Data.Text.Lazy as TL
  30 import qualified Data.TreeSeq.Strict as Tree
  31 import qualified Text.Megaparsec as P
  32 -- import qualified Data.List as List
  33
  34 import Language.TCT.Tree
  35 import Language.TCT.Cell
  36 import Language.TCT.Read.Cell
  37 import Language.TCT.Read.Tree
  38 import Language.TCT.Read.Token
  39
  40 import Debug.Trace (trace)
  41
  42 readTrees ::
  43  FilePath -> TL.Text ->
  44  Either (P.ParseError (P.Token TL.Text) (P.ErrorFancy Void)) (Trees (Cell Node))
  45 readTrees inp txt = do
  46         trs <- P.runParser (p_Trees <* P.eof) inp txt
  47         {-(join <$>) $ -}
  48         traverse (go Nothing) $
  49                 trace ("### TRS ###\n"<>show (Tree.Pretty trs)) trs
  50         where
  51         go ::
  52          Maybe Node ->
  53          Tree (Cell Node) ->
  54          Either (P.ParseError (P.Token TL.Text) (P.ErrorFancy Void))
  55                 (Tree (Cell Node))
  56         go p t@(Tree c@(Cell bn en nod) ts) =
  57                 case nod of
  58                  NodeGroup{}  -> Tree c <$> traverse (go (Just nod)) ts
  59                  NodeHeader{} -> Tree c <$> traverse (go (Just nod)) ts
  60                  NodeToken{}  -> Tree c <$> traverse (go (Just nod)) ts
  61                  NodePair{}   -> Tree c <$> traverse (go (Just nod)) ts
  62                  NodePara{}   -> Tree c <$> traverse (go (Just nod)) ts
  63                  NodeLower{}  -> Right t
  64                  -- NodeText n | TL.null n -> Right t
  65                  NodeText n ->
  66                         case p of
  67                          Just (NodeHeader HeaderBar{})   -> Right t
  68                          Just (NodeHeader HeaderEqual{}) -> Right t
  69                          _ -> do
  70                                 toks <- parseTokens <$> parseLexemes inp (n <$ c)
  71                                 return $
  72                                         case toList toks of
  73                                          [tok] -> tok
  74                                          _ -> Tree (Cell bn en NodeGroup) toks
  75                  {-
  76                  NodeHeader _n -> pure . Tree c . join <$> traverse (go (Just nod)) ts
  77                  NodeToken  _n -> pure . Tree c . join <$> traverse (go (Just nod)) ts
  78                  NodePair   _n -> pure . Tree c . join <$> traverse (go (Just nod)) ts
  79                  NodeLower{} -> Right $ pure t
  80                  NodeText n | TL.null n  -> Right $ pure t
  81                  NodeText n ->
  82                         case p of
  83                          Just (NodeHeader HeaderBar{})   -> Right $ pure t
  84                          Just (NodeHeader HeaderEqual{}) -> Right $ pure t
  85                          _ -> do
  86                                 acc <- parseLexemes inp (n <$ c)
  87                                 sn <- traverse (go (Just nod)) ts
  88                                 return $ parseTokens $
  89                                         foldr (\s a -> orientLexemePairAny $ LexemeTree s:a) acc (join sn)
  90                  -}