module Language.TCT.Read.Elem where
import Control.Applicative (Applicative(..), Alternative(..))
-import Control.Monad ((>>))
+import Control.Monad (Monad(..))
import Data.Bool
import Data.Char (Char)
import Data.Eq (Eq(..))
import Data.Function (($))
-import Data.Functor ((<$>))
+import Data.Functor ((<$>), (<$))
+import Data.Maybe (Maybe(..))
import Data.Semigroup (Semigroup(..))
-import Data.String (String)
-import Data.Text (Text)
-import Text.Show (Show(..))
import qualified Data.Char as Char
-import qualified Data.Text as Text
import qualified Text.Megaparsec as P
+import qualified Text.Megaparsec.Char as P
+import qualified Data.Text.Lazy as TL
+import Language.TCT.Debug
import Language.TCT.Elem
+import Language.TCT.Tree
+import Language.TCT.Read.Cell
--- * Type 'Parser'
--- | Convenient alias.
-type Parser e s a =
- ( P.ErrorComponent e
- , P.ShowErrorComponent e
- , P.Stream s
- , P.Token s ~ Char
- ) => P.Parsec e s a
+-- * Word
+p_Spaces :: P.Tokens s ~ TL.Text => Parser e s TL.Text
+p_Spaces = P.takeWhileP (Just "Space") Char.isSpace
+p_Spaces1 :: P.Tokens s ~ TL.Text => Parser e s TL.Text
+p_Spaces1 = P.takeWhile1P (Just "Space") Char.isSpace
+p_HSpaces :: P.Tokens s ~ TL.Text => Parser e s TL.Text
+p_HSpaces = P.takeWhileP (Just "HSpace") (==' ')
+p_Digits :: P.Tokens s ~ TL.Text => Parser e s TL.Text
+p_Digits = P.takeWhileP (Just "Digit") Char.isDigit
+p_Digits1 :: P.Tokens s ~ TL.Text => Parser e s TL.Text
+p_Digits1 = P.takeWhile1P (Just "Digit1") Char.isDigit
+p_AlphaNums :: P.Tokens s ~ TL.Text => Parser e s TL.Text
+p_AlphaNums = P.takeWhileP (Just "AlphaNum") Char.isAlphaNum
+p_AlphaNums1 :: P.Tokens s ~ TL.Text => Parser e s TL.Text
+p_AlphaNums1 = P.takeWhile1P (Just "AlphaNum1") Char.isAlphaNum
+{-
+-- NOTE: could be done with TL.Text, which has a less greedy (<>).
+p_Word :: Parser e Text Text
+p_Word = debugParser "Word" $ P.try p_take <|> p_copy
+ where
+ p_take = do
+ P.notFollowedBy $ P.satisfy $ not . Char.isAlphaNum
+ w <- P.takeWhile1P (Just "Word") $ \c ->
+ Char.isAlphaNum c ||
+ c == '_' ||
+ c == '-'
+ guard $ Char.isAlphaNum $ Text.last w
+ return w
+ p_copy =
+ (<>)
+ <$> p_AlphaNums1
+ <*> P.option "" (P.try $
+ (<>)
+ <$> ((Text.pack <$>) $ P.some $ P.char '_' <|> P.char '-')
+ <*> p_copy)
+-}
+
+-- * Elem
+p_ElemSingle :: P.Tokens s ~ TL.Text => Parser e s Pair
+p_ElemSingle = debugParser "ElemSingle" $
+ PairElem
+ <$ P.char '<'
+ <*> p_ElemName
+ <*> p_ElemAttrs
+ <* P.string "/>"
+
+p_ElemOpen :: P.Tokens s ~ TL.Text => Parser e s Pair
+p_ElemOpen = debugParser "ElemOpen" $
+ PairElem
+ <$ P.char '<'
+ <*> p_ElemName
+ <*> p_ElemAttrs
+ <* P.char '>'
+
+p_ElemName :: P.Tokens s ~ TL.Text => Parser e s ElemName
+p_ElemName = p_AlphaNums1
+ -- TODO: namespace
+
+p_ElemClose :: P.Tokens s ~ TL.Text => Parser e s Pair
+p_ElemClose = debugParser "ElemClose" $
+ (`PairElem` [])
+ <$ P.string "</"
+ <*> p_ElemName
+ <* P.char '>'
-pdbg :: ( Show a
- , P.ErrorComponent e
- , P.ShowErrorComponent e
- , P.Stream s
- , P.Token s ~ Char
- , P.ShowToken (P.Token s)
- , P.Stream s
- ) => String -> P.ParsecT e s m a -> P.ParsecT e s m a
--- pdbg m p = P.dbg m p
-pdbg _m p = p
-{-# INLINE pdbg #-}
+{-
+p_ElemOpenOrSingle :: Parser e Text Pair
+p_ElemOpenOrSingle =
+ p_ElemOpen >>= \p ->
+ P.char '>' $> LexemePairOpen p <|>
+ P.string "/>" $> LexemePairAny p
+-}
-p_Attrs :: Parser e s [(Text,Attr)]
-p_Attrs = P.many $ P.try $ (,) <$> p_Spaces <*> p_Attr
-p_Attr :: Parser e s Attr
-p_Attr = P.try p_Attr_Eq <|> p_Attr_Word
-p_Spaces :: Parser e s Text
-p_Spaces = Text.pack <$> P.some (P.satisfy Char.isSpace)
-p_Attr_Eq :: Parser e s Attr
-p_Attr_Eq =
- (\n (o,v,c) -> Attr n ("="<>o) v c)
- <$> p_Word
+-- * 'ElemAttr'
+p_ElemAttrs :: P.Tokens s ~ TL.Text => Parser e s [(White,ElemAttr)]
+p_ElemAttrs = P.many $ P.try $ (,) <$> p_Spaces <*> p_ElemAttr
+p_ElemAttr :: P.Tokens s ~ TL.Text => Parser e s ElemAttr
+p_ElemAttr = P.try p_ElemAttrEq <|> p_ElemAttrName
+
+p_ElemAttrEq :: P.Tokens s ~ TL.Text => Parser e s ElemAttr
+p_ElemAttrEq =
+ (\n (o,v,c) -> ElemAttr n ("="<>o) v c)
+ <$> p_ElemName
<* P.char '='
- <*> p_Attr_Value
-p_Attr_Word :: Parser e s Attr
-p_Attr_Word =
- (\(o,v,c) -> Attr "" o v c)
- <$> p_Attr_Value_Word
-p_Attr_Value :: Parser e s (Text,Text,Text)
-p_Attr_Value =
- p_Attr_Value_Quote '\'' <|>
- p_Attr_Value_Quote '"' <|>
- p_Attr_Value_Word
-p_Attr_Value_Quote :: Char -> Parser e s (Text,Text,Text)
-p_Attr_Value_Quote q =
- (\o v c -> (Text.singleton o, Text.pack v, Text.singleton c))
+ <*> p_ElemAttrValue
+p_ElemAttrName :: P.Tokens s ~ TL.Text => Parser e s ElemAttr
+p_ElemAttrName =
+ (\n -> ElemAttr n "" "" "")
+ <$> p_ElemName
+
+p_ElemAttrValue :: P.Tokens s ~ TL.Text => Parser e s (TL.Text,TL.Text,TL.Text)
+p_ElemAttrValue =
+ p_ElemAttrValueQuote '\'' <|>
+ p_ElemAttrValueQuote '"' <|>
+ p_ElemAttrValueWord
+
+p_ElemAttrValueQuote :: Char -> P.Tokens s ~ TL.Text => Parser e s (TL.Text,TL.Text,TL.Text)
+p_ElemAttrValueQuote q =
+ (\o v c -> (TL.singleton o, v, TL.singleton c))
<$> P.char q
- <*> P.many (
- P.notFollowedBy (P.string "/>") >>
- P.satisfy (\c -> Char.isPrint c && c /= '>' && c/=q))
+ <*> P.takeWhile1P (Just "ElemAttrValueQuoted") (/=q)
<*> P.char q
-p_Attr_Value_Word :: Parser e s (Text,Text,Text)
-p_Attr_Value_Word =
- (\v -> ("", Text.pack v, ""))
- <$> P.many (P.satisfy Char.isAlphaNum)
-
-p_Word :: Parser e s Text
-p_Word = pdbg "Word" $
- (<>)
- <$> p_plain
- <*> P.option "" (p_plain <|> p_link)
- where
- p_link = P.try $
- (<>)
- <$> (Text.pack <$> P.some (P.satisfy (\c -> c=='_' || c=='-')))
- <*> p_plain
- p_plain =
- Text.pack
- <$> P.some (P.satisfy $ \c ->
- Char.isLetter c ||
- Char.isNumber c
- )
+p_ElemAttrValueWord :: P.Tokens s ~ TL.Text => Parser e s (TL.Text,TL.Text,TL.Text)
+p_ElemAttrValueWord = do
+ w <- P.takeWhile1P (Just "ElemAttrValueWord") $ \c ->
+ Char.isPrint c &&
+ not (Char.isSpace c) &&
+ c /= '\'' &&
+ c /= '"' &&
+ c /= '=' &&
+ c /= '/' &&
+ c /= '<' &&
+ c /= '>'
+ return ("",w,"")
sourcephile / git / doclang.git / blobdiff