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
  58  ( Read_TypeNameR Text cs rs
  59  , Inj_Const cs Char
  60  ) => Read_TypeNameR Text cs (Proxy Char ': rs) where
  61         read_typenameR _cs "Char" k = k (ty @Char)
  62         read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k
  63 instance Show_Const cs => Show_Const (Proxy Char ': cs) where
  64         show_const ConstZ{} = "Char"
  65         show_const (ConstS c) = show_const c
  66
  67 instance -- Proj_ConC
  68  ( Proj_Const cs Char
  69  , Proj_Consts cs (Consts_imported_by Char)
  70  ) => Proj_ConC cs (Proxy Char) where
  71         proj_conC _ (TyConst q :$ TyConst c)
  72          | Just Refl <- eq_skind (kind_of_const c) SKiType
  73          , Just Refl <- proj_const c (Proxy::Proxy Char)
  74          = case () of
  75                  _ | Just Refl <- proj_const q (Proxy::Proxy Bounded) -> Just Con
  76                    | Just Refl <- proj_const q (Proxy::Proxy Enum)    -> Just Con
  77                    | Just Refl <- proj_const q (Proxy::Proxy Eq)      -> Just Con
  78                    | Just Refl <- proj_const q (Proxy::Proxy Ord)     -> Just Con
  79                    | Just Refl <- proj_const q (Proxy::Proxy Show)    -> Just Con
  80                  _ -> Nothing
  81         proj_conC _c _q = Nothing
  82 data instance TokenT meta (ts::[*]) (Proxy Char)
  83  = Token_Term_Char Char
  84  | Token_Term_Char_toUpper
  85  | Token_Term_Char_toLower
  86 deriving instance Eq_Token meta ts => Eq (TokenT meta ts (Proxy Char))
  87 deriving instance Show_Token meta ts => Show (TokenT meta ts (Proxy Char))
  88 instance -- CompileI
  89  ( Inj_Const (Consts_of_Ifaces is) Char
  90  , Inj_Const (Consts_of_Ifaces is) (->)
  91  ) => CompileI is (Proxy Char) where
  92         compileI tok _ctx k =
  93                 case tok of
  94                  Token_Term_Char c -> k (ty @Char) $ TermO $ \_c -> char c
  95                  Token_Term_Char_toUpper -> from_op char_toUpper
  96                  Token_Term_Char_toLower -> from_op char_toLower
  97                 where
  98                 from_op (op::forall term. Sym_Char term => term Char -> term Char) =
  99                         k (ty @Char ~> ty @Char) $ TermO $ \_c -> lam op