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
  43 p_Attrs :: Parser e s [(Text,Attr)]
  44 p_Attrs = P.many $ P.try $ (,) <$> p_Spaces <*> p_Attr
  45 p_Attr :: Parser e s Attr
  46 p_Attr = P.try p_Attr_Eq <|> p_Attr_Word
  47 p_Spaces :: Parser e s Text
  48 p_Spaces = Text.pack <$> P.some (P.satisfy Char.isSpace)
  49 p_Attr_Eq :: Parser e s Attr
  50 p_Attr_Eq =
  51         (\n (o,v,c) -> Attr n ("="<>o) v c)
  52          <$> p_Word
  53          <*  P.char '='
  54          <*> p_Attr_Value
  55 p_Attr_Word :: Parser e s Attr
  56 p_Attr_Word =
  57         (\(o,v,c) -> Attr "" o v c)
  58          <$> p_Attr_Value_Word
  59 p_Attr_Value :: Parser e s (Text,Text,Text)
  60 p_Attr_Value =
  61         p_Attr_Value_Quote '\'' <|>
  62         p_Attr_Value_Quote '"'  <|>
  63         p_Attr_Value_Word
  64 p_Attr_Value_Quote :: Char -> Parser e s (Text,Text,Text)
  65 p_Attr_Value_Quote q =
  66         (\o v c -> (Text.singleton o, Text.pack v, Text.singleton c))
  67          <$> P.char q
  68          <*> P.many (P.satisfy $ \c ->
  69                 Char.isPrint c && c/='/' && c/='>' && c/=q)
  70          <*> P.char q
  71 p_Attr_Value_Word :: Parser e s (Text,Text,Text)
  72 p_Attr_Value_Word =
  73         (\v -> ("", Text.pack v, ""))
  74          <$> P.many (P.satisfy Char.isAlphaNum)
  75
  76 p_Word :: Parser e s Text
  77 p_Word = pdbg "Word" $
  78         (<>)
  79          <$> p_plain
  80          <*> P.option "" (p_plain <|> p_link)
  81         where
  82         p_link = P.try $
  83                 (<>)
  84                  <$> (Text.pack <$> P.some (P.satisfy (\c -> c=='_' || c=='-')))
  85                  <*> p_plain
  86         p_plain =
  87                 Text.pack
  88                  <$> P.some (P.satisfy $ \c ->
  89                         Char.isLetter c ||
  90                         Char.isNumber c
  91                  )