]> Git — Sourcephile - haskell/symantic.git/blob - Language/Symantic/Lib/Char.hs
Fix Lib.Ord : Ordering.
[haskell/symantic.git] / 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 qualified Data.Char as Char
8 import Data.Proxy
9 import qualified Data.Text as Text
10 import Data.Type.Equality ((:~:)(Refl))
11
12 import Language.Symantic.Parsing hiding (char)
13 import qualified Language.Symantic.Parsing.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
20 -- * Class 'Sym_Char'
21 class Sym_Char term where
22 char :: Char -> term Char
23 char_toUpper :: term Char -> term Char
24 char_toLower :: term Char -> term Char
25
26 default char :: Trans t term => Char -> t term Char
27 default char_toUpper :: Trans t term => t term Char -> t term Char
28 default char_toLower :: Trans t term => t term Char -> t term Char
29
30 char = trans_lift . char
31 char_toUpper = trans_map1 char_toUpper
32 char_toLower = trans_map1 char_toLower
33
34 type instance Sym_of_Iface (Proxy Char) = Sym_Char
35 type instance Consts_of_Iface (Proxy Char) = Proxy Char ': Consts_imported_by Char
36 type instance Consts_imported_by Char =
37 [ Proxy Bounded
38 , Proxy Enum
39 , Proxy Eq
40 , Proxy Ord
41 , Proxy Show
42 ]
43
44 instance Sym_Char HostI where
45 char = HostI
46 char_toUpper = liftM Char.toUpper
47 char_toLower = liftM Char.toLower
48 instance Sym_Char TextI where
49 char a = TextI $ \_p _v ->
50 Text.pack (show a)
51 char_toUpper = textI1 "Char.toUpper"
52 char_toLower = textI1 "Char.toLower"
53 instance (Sym_Char r1, Sym_Char r2) => Sym_Char (DupI r1 r2) where
54 char x = char x `DupI` char x
55 char_toUpper = dupI1 (Proxy @Sym_Char) char_toUpper
56 char_toLower = dupI1 (Proxy @Sym_Char) char_toLower
57
58 instance
59 ( Read_TypeNameR Type_Name cs rs
60 , Inj_Const cs Char
61 ) => Read_TypeNameR Type_Name cs (Proxy Char ': rs) where
62 read_typenameR _cs (Type_Name "Char") k = k (ty @Char)
63 read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k
64 instance Show_Const cs => Show_Const (Proxy Char ': cs) where
65 show_const ConstZ{} = "Char"
66 show_const (ConstS c) = show_const c
67
68 instance -- Proj_ConC
69 ( Proj_Const cs Char
70 , Proj_Consts cs (Consts_imported_by Char)
71 ) => Proj_ConC cs (Proxy Char) where
72 proj_conC _ (TyConst q :$ TyConst c)
73 | Just Refl <- eq_skind (kind_of_const c) SKiType
74 , Just Refl <- proj_const c (Proxy @Char)
75 = case () of
76 _ | Just Refl <- proj_const q (Proxy @Bounded) -> Just Con
77 | Just Refl <- proj_const q (Proxy @Enum) -> Just Con
78 | Just Refl <- proj_const q (Proxy @Eq) -> Just Con
79 | Just Refl <- proj_const q (Proxy @Ord) -> Just Con
80 | Just Refl <- proj_const q (Proxy @Show) -> Just Con
81 _ -> Nothing
82 proj_conC _c _q = Nothing
83 data instance TokenT meta (ts::[*]) (Proxy Char)
84 = Token_Term_Char Char
85 | Token_Term_Char_toUpper
86 | Token_Term_Char_toLower
87 deriving instance Eq_Token meta ts => Eq (TokenT meta ts (Proxy Char))
88 deriving instance Show_Token meta ts => Show (TokenT meta ts (Proxy Char))
89 instance -- CompileI
90 ( Inj_Const (Consts_of_Ifaces is) Char
91 , Inj_Const (Consts_of_Ifaces is) (->)
92 ) => CompileI is (Proxy Char) where
93 compileI tok _ctx k =
94 case tok of
95 Token_Term_Char c -> k (ty @Char) $ TermO $ \_c -> char c
96 Token_Term_Char_toUpper -> from_op char_toUpper
97 Token_Term_Char_toLower -> from_op char_toLower
98 where
99 from_op (op::forall term. Sym_Char term => term Char -> term Char) =
100 k (ty @Char ~> ty @Char) $ TermO $ \_c -> lam op
101 instance -- TokenizeT
102 Inj_Token meta ts Char =>
103 TokenizeT meta ts (Proxy Char) where
104 tokenizeT _t = mempty
105 { tokenizers_infix = tokenizeTMod [Mod_Name "Char"]
106 [ tokenize0 "toLower" infixN5 Token_Term_Char_toLower
107 , tokenize0 "toUpper" infixN5 Token_Term_Char_toUpper
108 ]
109 }
110 instance -- Gram_Term_AtomsT
111 ( Alt g
112 , Gram_Rule g
113 , Gram_Lexer g
114 , Gram_Meta meta g
115 , Inj_Token meta ts Char
116 ) => Gram_Term_AtomsT meta ts (Proxy Char) g where
117 term_atomsT _t =
118 [ rule "term_char" $
119 lexeme $ metaG $
120 (\c meta -> ProTok $ inj_etoken meta $ Token_Term_Char c)
121 <$> Gram.between tickG tickG (
122 Gram.cf_of_term (Gram.any `Gram.but` tickG) Gram.<+>
123 '\'' <$ Gram.string "\\'"
124 )
125 ]
126 where
127 tickG :: Gram_Terminal g' => g' Char
128 tickG = Gram.char '\''