]> Git — Sourcephile - haskell/symantic.git/blob - Language/Symantic/Compiling/Char.hs
Add tests for Compiling.
[haskell/symantic.git] / Language / Symantic / Compiling / Char.hs
1 {-# LANGUAGE DataKinds #-}
2 {-# LANGUAGE DefaultSignatures #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# LANGUAGE FlexibleInstances #-}
5 {-# LANGUAGE MultiParamTypeClasses #-}
6 {-# LANGUAGE OverloadedStrings #-}
7 {-# LANGUAGE Rank2Types #-}
8 {-# LANGUAGE ScopedTypeVariables #-}
9 {-# LANGUAGE TypeFamilies #-}
10 {-# LANGUAGE TypeOperators #-}
11 {-# LANGUAGE UndecidableInstances #-}
12 {-# OPTIONS_GHC -fno-warn-orphans #-}
13 -- | Symantic for 'Char'.
14 module Language.Symantic.Compiling.Char where
15
16 import Control.Monad (liftM)
17 import qualified Data.Char as Char
18 import qualified Data.Function as Fun
19 import Data.Proxy
20 import Data.String (IsString)
21 import Data.Text (Text)
22 import qualified Data.Text as Text
23 import Data.Type.Equality ((:~:)(Refl))
24
25 import Language.Symantic.Typing
26 import Language.Symantic.Compiling.Term
27 import Language.Symantic.Interpreting
28 import Language.Symantic.Transforming.Trans
29
30 -- * Class 'Sym_Char'
31 class Sym_Char term where
32 char :: Char -> term Char
33 char_toUpper :: term Char -> term Char
34
35 default char :: Trans t term => Char -> t term Char
36 default char_toUpper :: Trans t term => t term Char -> t term Char
37
38 char = trans_lift . char
39 char_toUpper = trans_map1 char_toUpper
40
41 type instance Sym_of_Iface (Proxy Char) = Sym_Char
42 type instance Consts_of_Iface (Proxy Char) = Proxy Char ': Consts_imported_by Char
43 type instance Consts_imported_by Char =
44 [ Proxy Bounded
45 , Proxy Enum
46 , Proxy Eq
47 , Proxy Ord
48 ]
49
50 instance Sym_Char HostI where
51 char = HostI
52 char_toUpper = liftM Char.toUpper
53 instance Sym_Char TextI where
54 char a = TextI $ \_p _v ->
55 Text.pack (show a)
56 char_toUpper = textI_app1 "char_toUpper"
57 instance (Sym_Char r1, Sym_Char r2) => Sym_Char (DupI r1 r2) where
58 char x = char x `DupI` char x
59 char_toUpper = dupI1 sym_Char char_toUpper
60
61 instance Const_from Text cs => Const_from Text (Proxy Char ': cs) where
62 const_from "Char" k = k (ConstZ kind)
63 const_from s k = const_from s $ k . ConstS
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::Proxy Char)
75 = Just $ case () of
76 _ | Just Refl <- proj_const q (Proxy::Proxy Bounded) -> Just Con
77 | Just Refl <- proj_const q (Proxy::Proxy Enum) -> Just Con
78 | Just Refl <- proj_const q (Proxy::Proxy Eq) -> Just Con
79 | Just Refl <- proj_const q (Proxy::Proxy Ord) -> Just Con
80 _ -> Nothing
81 proj_conC _c _q = Nothing
82 instance -- Term_fromI
83 ( AST ast
84 , Lexem ast ~ LamVarName
85 , Inj_Const (Consts_of_Ifaces is) Char
86 , Inj_Const (Consts_of_Ifaces is) (->)
87 , Show_Const (Consts_of_Ifaces is)
88 ) => Term_fromI is (Proxy Char) ast where
89 term_fromI ast _ctx k =
90 case ast_lexem ast of
91 "char" -> char_from
92 "char_toUpper" -> char_toUpper_from
93 _ -> Left $ Error_Term_unsupported
94 where
95 char_from =
96 let ty = tyChar in
97 from_ast1 ast $ \ast_lit as ->
98 from_lex (Text.pack $ show_type ty) ast_lit $ \(lit::Char) ->
99 k as ty $ TermLC $ Fun.const $ char lit
100 char_toUpper_from =
101 from_ast0 ast $ \_ as ->
102 k as (tyChar ~> tyChar) $ TermLC $
103 Fun.const $ lam char_toUpper
104
105 -- | The 'Char' 'Type'
106 tyChar :: Inj_Const cs Char => Type cs Char
107 tyChar = TyConst inj_const
108
109 sym_Char :: Proxy Sym_Char
110 sym_Char = Proxy
111
112 syChar :: IsString a => Syntax a
113 syChar = Syntax "Char" []