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.Monoid (mempty)
   8 import Data.Proxy
   9 import Data.Semigroup (Semigroup)
  10 import qualified Data.Semigroup as Semigroup
  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 (Proxy Semigroup)
  31 type instance TyConsts_imported_by (Proxy Semigroup) =
  32  '[ Proxy Integral
  33  ]
  34
  35 instance Sym_Semigroup HostI where
  36         (<>)   = liftM2 (Semigroup.<>)
  37         stimes = liftM2 Semigroup.stimes
  38 instance Sym_Semigroup TextI where
  39         (<>)   = textI_infix "-" (infixR 6)
  40         stimes = textI2 "stimes"
  41 instance (Sym_Semigroup r1, Sym_Semigroup r2) => Sym_Semigroup (DupI r1 r2) where
  42         (<>)   = dupI2 @Sym_Semigroup (<>)
  43         stimes = dupI2 @Sym_Semigroup stimes
  44
  45 instance
  46  ( Read_TyNameR TyName cs rs
  47  , Inj_TyConst cs Semigroup
  48  ) => Read_TyNameR TyName cs (Proxy Semigroup ': rs) where
  49         read_TyNameR _cs (TyName "Semigroup") k = k (ty @Semigroup)
  50         read_TyNameR _rs raw k = read_TyNameR (Proxy @rs) raw k
  51 instance Show_TyConst cs => Show_TyConst (Proxy Semigroup ': cs) where
  52         show_TyConst TyConstZ{} = "Semigroup"
  53         show_TyConst (TyConstS c) = show_TyConst c
  54
  55 instance Proj_TyConC cs (Proxy Semigroup)
  56 data instance TokenT meta (ts::[*]) (Proxy Semigroup)
  57  = Token_Term_Semigroup_sappend (EToken meta ts)
  58  | Token_Term_Semigroup_stimes  (EToken meta ts) (EToken meta ts)
  59 deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Semigroup))
  60 deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Semigroup))
  61
  62 instance -- CompileI
  63  ( Read_TyName TyName cs
  64  , Inj_TyConst cs Semigroup
  65  , Inj_TyConst cs (->)
  66  , Inj_TyConsts cs (TyConsts_imported_by (Proxy Semigroup))
  67  , Proj_TyCon cs
  68  , Compile cs is
  69  ) => CompileI cs is (Proxy Semigroup) where
  70         compileI tok ctx k =
  71                 case tok of
  72                  Token_Term_Semigroup_sappend tok_a ->
  73                         -- (<>) :: Semigroup a => a -> a -> a
  74                         compileO tok_a ctx $ \ty_a (TermO x) ->
  75                         check_TyCon (At (Just tok_a) (ty @Semigroup :$ ty_a)) $ \TyCon ->
  76                         k (ty_a ~> ty_a) $ TermO $
  77                          \c -> lam $ \y -> (<>) (x c) y
  78                  Token_Term_Semigroup_stimes tok_b tok_a ->
  79                         -- stimes :: (Semigroup a, Integral b) => b -> a -> a
  80                         compileO tok_b ctx $ \ty_b (TermO b) ->
  81                         compileO tok_a ctx $ \ty_a (TermO a) ->
  82                         check_TyCon (At (Just tok_a) (ty @Integral :$ ty_b)) $ \TyCon ->
  83                         check_TyCon (At (Just tok_a) (ty @Semigroup :$ ty_a)) $ \TyCon ->
  84                         k ty_a $ TermO $
  85                          \c -> stimes (b c) (a c)
  86 instance -- TokenizeT
  87  Inj_Token meta ts Semigroup =>
  88  TokenizeT meta ts (Proxy Semigroup) where
  89         tokenizeT _t = mempty
  90          { tokenizers_infix = tokenizeTMod []
  91                  [ tokenize1 "<>" (infixR 6)  Token_Term_Semigroup_sappend
  92                  , tokenize2 "stimes" infixN5 Token_Term_Semigroup_stimes
  93                  ]
  94          }
  95 instance Gram_Term_AtomsT meta ts (Proxy Semigroup) g