]> Git — Sourcephile - haskell/symantic.git/blob - symantic-lib/Language/Symantic/Lib/Char.hs
Add README.md to extra-doc-files.
[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 qualified Data.Char as Char
7 import qualified Data.Text as Text
8
9 import Language.Symantic.Grammar hiding (char, any)
10 import qualified Language.Symantic.Grammar as G
11 import Language.Symantic
12 import Language.Symantic.Lib.List (tyList)
13
14 -- * Class 'Sym_Char'
15 type instance Sym Char = Sym_Char
16 class Sym_Char term where
17 char :: Char -> term Char
18 char_toUpper :: term Char -> term Char
19 char_toLower :: term Char -> term Char
20
21 default char :: Sym_Char (UnT term) => Trans term => Char -> term Char
22 default char_toUpper :: Sym_Char (UnT term) => Trans term => term Char -> term Char
23 default char_toLower :: Sym_Char (UnT term) => Trans term => term Char -> term Char
24
25 char = trans . char
26 char_toUpper = trans1 char_toUpper
27 char_toLower = trans1 char_toLower
28
29 -- Interpreting
30 instance Sym_Char Eval where
31 char = Eval
32 char_toUpper = eval1 Char.toUpper
33 char_toLower = eval1 Char.toLower
34 instance Sym_Char View where
35 char a = View $ \_p _v ->
36 Text.pack (show a)
37 char_toUpper = view1 "Char.toUpper"
38 char_toLower = view1 "Char.toLower"
39 instance (Sym_Char r1, Sym_Char r2) => Sym_Char (Dup r1 r2) where
40 char x = char x `Dup` char x
41 char_toUpper = dup1 @Sym_Char char_toUpper
42 char_toLower = dup1 @Sym_Char char_toLower
43
44 -- Transforming
45 instance (Sym_Char term, Sym_Lambda term) => Sym_Char (BetaT term)
46
47 -- Typing
48 instance NameTyOf Char where
49 nameTyOf _c = ["Char"] `Mod` "Char"
50 instance ClassInstancesFor Char where
51 proveConstraintFor _ (TyApp _ (TyConst _ _ q) z)
52 | Just HRefl <- proj_ConstKiTy @_ @Char z
53 = case () of
54 _ | Just Refl <- proj_Const @Bounded q -> Just Dict
55 | Just Refl <- proj_Const @Enum q -> Just Dict
56 | Just Refl <- proj_Const @Eq q -> Just Dict
57 | Just Refl <- proj_Const @Ord q -> Just Dict
58 | Just Refl <- proj_Const @Show q -> Just Dict
59 _ -> Nothing
60 proveConstraintFor _c _q = Nothing
61 instance TypeInstancesFor Char
62
63 -- Compiling
64 instance
65 ( Gram_Source src g
66 , Gram_Alt g
67 , Gram_Rule g
68 , Gram_Comment g
69 , SymInj ss Char
70 ) => Gram_Term_AtomsFor src ss g Char where
71 g_term_atomsFor =
72 [ rule "teChar" $
73 lexeme $ source $
74 (\c src -> BinTree0 $ Token_Term $ TermAVT $ (`setSource` src) $ teChar c)
75 <$> between tickG tickG (
76 cfOf (G.any `but` tickG) <+>
77 '\'' <$ string "\\'"
78 )
79 ]
80 where
81 tickG :: Gram_Terminal g' => g' Char
82 tickG = G.char '\''
83 instance (Source src, SymInj ss Char) => ModuleFor src ss Char where
84 moduleFor = ["Char"] `moduleWhere`
85 [ "toLower" := teChar_toLower
86 , "toUpper" := teChar_toUpper
87 ]
88
89 -- ** 'Type's
90 tyChar :: Source src => LenInj vs => Type src vs Char
91 tyChar = tyConst @(K Char) @Char
92
93 tyString :: Source src => LenInj vs => Type src vs String
94 tyString = tyList tyChar
95
96 -- ** 'Term's
97 teChar :: Source src => SymInj ss Char => Char -> Term src ss ts '[] (() #> Char)
98 teChar b = Term noConstraint tyChar $ teSym @Char $ char b
99
100 teChar_toUpper, teChar_toLower :: TermDef Char '[] (() #> (Char -> Char))
101 teChar_toUpper = Term noConstraint (tyChar ~> tyChar) $ teSym @Char $ lam1 char_toUpper
102 teChar_toLower = Term noConstraint (tyChar ~> tyChar) $ teSym @Char $ lam1 char_toLower