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