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