]> Git — Sourcephile - haskell/symantic.git/blob - Language/Symantic/Compiling/Char.hs
Renaming textI_app* to textI*.
[haskell/symantic.git] / Language / Symantic / Compiling / Char.hs
1 {-# LANGUAGE UndecidableInstances #-}
2 {-# OPTIONS_GHC -fno-warn-orphans #-}
3 -- | Symantic for 'Char'.
4 module Language.Symantic.Compiling.Char where
5
6 import Control.Monad (liftM)
7 import qualified Data.Char as Char
8 import Data.Proxy
9 import Data.Text (Text)
10 import qualified Data.Text as Text
11 import Data.Type.Equality ((:~:)(Refl))
12
13 import Language.Symantic.Parsing
14 import Language.Symantic.Typing
15 import Language.Symantic.Compiling.Term
16 import Language.Symantic.Interpreting
17 import Language.Symantic.Transforming.Trans
18
19 -- * Class 'Sym_Char'
20 class Sym_Char term where
21 char :: Char -> term Char
22 char_toUpper :: term Char -> term Char
23 char_toLower :: term Char -> term Char
24
25 default char :: Trans t term => Char -> t term Char
26 default char_toUpper :: Trans t term => t term Char -> t term Char
27 default char_toLower :: Trans t term => t term Char -> t term Char
28
29 char = trans_lift . char
30 char_toUpper = trans_map1 char_toUpper
31 char_toLower = trans_map1 char_toLower
32
33 type instance Sym_of_Iface (Proxy Char) = Sym_Char
34 type instance Consts_of_Iface (Proxy Char) = Proxy Char ': Consts_imported_by Char
35 type instance Consts_imported_by Char =
36 [ Proxy Bounded
37 , Proxy Enum
38 , Proxy Eq
39 , Proxy Ord
40 , Proxy Show
41 ]
42
43 instance Sym_Char HostI where
44 char = HostI
45 char_toUpper = liftM Char.toUpper
46 char_toLower = liftM Char.toLower
47 instance Sym_Char TextI where
48 char a = TextI $ \_p _v ->
49 Text.pack (show a)
50 char_toUpper = textI1 "Char.toUpper"
51 char_toLower = textI1 "Char.toLower"
52 instance (Sym_Char r1, Sym_Char r2) => Sym_Char (DupI r1 r2) where
53 char x = char x `DupI` char x
54 char_toUpper = dupI1 (Proxy @Sym_Char) char_toUpper
55 char_toLower = dupI1 (Proxy @Sym_Char) char_toLower
56
57 instance Const_from Text cs => Const_from Text (Proxy Char ': cs) where
58 const_from "Char" k = k (ConstZ kind)
59 const_from s k = const_from s $ k . ConstS
60 instance Show_Const cs => Show_Const (Proxy Char ': cs) where
61 show_const ConstZ{} = "Char"
62 show_const (ConstS c) = show_const c
63
64 instance -- Proj_ConC
65 ( Proj_Const cs Char
66 , Proj_Consts cs (Consts_imported_by Char)
67 ) => Proj_ConC cs (Proxy Char) where
68 proj_conC _ (TyConst q :$ TyConst c)
69 | Just Refl <- eq_skind (kind_of_const c) SKiType
70 , Just Refl <- proj_const c (Proxy::Proxy Char)
71 = case () of
72 _ | Just Refl <- proj_const q (Proxy::Proxy Bounded) -> Just Con
73 | Just Refl <- proj_const q (Proxy::Proxy Enum) -> Just Con
74 | Just Refl <- proj_const q (Proxy::Proxy Eq) -> Just Con
75 | Just Refl <- proj_const q (Proxy::Proxy Ord) -> Just Con
76 | Just Refl <- proj_const q (Proxy::Proxy Show) -> Just Con
77 _ -> Nothing
78 proj_conC _c _q = Nothing
79 data instance TokenT meta (ts::[*]) (Proxy Char)
80 = Token_Term_Char Char
81 | Token_Term_Char_toUpper
82 | Token_Term_Char_toLower
83 deriving instance Eq_Token meta ts => Eq (TokenT meta ts (Proxy Char))
84 deriving instance Show_Token meta ts => Show (TokenT meta ts (Proxy Char))
85 instance -- CompileI
86 ( Inj_Const (Consts_of_Ifaces is) Char
87 , Inj_Const (Consts_of_Ifaces is) (->)
88 ) => CompileI is (Proxy Char) where
89 compileI tok _ctx k =
90 case tok of
91 Token_Term_Char c -> k (ty @Char) $ TermO $ \_c -> char c
92 Token_Term_Char_toUpper -> from_op char_toUpper
93 Token_Term_Char_toLower -> from_op char_toLower
94 where
95 from_op (op::forall term. Sym_Char term => term Char -> term Char) =
96 k (ty @Char ~> ty @Char) $ TermO $ \_c -> lam op