]> Git — Sourcephile - haskell/symantic.git/blob - symantic-grammar/Language/Symantic/Grammar/Terminal.hs
Support GHC-8.4.3.
[haskell/symantic.git] / 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 -> parenInfix 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