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 ((>>))
   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.Semigroup (Semigroup(..))
  15 import Data.String (String)
  16 import Data.Text (Text)
  17 import Text.Show (Show(..))
  18 import qualified Data.Char as Char
  19 import qualified Data.Text as Text
  20 import qualified Text.Megaparsec as P
  21 import qualified Data.Text.Lazy as TL
  22
  23 import Language.TCT.Elem
  24
  25 -- * Type 'Parser'
  26 -- | Convenient alias.
  27 type Parser e s a =
  28  ( P.ErrorComponent e
  29  , P.ShowErrorComponent e
  30  , P.Stream s
  31  , P.Token s ~ Char
  32  ) => P.Parsec e s a
  33
  34 pdbg :: ( Show a
  35         , P.ErrorComponent e
  36         , P.ShowErrorComponent e
  37         , P.Stream s
  38         , P.Token s ~ Char
  39         , P.ShowToken (P.Token s)
  40         , P.Stream s
  41         ) => String -> P.ParsecT e s m a -> P.ParsecT e s m a
  42 -- pdbg m p = P.dbg m p
  43 pdbg _m p = p
  44 {-# INLINE pdbg #-}
  45
  46 p_Attrs :: Parser e s [(White,Attr)]
  47 p_Attrs = P.many $ P.try $ (,) <$> p_Spaces <*> p_Attr
  48 p_Attr :: Parser e s Attr
  49 p_Attr = P.try p_Attr_Eq <|> p_Attr_Word
  50 p_Spaces :: Parser e s White
  51 p_Spaces = Text.pack <$> P.some (P.satisfy Char.isSpace)
  52 p_Attr_Eq :: Parser e s Attr
  53 p_Attr_Eq =
  54         (\n (o,v,c) -> Attr (TL.toStrict n) ("="<>o) v c)
  55          <$> p_Word
  56          <*  P.char '='
  57          <*> p_Attr_Value
  58 p_Attr_Word :: Parser e s Attr
  59 p_Attr_Word =
  60         (\(o,v,c) -> Attr "" o v c)
  61          <$> p_Attr_Value_Word
  62 p_Attr_Value :: Parser e s (Text,Text,Text)
  63 p_Attr_Value =
  64         p_Attr_Value_Quote '\'' <|>
  65         p_Attr_Value_Quote '"'  <|>
  66         p_Attr_Value_Word
  67 p_Attr_Value_Quote :: Char -> Parser e s (Text,Text,Text)
  68 p_Attr_Value_Quote q =
  69         (\o v c -> (Text.singleton o, Text.pack v, Text.singleton c))
  70          <$> P.char q
  71          <*> P.many (
  72                 P.notFollowedBy (P.string "/>") >>
  73                 P.satisfy (\c -> Char.isPrint c && c /= '>' && c/=q))
  74          <*> P.char q
  75 p_Attr_Value_Word :: Parser e s (Text,Text,Text)
  76 p_Attr_Value_Word =
  77         (\v -> ("", Text.pack v, ""))
  78          <$> P.many (P.satisfy Char.isAlphaNum)
  79
  80 p_Word :: Parser e s TL.Text
  81 p_Word = pdbg "Word" $
  82         (<>)
  83          <$> p_plain
  84          <*> P.option "" (p_plain <|> p_hyphen)
  85         where
  86         p_hyphen = P.try $
  87                 (<>)
  88                  <$> (TL.pack <$> P.some (P.satisfy (\c -> c=='_' || c=='-')))
  89                  <*> p_plain
  90         p_plain =
  91                 TL.pack
  92                  <$> P.some (P.satisfy $ \c ->
  93                         Char.isLetter c ||
  94                         Char.isNumber c
  95                  )