symantic-lib/Language/Symantic/Lib/Semigroup.hs

   1 {-# LANGUAGE UndecidableInstances #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3 -- | Symantic for 'Semigroup'.
   4 module Language.Symantic.Lib.Semigroup where
   5
   6 import Control.Monad
   7 import Data.Semigroup (Semigroup)
   8 import qualified Data.Semigroup as Semigroup
   9 import Data.Monoid (mempty)
  10 import Data.Proxy
  11
  12 import Language.Symantic.Parsing
  13 import Language.Symantic.Typing
  14 import Language.Symantic.Compiling
  15 import Language.Symantic.Interpreting
  16 import Language.Symantic.Transforming
  17 import Language.Symantic.Lib.Lambda
  18
  19 -- * Class 'Sym_Semigroup'
  20 class Sym_Semigroup term where
  21         (<>)   :: Semigroup a => term a -> term a -> term a
  22         stimes :: (Semigroup a, Integral b) => term b -> term a -> term a
  23         -- sconcat :: NonEmpty a -> a
  24         default (<>)   :: (Trans t term, Semigroup a) => t term a -> t term a -> t term a
  25         default stimes :: (Trans t term, Semigroup a, Integral b) => t term b -> t term a -> t term a
  26         (<>)   = trans_map2 (<>)
  27         stimes = trans_map2 stimes
  28
  29 type instance Sym_of_Iface (Proxy Semigroup) = Sym_Semigroup
  30 type instance TyConsts_of_Iface (Proxy Semigroup) = Proxy Semigroup ': TyConsts_imported_by Semigroup
  31 type instance TyConsts_imported_by Semigroup = '[Proxy Integral]
  32
  33 instance Sym_Semigroup HostI where
  34         (<>)   = liftM2 (Semigroup.<>)
  35         stimes = liftM2 Semigroup.stimes
  36 instance Sym_Semigroup TextI where
  37         (<>)   = textI_infix "-" (infixR 6)
  38         stimes = textI2 "stimes"
  39 instance (Sym_Semigroup r1, Sym_Semigroup r2) => Sym_Semigroup (DupI r1 r2) where
  40         (<>)   = dupI2 @Sym_Semigroup (<>)
  41         stimes = dupI2 @Sym_Semigroup stimes
  42
  43 instance
  44  ( Read_TyNameR TyName cs rs
  45  , Inj_TyConst cs Semigroup
  46  ) => Read_TyNameR TyName cs (Proxy Semigroup ': rs) where
  47         read_TyNameR _cs (TyName "Semigroup") k = k (ty @Semigroup)
  48         read_TyNameR _rs raw k = read_TyNameR (Proxy @rs) raw k
  49 instance Show_TyConst cs => Show_TyConst (Proxy Semigroup ': cs) where
  50         show_TyConst TyConstZ{} = "Semigroup"
  51         show_TyConst (TyConstS c) = show_TyConst c
  52
  53 instance Proj_TyConC cs (Proxy Semigroup)
  54 data instance TokenT meta (ts::[*]) (Proxy Semigroup)
  55  = Token_Term_Semigroup_sappend (EToken meta ts)
  56  | Token_Term_Semigroup_stimes  (EToken meta ts) (EToken meta ts)
  57 deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Semigroup))
  58 deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Semigroup))
  59 instance -- CompileI
  60  ( Read_TyName TyName (TyConsts_of_Ifaces is)
  61  , Inj_TyConst (TyConsts_of_Ifaces is) Semigroup
  62  , Inj_TyConst (TyConsts_of_Ifaces is) (->)
  63  , Inj_TyConst (TyConsts_of_Ifaces is) Integral
  64  , Proj_TyCon  (TyConsts_of_Ifaces is)
  65  , Compile is
  66  ) => CompileI is (Proxy Semigroup) where
  67         compileI tok ctx k =
  68                 case tok of
  69                  Token_Term_Semigroup_sappend tok_a ->
  70                         -- (<>) :: Semigroup a => a -> a -> a
  71                         compileO tok_a ctx $ \ty_a (TermO x) ->
  72                         check_TyCon (At (Just tok_a) (ty @Semigroup :$ ty_a)) $ \TyCon ->
  73                         k (ty_a ~> ty_a) $ TermO $
  74                          \c -> lam $ \y -> (<>) (x c) y
  75                  Token_Term_Semigroup_stimes tok_b tok_a ->
  76                         -- stimes :: (Semigroup a, Integral b) => b -> a -> a
  77                         compileO tok_b ctx $ \ty_b (TermO b) ->
  78                         compileO tok_a ctx $ \ty_a (TermO a) ->
  79                         check_TyCon (At (Just tok_a) (ty @Integral :$ ty_b)) $ \TyCon ->
  80                         check_TyCon (At (Just tok_a) (ty @Semigroup :$ ty_a)) $ \TyCon ->
  81                         k ty_a $ TermO $
  82                          \c -> stimes (b c) (a c)
  83 instance -- TokenizeT
  84  Inj_Token meta ts Semigroup =>
  85  TokenizeT meta ts (Proxy Semigroup) where
  86         tokenizeT _t = mempty
  87          { tokenizers_infix = tokenizeTMod []
  88                  [ tokenize1 "<>" (infixR 6)  Token_Term_Semigroup_sappend
  89                  , tokenize2 "stimes" infixN5 Token_Term_Semigroup_stimes
  90                  ]
  91          }
  92 instance Gram_Term_AtomsT meta ts (Proxy Semigroup) g