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