symantic-grammar/Language/Symantic/Grammar/Terminal.hs

   1 {-# OPTIONS_GHC -fno-warn-orphans #-}
   2 -- | Symantics for terminal grammars.
   3 module Language.Symantic.Grammar.Terminal where
   4
   5 import Control.Applicative (Applicative(..))
   6 import Data.Bool
   7 import Data.Char (Char)
   8 import Data.Eq (Eq(..))
   9 import Data.Function (($), (.))
  10 import Data.Functor (Functor(..), (<$>))
  11 import Data.Semigroup (Semigroup(..))
  12 import Data.String (IsString(..), String)
  13 import Text.Show (Show(..))
  14 import qualified Data.Bool as Bool
  15 import qualified Data.Char as Char
  16 import qualified Data.List as List
  17 import qualified Data.Text as Text
  18 import qualified Data.Text.Lazy as TL
  19
  20 import Language.Symantic.Grammar.Fixity
  21 import Language.Symantic.Grammar.EBNF
  22
  23 -- * Type 'Terminal'
  24 -- | Terminal grammar.
  25 newtype Terminal g a
  26  =      Terminal { unTerminal :: g a }
  27  deriving (Functor, Gram_Char, Gram_String)
  28 deriving instance Gram_Rule g => Gram_Rule (Terminal g)
  29
  30 -- ** Class 'Gram_Char'
  31 -- | Symantics for terminal grammars.
  32 class Gram_Rule g => Gram_Char g where
  33         any    :: g Char
  34         but    :: Terminal g Char -> Terminal g Char -> Terminal g Char
  35         eoi    :: g ()
  36         eol    :: g Char
  37         space  :: g Char
  38         char   :: Char -> g Char
  39         unicat :: Unicat -> g Char
  40         range  :: (Char, Char) -> g Char
  41         eol   = rule "NewLine" $ char '\n'
  42         space = rule "Space" $ char ' '
  43 deriving instance Gram_Char RuleEBNF
  44 instance Gram_Char EBNF where
  45         any  = ebnf_const "_"
  46         Terminal (EBNF f) `but` Terminal (EBNF g) =
  47                 Terminal $ EBNF $ \bo po -> pairIfNeeded pairParen po op $
  48                         f bo (op, SideL) <> " - " <> g bo (op, SideR)
  49                 where op = infixL 6
  50         eoi   = ebnf_const "eoi"
  51         eol   = ebnf_const "↵"
  52         space = ebnf_const "␣"
  53         char  = ebnf_const . escape
  54                 where
  55                 escape c | Char.isPrint c && c /= '"' = Text.concat $ ["\"", Text.singleton c, "\""]
  56                 escape c = Text.concat ["U+", Text.pack $ show $ Char.ord c]
  57         unicat = ebnf_const . Text.pack . show
  58         range (l, h) = ebnf_const $ Text.concat
  59          [ runEBNF $ char l
  60          , "…"
  61          , runEBNF $ char h
  62          ]
  63
  64 -- *** Type 'Unicat'
  65 -- | Unicode category.
  66 data Unicat
  67  = Unicat_Letter
  68  | Unicat_Mark
  69  | Unicat_Number
  70  | Unicat_Punctuation
  71  | Unicat_Symbol
  72  | Unicat Char.GeneralCategory
  73  deriving (Eq, Show)
  74
  75 unicode_categories :: Unicat -> [Char.GeneralCategory]
  76 unicode_categories c =
  77         case c of
  78          Unicat_Letter ->
  79                  [ Char.UppercaseLetter
  80                  , Char.LowercaseLetter
  81                  , Char.TitlecaseLetter
  82                  , Char.ModifierLetter
  83                  , Char.OtherLetter
  84                  ]
  85          Unicat_Mark ->
  86                  [ Char.NonSpacingMark
  87                  , Char.SpacingCombiningMark
  88                  , Char.EnclosingMark
  89                  ]
  90          Unicat_Number ->
  91                  [ Char.DecimalNumber
  92                  , Char.LetterNumber
  93                  , Char.OtherNumber
  94                  ]
  95          Unicat_Punctuation ->
  96                  [ Char.ConnectorPunctuation
  97                  , Char.DashPunctuation
  98                  , Char.OpenPunctuation
  99                  , Char.ClosePunctuation
 100                  , Char.OtherPunctuation
 101                  ]
 102          Unicat_Symbol ->
 103                  [ Char.MathSymbol
 104                  , Char.CurrencySymbol
 105                  , Char.ModifierSymbol
 106                  , Char.OtherSymbol
 107                  ]
 108          Unicat cat -> [cat]
 109
 110 -- ** Class 'Gram_String'
 111 class Functor g => Gram_String g where
 112         string   :: String -> g String
 113         {-
 114         string = foldr (\c -> (<*>) ((:) <$> char c)) (pure "")
 115         string [] = pure []
 116         string (c:cs) = (:) <$> char c <*> string cs
 117         -}
 118         text     :: Text.Text -> g Text.Text
 119         textLazy :: TL.Text -> g TL.Text
 120         text t     = Text.pack <$> string (Text.unpack t)
 121         textLazy t = TL.pack   <$> string (TL.unpack t)
 122 deriving instance Gram_String RuleEBNF
 123 instance Gram_String EBNF where
 124         string s =
 125                 case List.break (\c -> Bool.not (Char.isPrint c) || c == '"') s of
 126                  (ps, "")   -> raw ps
 127                  ("", [c])  -> "" <$ char c
 128                  (ps, [c])  -> "" <$ raw ps <* char c
 129                  ("", c:rs) -> "" <$ char c <* string rs
 130                  (ps, c:rs) -> "" <$ raw ps <* char c <* string rs
 131                 where
 132                 raw cs = ebnf_const $ Text.concat $ ["\"", Text.pack cs, "\""]
 133 instance IsString (EBNF String) where
 134         fromString = string