Language/TCT/Read/Tree.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 module Language.TCT.Read.Tree where
   4
   5 import Control.Applicative (Applicative(..), Alternative(..))
   6 import Control.Monad (Monad(..), void)
   7 import Data.Bool
   8 import Data.Char (Char)
   9 import Data.Eq (Eq(..))
  10 import Data.Monoid (Monoid(..))
  11 import Data.Function (($), (.))
  12 import Data.Functor ((<$>), ($>))
  13 import Data.Semigroup (Semigroup(..))
  14 import Data.Sequence (ViewR(..))
  15 import Data.String (String)
  16 import Prelude (undefined, Int, Num(..), toInteger)
  17 import Data.Text (Text)
  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.Sequence as Seq
  23 import qualified Data.Text as Text
  24 import qualified Text.Megaparsec as P
  25
  26 import Language.TCT.Tree
  27
  28 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
  29 -- pdbg m p = P.dbg m p
  30 pdbg _m p = p
  31
  32 -- * Type 'Pos'
  33 p_Position :: Parser (Line,Column)
  34 p_Position = (\p -> (intOfPos $ P.sourceLine p, intOfPos $ P.sourceColumn p)) <$> P.getPosition
  35 intOfPos :: P.Pos -> Int
  36 intOfPos = fromInteger . toInteger . P.unPos
  37
  38 -- ** Type 'Line'
  39 p_Line :: Parser Line
  40 p_Line = intOfPos . P.sourceLine <$> P.getPosition
  41
  42 -- ** Type 'Column'
  43 p_Column :: Parser Column
  44 p_Column = intOfPos . P.sourceColumn <$> P.getPosition
  45
  46 -- * Type 'Row'
  47 p_Row :: Row -> Parser Row
  48 p_Row row = pdbg "Row" $
  49         P.try (p_CellKey row) <|>
  50         P.try (p_CellValue row) <|>
  51         p_PlainLine row -- <|>
  52         -- (P.newline $> row) <|>
  53         -- (P.eof $> row)
  54
  55 -- ** Type 'Key'
  56 p_CellKey :: Row -> Parser Row
  57 p_CellKey row = pdbg "CellKey" $ do
  58         P.skipMany $ P.char ' '
  59         pos <- p_Position
  60         key <- pdbg "Key" $
  61                 P.choice $
  62                  [ P.try $ P.string "- " $> KeyDash
  63                  -- TODO: KeyNum
  64                  -- TODO: KeyComment
  65                  , P.try $ P.some (P.char '#') <* P.char ' ' >>= \hs ->
  66                         return (KeySection $ List.length hs)
  67                  , do
  68                         name <- Text.pack <$> some (P.satisfy $ \c ->
  69                                 Char.isAlphaNum c || c=='-' || c=='_')
  70                         P.skipMany $ P.char ' '
  71                         P.choice
  72                          [ P.char ':' $> KeyColon name
  73                          , P.char '>' $> KeyGreat name
  74                          , P.char '=' $> KeyEqual name
  75                          , P.char '|' $> KeyBar   name
  76                          -- TODO: KeyAt
  77                          ]
  78                  ]
  79         posEnd <- p_Position
  80         let row' = Key pos posEnd key : row
  81         case key of
  82          KeySection{} -> P.try (p_CellValue row') <|> p_PlainLine row'
  83          KeyDash{}    -> p_Row row'
  84          KeyColon{}   -> p_Row row'
  85          KeyGreat{}   -> p_Row row'
  86          KeyEqual{}   -> p_PlainLine row'
  87          KeyBar{}     -> p_PlainLine row'
  88
  89 -- | Parse up to an end-of-line or end-of-file.
  90 p_PlainLine :: Row -> Parser Row
  91 p_PlainLine row = pdbg "PlainLine" $ do
  92         P.skipMany $ P.char ' '
  93         pos <- p_Position
  94         line <- many $ P.satisfy (/='\n')
  95         posEnd <- p_Position
  96         P.newline $> Value pos posEnd (Text.pack line) : row
  97          <|> P.eof $> row
  98
  99 -- *** Type 'Group'
 100 p_CellValue :: Row -> Parser Row
 101 p_CellValue row = pdbg "CellValue" $ do
 102         P.skipMany $ P.char ' '
 103         pos <- p_Position
 104         val <- Text.pack <$> P.some (P.satisfy (/='\n'))
 105         posEnd <- p_Position
 106         return $ Value pos posEnd val : row
 107
 108 p_Value :: Parser Value
 109 p_Value = pdbg "Value" $
 110         -- (List.foldl' (<>) (Plain "") <$>) $
 111         -- some $
 112         Plain . Text.pack
 113          <$> P.some (P.satisfy (/='\n'))
 114         {-
 115         P.choice $
 116          [ -- P.try p_Escape
 117          -- , P.try p_Tag
 118          -- , P.try p_Group
 119          , p_Plain
 120          ]
 121         -}
 122
 123 p_Tag :: Parser Value
 124 p_Tag = pdbg "Tag" $ P.try p_TagGroup <|> p_TagOpen
 125         where
 126         p_TagGroup = P.char '#' *> p_TagName <* P.char '#'
 127                 where
 128                 p_TagName :: Parser Value
 129                 p_TagName =
 130                         (\w ws -> Tag $ Text.concat $ w : ws)
 131                          <$> p_TagNameWord
 132                          <*> many ((<>) <$> (Text.pack <$> many (P.char ' ')) <*> p_TagNameWord)
 133                 p_TagNameWord = Text.pack <$> some (P.satisfy $ \c -> c/=' ' && c/='#' && Char.isPrint c)
 134         p_TagOpen = P.char '#' *> p_TagName
 135                 where
 136                 p_TagName = Tag . Text.pack <$> some (P.satisfy isTagNameShortChar)
 137
 138 isTagNameShortChar :: Char -> Bool
 139 isTagNameShortChar c | Char.isAlphaNum c = True
 140 isTagNameShortChar '-' = True
 141 isTagNameShortChar '_' = True
 142 isTagNameShortChar _   = False
 143
 144 p_Escape :: Parser Value
 145 p_Escape = do
 146         void $ P.char '\\'
 147         P.option (Plain $ "\\") $ P.try $ do
 148                 P.choice
 149                  [ P.char c >> pure (Plain $ Text.singleton c)
 150                  | c <- "<>=|@#*_\\/`'\"«»-"
 151                  ]
 152
 153 p_Group :: Parser Value
 154 p_Group =
 155         P.choice
 156          [ p_Group1 Star        '*'
 157          , p_Group1 Slash       '/'
 158          , p_Group1 Underscore  '_'
 159          , p_Group1 Dash        '-'
 160          , p_Group1 Backquote   '`'
 161          , p_Group1 Singlequote '\''
 162          , p_Group1 Doublequote '"'
 163          -- , Group Frenchquote <$ p_Group2 '«' '»'
 164          ]
 165
 166 p_Group1 :: Group -> Char -> Parser Value
 167 p_Group1 g c = (if c == '/' then pdbg "Group1" else (\p -> p)) $ do
 168         void $ P.char c
 169         P.option (Plain $ Text.singleton c) $ P.try $ do
 170                 P.notFollowedBy $ P.char ' '
 171                 v <- (if c == '/' then pdbg "Group1: Value" else (\p -> p)) $ p_Value
 172                 case lastCharOfValue v of
 173                  ' ' -> fail "grouped Value ends with space"
 174                  _   -> return ()
 175                 void $ P.char c
 176                 return $ Group g v
 177
 178 lastCharOfValue :: Value -> Char
 179 lastCharOfValue = \case
 180  Plain t -> Text.last t
 181  Tag t | Text.all (\c -> Char.isAlphaNum c || c=='-' || c=='_') t -> Text.last t
 182  Tag _t -> '#'
 183  Group _ v -> lastCharOfValue v
 184  Values vs | _:>v <- Seq.viewr vs -> lastCharOfValue v
 185  Values{} -> undefined
 186
 187 p_Plain :: Parser Value
 188 p_Plain = pdbg "Plain" $
 189         Plain . Text.pack
 190          <$> P.some
 191                  (P.satisfy $ \case
 192                          '\n' -> False
 193                          '#'  -> False
 194                          '*'  -> False
 195                          '_'  -> False
 196                          '/'  -> False
 197                          '`'  -> False
 198                          '\'' -> False
 199                          '"'  -> False
 200                          '«'  -> False
 201                          '»'  -> False
 202                          _    -> True
 203                  )
 204
 205 -- * Type 'Rows'
 206
 207 -- | @a-- * Type 'TCT'
 208
 209 p_TCT :: Parser (TCT Text)
 210 p_TCT = do
 211         tree <- collapsePath <$> go [Tree (Value (0,0) (0,0) "") mempty]
 212         return $
 213                 case tree of
 214                  Tree (Value _ _ v) roots | Text.null v -> roots
 215                  _ -> undefined
 216         where
 217         go :: Rows -> Parser Rows
 218         go acc = pdbg "go" $
 219                 p_Row [] >>= \case
 220                  []  -> return acc
 221                  row -> go $ appendRow acc (List.reverse row)