Language/TCT/Read/Elem.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE Rank2Types #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5 module Language.TCT.Read.Elem where
   6
   7 import Control.Applicative (Applicative(..), Alternative(..))
   8 import Control.Monad (Monad(..))
   9 import Data.Bool
  10 import Data.Char (Char)
  11 import Data.Eq (Eq(..))
  12 import Data.Function (($))
  13 import Data.Functor ((<$>), (<$))
  14 import Data.Maybe (Maybe(..))
  15 import Data.Semigroup (Semigroup(..))
  16 import qualified Data.Char as Char
  17 import qualified Text.Megaparsec as P
  18 import qualified Text.Megaparsec.Char as P
  19 import qualified Data.Text.Lazy as TL
  20
  21 import Language.TCT.Debug
  22 import Language.TCT.Elem
  23 import Language.TCT.Tree
  24 import Language.TCT.Read.Cell
  25
  26 -- * Word
  27 p_Spaces :: P.Tokens s ~ TL.Text => Parser e s TL.Text
  28 p_Spaces = P.takeWhileP (Just "Space") Char.isSpace
  29 p_Spaces1 :: P.Tokens s ~ TL.Text => Parser e s TL.Text
  30 p_Spaces1 = P.takeWhile1P (Just "Space") Char.isSpace
  31 p_HSpaces :: P.Tokens s ~ TL.Text => Parser e s TL.Text
  32 p_HSpaces = P.takeWhileP (Just "HSpace") (==' ')
  33 p_Digits :: P.Tokens s ~ TL.Text => Parser e s TL.Text
  34 p_Digits = P.takeWhile1P (Just "Digit") Char.isDigit
  35 p_AlphaNums :: P.Tokens s ~ TL.Text => Parser e s TL.Text
  36 p_AlphaNums = P.takeWhile1P (Just "AlphaNum") Char.isAlphaNum
  37 {-
  38 -- NOTE: could be done with TL.Text, which has a less greedy (<>).
  39 p_Word :: Parser e Text Text
  40 p_Word = debugParser "Word" $ P.try p_take <|> p_copy
  41         where
  42         p_take = do
  43                 P.notFollowedBy $ P.satisfy $ not . Char.isAlphaNum
  44                 w <- P.takeWhile1P (Just "Word") $ \c ->
  45                         Char.isAlphaNum c ||
  46                         c == '_' ||
  47                         c == '-'
  48                 guard $ Char.isAlphaNum $ Text.last w
  49                 return w
  50         p_copy =
  51                 (<>)
  52                  <$> p_AlphaNums
  53                  <*> P.option "" (P.try $
  54                         (<>)
  55                          <$> ((Text.pack <$>) $ P.some $ P.char '_' <|> P.char '-')
  56                          <*> p_copy)
  57 -}
  58
  59 -- * Elem
  60 p_ElemSingle :: P.Tokens s ~ TL.Text => Parser e s Pair
  61 p_ElemSingle = debugParser "ElemSingle" $
  62         PairElem
  63          <$  P.char '<'
  64          <*> p_ElemName
  65          <*> p_ElemAttrs
  66          <*  P.string "/>"
  67
  68 p_ElemOpen :: P.Tokens s ~ TL.Text => Parser e s Pair
  69 p_ElemOpen = debugParser "ElemOpen" $
  70         PairElem
  71          <$  P.char '<'
  72          <*> p_ElemName
  73          <*> p_ElemAttrs
  74          <*  P.char '>'
  75
  76 p_ElemName :: P.Tokens s ~ TL.Text => Parser e s ElemName
  77 p_ElemName = p_AlphaNums
  78  -- TODO: namespace
  79
  80 p_ElemClose :: P.Tokens s ~ TL.Text => Parser e s Pair
  81 p_ElemClose = debugParser "ElemClose" $
  82         (`PairElem` [])
  83          <$  P.string "</"
  84          <*> p_ElemName
  85          <*  P.char '>'
  86
  87 {-
  88 p_ElemOpenOrSingle :: Parser e Text Pair
  89 p_ElemOpenOrSingle =
  90         p_ElemOpen >>= \p ->
  91                 P.char    '>' $> LexemePairOpen p <|>
  92                 P.string "/>" $> LexemePairAny  p
  93 -}
  94
  95 -- * 'ElemAttr'
  96 p_ElemAttrs :: P.Tokens s ~ TL.Text => Parser e s [(White,ElemAttr)]
  97 p_ElemAttrs = P.many $ P.try $ (,) <$> p_Spaces <*> p_ElemAttr
  98 p_ElemAttr :: P.Tokens s ~ TL.Text => Parser e s ElemAttr
  99 p_ElemAttr = P.try p_ElemAttrEq <|> p_ElemAttrName
 100
 101 p_ElemAttrEq :: P.Tokens s ~ TL.Text => Parser e s ElemAttr
 102 p_ElemAttrEq =
 103         (\n (o,v,c) -> ElemAttr n ("="<>o) v c)
 104          <$> p_ElemName
 105          <*  P.char '='
 106          <*> p_ElemAttrValue
 107 p_ElemAttrName :: P.Tokens s ~ TL.Text => Parser e s ElemAttr
 108 p_ElemAttrName =
 109         (\n -> ElemAttr n "" "" "")
 110          <$> p_ElemName
 111
 112 p_ElemAttrValue :: P.Tokens s ~ TL.Text => Parser e s (TL.Text,TL.Text,TL.Text)
 113 p_ElemAttrValue =
 114         p_ElemAttrValueQuote '\'' <|>
 115         p_ElemAttrValueQuote '"'  <|>
 116         p_ElemAttrValueWord
 117
 118 p_ElemAttrValueQuote :: Char -> P.Tokens s ~ TL.Text => Parser e s (TL.Text,TL.Text,TL.Text)
 119 p_ElemAttrValueQuote q =
 120         (\o v c -> (TL.singleton o, v, TL.singleton c))
 121          <$> P.char q
 122          <*> P.takeWhile1P (Just "ElemAttrValueQuoted") (/=q)
 123          <*> P.char q
 124 p_ElemAttrValueWord :: P.Tokens s ~ TL.Text => Parser e s (TL.Text,TL.Text,TL.Text)
 125 p_ElemAttrValueWord = do
 126         w <- P.takeWhile1P (Just "ElemAttrValueWord") $ \c ->
 127                 Char.isPrint c &&
 128                 not (Char.isSpace c) &&
 129                 c /= '\'' &&
 130                 c /= '"' &&
 131                 c /= '=' &&
 132                 c /= '/' &&
 133                 c /= '<' &&
 134                 c /= '>'
 135         return ("",w,"")