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)
  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 _ (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_Char 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