Language/TCT.hs

   1 {-# OPTIONS_GHC -fno-warn-orphans #-}
   2 {-# LANGUAGE TypeFamilies #-}
   3 {-# LANGUAGE TupleSections #-}
   4 {-# LANGUAGE LambdaCase #-}
   5 {-# LANGUAGE NoMonomorphismRestriction #-}
   6 {-# LANGUAGE FlexibleContexts #-}
   7 {-# LANGUAGE ViewPatterns #-}
   8 module Language.TCT where
   9
  10 import Data.Bool
  11 import Control.Applicative (Applicative(..), Alternative(..))
  12 import qualified Data.Char as Char
  13 import qualified Data.List as List
  14 import Data.Semigroup ((<>))
  15 -- import Data.Tuple (fst,snd)
  16 import Data.Maybe (Maybe(..))
  17 import Data.Ord (Ordering(..), Ord(..))
  18 import Data.Function (($), (.))
  19 import Data.Functor ((<$>))
  20 import Control.Monad (Monad(..))
  21 import Data.Eq (Eq(..))
  22 import Data.Text (Text)
  23 import qualified Data.Text as T
  24 import Text.Show (Show(..))
  25 import Data.String (String)
  26 import Text.Megaparsec.Text
  27 import Prelude (undefined, Int, Num(..), toInteger)
  28 import qualified Text.Megaparsec as P
  29
  30 import Data.Tree
  31 import Debug.Trace ()
  32
  33 trac :: String -> a -> a
  34 trac _m x = x
  35
  36 dbg :: Show a => String -> a -> a
  37 dbg m x = trac (m <> ": " <> show x) x
  38
  39 pdbg :: (Show a, P.ShowErrorComponent e, P.ShowToken (P.Token s), P.Stream s) => String -> P.ParsecT e s m a -> P.ParsecT e s m a
  40 pdbg m p = P.dbg m p
  41
  42 column :: Parser Col
  43 column = fromInteger . toInteger . P.unPos . P.sourceColumn <$> P.getPosition
  44
  45 type Col = Int
  46 type Name = Text
  47 data Token = Key   Key
  48            | Value Text
  49            deriving (Eq, Show)
  50 data Key = Great Name
  51          | Equal Name
  52          | Colon Name
  53          | Bar   Name
  54          | Dash
  55          | Section Int Value
  56          deriving (Eq, Show)
  57 data Value = Verbatim Text
  58            | Tag Text
  59            | Decoration Decoration Value
  60            deriving (Eq, Show)
  61 data Decoration = Bold
  62                 | Italic
  63                 | Underline
  64                 | Crossed
  65                 | Code
  66                 deriving (Eq, Show)
  67
  68 appendRow ::
  69  [(Col,Tree Token)] -> -- ^ parents, from closed to farest (non-strictly descending)
  70  [(Col,Token)] ->      -- ^ next row, from leftest column to rightest (non-stricly ascending)
  71  [(Col,Tree Token)]    -- ^ new parents
  72 appendRow [] row = ((`Node` []) <$>) <$> List.reverse row
  73 appendRow parents [] = parents
  74 appendRow ps@((colParent,parent@(Node tokParent nodesParent)):parents)
  75           rs@((colRow,tokRow):rows) =
  76         trac ("appendRow: ps=" <> show ps) $
  77         trac ("appendRow: rs=" <> show rs) $
  78         dbg "appendRow" $
  79         case dbg "colParent" colParent`compare`dbg "colRow" colRow of
  80          LT -> lt
  81          EQ ->
  82                 case (dbg "tokParent" tokParent,dbg "tokRow" tokRow) of
  83                  (Value p, Value r) -> appendRow ((colRow, Node tok nodesParent) : parents) rows
  84                                        where tok = Value $ p <> T.singleton '\n' <> padding colParent colRow <> r
  85                                              padding x y = T.replicate (fromInteger $ toInteger $ y - x) (T.singleton ' ')
  86                  (_, Key (Section sectionRow _)) | Just (sectionParent, sp:pars) <- collapseSection colRow ps ->
  87                         case dbg "sectionParent" sectionParent`compare`dbg "sectionRow" sectionRow of
  88                          LT -> appendRow ((colRow,Node tokRow []):sp:pars) rows
  89                          EQ -> appendRow ((colRow,Node tokRow []):insertChild sp pars) rows
  90                          GT -> gt
  91                  (Key (Section{}), Value{}) -> lt
  92                  (Key (Section{}), Key{})   -> lt
  93                  (Value{}, Key{}) -> eq
  94                  (Key{}, Key{})   -> eq
  95                  (Key{}, Value{}) -> eq
  96          GT -> gt
  97         where
  98         lt = appendRow [] rs <> ps
  99         eq = appendRow ((colRow,Node tokRow []):insertChild (colParent,parent) parents) rows
 100         gt = appendRow (insertChild (colParent,parent) parents) rs
 101         -- | Find the first section (if any), returning its level, and the path collpased upto it.
 102         collapseSection :: Col -> [(Col,Tree Token)] -> Maybe (Int,[(Col,Tree Token)])
 103         collapseSection col pars@((c,x):xs) | c==col =
 104                 case x of
 105                  Node (Key (Section s _)) _ -> Just (s,pars)
 106                  _ -> (\(s,cs) -> (s,insertChild (c,x) cs)) <$> collapseSection col xs
 107         collapseSection _ _ = Nothing
 108
 109 insertChild :: (Col,Tree Token) -> [(Col,Tree Token)] -> [(Col,Tree Token)]
 110 insertChild c ps@[] =
 111         trac ("insertChild: c="<>show c) $
 112         trac ("insertChild: ps="<>show ps) $
 113         dbg "insertChild" $
 114         [c]
 115 insertChild c@(colChild,child) ps@((colParent,Node tokParent nodesParent):parents) =
 116         trac ("insertChild: c="<>show c) $
 117         trac ("insertChild: ps="<>show ps) $
 118         dbg "insertChild" $
 119         case dbg "colParent" colParent`compare`dbg "colChild" colChild of
 120          LT -> (colParent,Node tokParent (nodesParent <> [child])) : parents
 121          EQ -> (colParent,Node tokParent (nodesParent <> [child])) : parents
 122          GT -> undefined
 123
 124 collapsePath :: [(Col,Tree Token)] -> Tree Token
 125 collapsePath [] = undefined
 126 collapsePath [(_,child)] = dbg "collapsePath" $ child
 127 collapsePath (child:parents) = dbg "collapsePath" $ collapsePath $ insertChild child parents
 128
 129 p_Row :: [(Col,Token)] -> Parser [(Col,Token)]
 130 p_Row path = pdbg "Path" $ do
 131         P.skipMany $ P.char ' '
 132         P.try p_Key <|> p_Value path
 133         where
 134         p_Key = do
 135                 colKey <- column
 136                 P.choice
 137                  [ P.string "- " >>
 138                         P.try (p_Row ((colKey,Key Dash):path)) <|>
 139                         p_Value ((colKey,Key Dash):path)
 140                  , P.try $ do
 141                         hs <- List.length <$> P.some (P.char '#') <* P.char ' '
 142                         v  <- p_line
 143                         p_Value $ (colKey,Key $ Section hs $ Verbatim v):path
 144                  , do
 145                         name <- T.pack <$> some (P.satisfy $ \c -> Char.isAlphaNum c || c=='-' || c=='_')
 146                         P.choice
 147                          [ P.char ':' >>
 148                                 P.try (p_Row ((colKey,Key $ Colon name):path)) <|>
 149                                 p_Value ((colKey,Key $ Colon name):path)
 150                          , P.char '>' >>
 151                                 P.try (p_Row ((colKey,Key $ Great name):path)) <|>
 152                                 p_Value ((colKey,Key $ Great name):path)
 153                          , P.char '=' >> p_Value ((colKey,Key $ Equal name):path)
 154                          , P.char '|' >> p_Value ((colKey,Key $ Bar   name):path)
 155                          ]
 156                  ]
 157         p_Value pth = pdbg "Value" $ do
 158                 colValue  <- column
 159                 P.option pth . P.try $ do
 160                         (\v -> (colValue, Value v) : pth)
 161                          <$> p_line
 162         p_line = T.pack <$> some (P.notFollowedBy (P.newline) *> P.anyChar)
 163
 164 p_TCT :: Parser [Tree Token]
 165 p_TCT = do
 166         tree <- collapsePath <$> go [(0,Node (Value T.empty) [])]
 167         return $
 168                 case tree of
 169                  Node (Value v) roots | T.null v -> roots
 170                  _ -> undefined
 171         where
 172         go :: [(Col,Tree Token)] -> Parser [(Col,Tree Token)]
 173         go acc = pdbg "go" $ do
 174                 P.skipMany $ P.char ' ' <|> P.char '\n'
 175                 p_Row [] >>= \case
 176                  [] -> return acc
 177                  row -> go $ appendRow acc (List.reverse row)
 178
 179 parser :: Parser [Tree Token]
 180 parser = p_TCT <* P.eof