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