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