]> Git — Sourcephile - haskell/symantic.git/blob - symantic-lib/Language/Symantic/Lib/Char.hs
Add compileWithTyCtx.
[haskell/symantic.git] / symantic-lib / Language / Symantic / Lib / Char.hs
1 {-# LANGUAGE UndecidableInstances #-}
2 {-# OPTIONS_GHC -fno-warn-orphans #-}
3 -- | Symantic for 'Char'.
4 module Language.Symantic.Lib.Char where
5
6 import Control.Monad (liftM)
7 import Data.Proxy
8 import Data.Type.Equality ((:~:)(Refl))
9 import qualified Data.Char as Char
10 import qualified Data.Text as Text
11
12 import Language.Symantic.Parsing hiding (char)
13 import qualified Language.Symantic.Grammar as Gram
14 import Language.Symantic.Typing
15 import Language.Symantic.Compiling
16 import Language.Symantic.Interpreting
17 import Language.Symantic.Transforming
18 import Language.Symantic.Lib.Lambda
19 import Language.Symantic.Lib.MonoFunctor (TyFam_MonoElement(..))
20
21 -- * Class 'Sym_Char'
22 class Sym_Char term where
23 char :: Char -> term Char
24 char_toUpper :: term Char -> term Char
25 char_toLower :: term Char -> term Char
26
27 default char :: Trans t term => Char -> t term Char
28 default char_toUpper :: Trans t term => t term Char -> t term Char
29 default char_toLower :: Trans t term => t term Char -> t term Char
30
31 char = trans_lift . char
32 char_toUpper = trans_map1 char_toUpper
33 char_toLower = trans_map1 char_toLower
34
35 type instance Sym_of_Iface (Proxy Char) = Sym_Char
36 type instance TyConsts_of_Iface (Proxy Char) = Proxy Char ': TyConsts_imported_by (Proxy Char)
37 type instance TyConsts_imported_by (Proxy Char) =
38 [ Proxy Bounded
39 , Proxy Enum
40 , Proxy Eq
41 , Proxy Ord
42 , Proxy Show
43 ]
44
45 instance Sym_Char HostI where
46 char = HostI
47 char_toUpper = liftM Char.toUpper
48 char_toLower = liftM Char.toLower
49 instance Sym_Char TextI where
50 char a = TextI $ \_p _v ->
51 Text.pack (show a)
52 char_toUpper = textI1 "Char.toUpper"
53 char_toLower = textI1 "Char.toLower"
54 instance (Sym_Char r1, Sym_Char r2) => Sym_Char (DupI r1 r2) where
55 char x = char x `DupI` char x
56 char_toUpper = dupI1 @Sym_Char char_toUpper
57 char_toLower = dupI1 @Sym_Char char_toLower
58
59 instance
60 ( Read_TyNameR TyName cs rs
61 , Inj_TyConst cs Char
62 ) => Read_TyNameR TyName cs (Proxy Char ': rs) where
63 read_TyNameR _cs (TyName "Char") k = k (ty @Char)
64 read_TyNameR _rs raw k = read_TyNameR (Proxy @rs) raw k
65 instance Show_TyConst cs => Show_TyConst (Proxy Char ': cs) where
66 show_TyConst TyConstZ{} = "Char"
67 show_TyConst (TyConstS c) = show_TyConst c
68
69 instance Proj_TyFamC cs TyFam_MonoElement Char
70
71 instance -- Proj_TyConC
72 ( Proj_TyConst cs Char
73 , Proj_TyConsts cs (TyConsts_imported_by (Proxy Char))
74 ) => Proj_TyConC cs (Proxy Char) where
75 proj_TyConC _ (TyConst q :$ TyConst c)
76 | Just Refl <- eq_skind (kind_of_TyConst c) SKiType
77 , Just Refl <- proj_TyConst c (Proxy @Char)
78 = case () of
79 _ | Just Refl <- proj_TyConst q (Proxy @Bounded) -> Just TyCon
80 | Just Refl <- proj_TyConst q (Proxy @Enum) -> Just TyCon
81 | Just Refl <- proj_TyConst q (Proxy @Eq) -> Just TyCon
82 | Just Refl <- proj_TyConst q (Proxy @Ord) -> Just TyCon
83 | Just Refl <- proj_TyConst q (Proxy @Show) -> Just TyCon
84 _ -> Nothing
85 proj_TyConC _c _q = Nothing
86 data instance TokenT meta (ts::[*]) (Proxy Char)
87 = Token_Term_Char Char
88 | Token_Term_Char_toUpper
89 | Token_Term_Char_toLower
90 deriving instance Eq_Token meta ts => Eq (TokenT meta ts (Proxy Char))
91 deriving instance Show_Token meta ts => Show (TokenT meta ts (Proxy Char))
92
93 instance -- CompileI
94 ( Inj_TyConst cs Char
95 , Inj_TyConst cs (->)
96 ) => CompileI cs is (Proxy Char) where
97 compileI tok _ctx k =
98 case tok of
99 Token_Term_Char c -> k (ty @Char) $ Term $ \_c -> char c
100 Token_Term_Char_toUpper -> from_op char_toUpper
101 Token_Term_Char_toLower -> from_op char_toLower
102 where
103 from_op (op::forall term. Sym_Char term => term Char -> term Char) =
104 k (ty @Char ~> ty @Char) $ Term $ \_c -> lam op
105 instance -- TokenizeT
106 Inj_Token meta ts Char =>
107 TokenizeT meta ts (Proxy Char) where
108 tokenizeT _t = mempty
109 { tokenizers_infix = tokenizeTMod [Mod_Name "Char"]
110 [ tokenize0 "toLower" infixN5 Token_Term_Char_toLower
111 , tokenize0 "toUpper" infixN5 Token_Term_Char_toUpper
112 ]
113 }
114 instance -- Gram_Term_AtomsT
115 ( Alt g
116 , Gram_Rule g
117 , Gram_Lexer g
118 , Gram_Meta meta g
119 , Inj_Token meta ts Char
120 ) => Gram_Term_AtomsT meta ts (Proxy Char) g where
121 gs_term_atomsT _t =
122 [ rule "term_char" $
123 lexeme $ metaG $
124 (\c meta -> ProTok $ inj_EToken meta $ Token_Term_Char c)
125 <$> Gram.between tickG tickG (
126 Gram.cf_of_Terminal (Gram.any `Gram.but` tickG) Gram.<+>
127 '\'' <$ Gram.string "\\'"
128 )
129 ]
130 where
131 tickG :: Gram_Terminal g' => g' Char
132 tickG = Gram.char '\''