{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Symantic.Grammar.Terminal where
import Control.Applicative (Applicative(..))
import Data.Bool
import Data.Char (Char)
import Data.Eq (Eq(..))
import Data.Function (($), (.))
import Data.Functor (Functor(..), (<$>))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..), String)
import Text.Show (Show(..))
import qualified Data.Bool as Bool
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import Language.Symantic.Grammar.Fixity
import Language.Symantic.Grammar.EBNF
newtype Terminal g a
= Terminal { unTerminal :: g a }
deriving (Functor, Gram_Char, Gram_String)
deriving instance Gram_Rule g => Gram_Rule (Terminal g)
class Gram_Rule g => Gram_Char g where
any :: g Char
but :: Terminal g Char -> Terminal g Char -> Terminal g Char
eoi :: g ()
eol :: g Char
space :: g Char
char :: Char -> g Char
unicat :: Unicat -> g Char
range :: (Char, Char) -> g Char
eol = rule "NewLine" $ char '\n'
space = rule "Space" $ char ' '
deriving instance Gram_Char RuleEBNF
instance Gram_Char EBNF where
any = ebnf_const "_"
Terminal (EBNF f) `but` Terminal (EBNF g) =
Terminal $ EBNF $ \bo po -> pairIfNeeded pairParen po op $
f bo (op, SideL) <> " - " <> g bo (op, SideR)
where op = infixL 6
eoi = ebnf_const "eoi"
eol = ebnf_const "↵"
space = ebnf_const "␣"
char = ebnf_const . escape
where
escape c | Char.isPrint c && c /= '"' = Text.concat $ ["\"", Text.singleton c, "\""]
escape c = Text.concat ["U+", Text.pack $ show $ Char.ord c]
unicat = ebnf_const . Text.pack . show
range (l, h) = ebnf_const $ Text.concat
[ runEBNF $ char l
, "…"
, runEBNF $ char h
]
data Unicat
= Unicat_Letter
| Unicat_Mark
| Unicat_Number
| Unicat_Punctuation
| Unicat_Symbol
| Unicat Char.GeneralCategory
deriving (Eq, Show)
unicode_categories :: Unicat -> [Char.GeneralCategory]
unicode_categories c =
case c of
Unicat_Letter ->
[ Char.UppercaseLetter
, Char.LowercaseLetter
, Char.TitlecaseLetter
, Char.ModifierLetter
, Char.OtherLetter
]
Unicat_Mark ->
[ Char.NonSpacingMark
, Char.SpacingCombiningMark
, Char.EnclosingMark
]
Unicat_Number ->
[ Char.DecimalNumber
, Char.LetterNumber
, Char.OtherNumber
]
Unicat_Punctuation ->
[ Char.ConnectorPunctuation
, Char.DashPunctuation
, Char.OpenPunctuation
, Char.ClosePunctuation
, Char.OtherPunctuation
]
Unicat_Symbol ->
[ Char.MathSymbol
, Char.CurrencySymbol
, Char.ModifierSymbol
, Char.OtherSymbol
]
Unicat cat -> [cat]
class Functor g => Gram_String g where
string :: String -> g String
text :: Text.Text -> g Text.Text
textLazy :: TL.Text -> g TL.Text
text t = Text.pack <$> string (Text.unpack t)
textLazy t = TL.pack <$> string (TL.unpack t)
deriving instance Gram_String RuleEBNF
instance Gram_String EBNF where
string s =
case List.break (\c -> Bool.not (Char.isPrint c) || c == '"') s of
(ps, "") -> raw ps
("", [c]) -> "" <$ char c
(ps, [c]) -> "" <$ raw ps <* char c
("", c:rs) -> "" <$ char c <* string rs
(ps, c:rs) -> "" <$ raw ps <* char c <* string rs
where
raw cs = ebnf_const $ Text.concat $ ["\"", Text.pack cs, "\""]
instance IsString (EBNF String) where
fromString = string