-- | Symantic for 'Semigroup'.
module Language.Symantic.Lib.Semigroup where
-import Control.Monad
import Data.Semigroup (Semigroup)
import qualified Data.Semigroup as Semigroup
-import Data.Monoid (mempty)
-import Data.Proxy
-import Language.Symantic.Parsing
-import Language.Symantic.Typing
-import Language.Symantic.Compiling
-import Language.Symantic.Interpreting
-import Language.Symantic.Transforming
-import Language.Symantic.Lib.Lambda
+import Language.Symantic
+import Language.Symantic.Lib.Function (a0, b1)
+import Language.Symantic.Lib.Integral (tyIntegral)
-- * Class 'Sym_Semigroup'
+type instance Sym Semigroup = Sym_Semigroup
class Sym_Semigroup term where
(<>) :: Semigroup a => term a -> term a -> term a
stimes :: (Semigroup a, Integral b) => term b -> term a -> term a
-- sconcat :: NonEmpty a -> a
- default (<>) :: (Trans t term, Semigroup a) => t term a -> t term a -> t term a
- default stimes :: (Trans t term, Semigroup a, Integral b) => t term b -> t term a -> t term a
- (<>) = trans_map2 (<>)
- stimes = trans_map2 stimes
+ default (<>) :: Sym_Semigroup (UnT term) => Trans term => Semigroup a => term a -> term a -> term a
+ default stimes :: Sym_Semigroup (UnT term) => Trans term => Semigroup a => Integral b => term b -> term a -> term a
+ (<>) = trans2 (<>)
+ stimes = trans2 stimes
-type instance Sym_of_Iface (Proxy Semigroup) = Sym_Semigroup
-type instance TyConsts_of_Iface (Proxy Semigroup) = Proxy Semigroup ': TyConsts_imported_by Semigroup
-type instance TyConsts_imported_by Semigroup = '[Proxy Integral]
+-- Interpreting
+instance Sym_Semigroup Eval where
+ (<>) = eval2 (Semigroup.<>)
+ stimes = eval2 Semigroup.stimes
+instance Sym_Semigroup View where
+ (<>) = viewInfix "-" (infixR 6)
+ stimes = view2 "stimes"
+instance (Sym_Semigroup r1, Sym_Semigroup r2) => Sym_Semigroup (Dup r1 r2) where
+ (<>) = dup2 @Sym_Semigroup (<>)
+ stimes = dup2 @Sym_Semigroup stimes
-instance Sym_Semigroup HostI where
- (<>) = liftM2 (Semigroup.<>)
- stimes = liftM2 Semigroup.stimes
-instance Sym_Semigroup TextI where
- (<>) = textI_infix "-" (infixR 6)
- stimes = textI2 "stimes"
-instance (Sym_Semigroup r1, Sym_Semigroup r2) => Sym_Semigroup (DupI r1 r2) where
- (<>) = dupI2 @Sym_Semigroup (<>)
- stimes = dupI2 @Sym_Semigroup stimes
+-- Transforming
+instance (Sym_Semigroup term, Sym_Lambda term) => Sym_Semigroup (BetaT term)
-instance
- ( Read_TyNameR TyName cs rs
- , Inj_TyConst cs Semigroup
- ) => Read_TyNameR TyName cs (Proxy Semigroup ': rs) where
- read_TyNameR _cs (TyName "Semigroup") k = k (ty @Semigroup)
- read_TyNameR _rs raw k = read_TyNameR (Proxy @rs) raw k
-instance Show_TyConst cs => Show_TyConst (Proxy Semigroup ': cs) where
- show_TyConst TyConstZ{} = "Semigroup"
- show_TyConst (TyConstS c) = show_TyConst c
+-- Typing
+instance NameTyOf Semigroup where
+ nameTyOf _c = ["Semigroup"] `Mod` "Semigroup"
+instance FixityOf Semigroup
+instance ClassInstancesFor Semigroup
+instance TypeInstancesFor Semigroup
-instance Proj_TyConC cs (Proxy Semigroup)
-data instance TokenT meta (ts::[*]) (Proxy Semigroup)
- = Token_Term_Semigroup_sappend (EToken meta ts)
- | Token_Term_Semigroup_stimes (EToken meta ts) (EToken meta ts)
-deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Semigroup))
-deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Semigroup))
-instance -- CompileI
- ( Read_TyName TyName (TyConsts_of_Ifaces is)
- , Inj_TyConst (TyConsts_of_Ifaces is) Semigroup
- , Inj_TyConst (TyConsts_of_Ifaces is) (->)
- , Inj_TyConst (TyConsts_of_Ifaces is) Integral
- , Proj_TyCon (TyConsts_of_Ifaces is)
- , Compile is
- ) => CompileI is (Proxy Semigroup) where
- compileI tok ctx k =
- case tok of
- Token_Term_Semigroup_sappend tok_a ->
- -- (<>) :: Semigroup a => a -> a -> a
- compileO tok_a ctx $ \ty_a (TermO x) ->
- check_TyCon (At (Just tok_a) (ty @Semigroup :$ ty_a)) $ \TyCon ->
- k (ty_a ~> ty_a) $ TermO $
- \c -> lam $ \y -> (<>) (x c) y
- Token_Term_Semigroup_stimes tok_b tok_a ->
- -- stimes :: (Semigroup a, Integral b) => b -> a -> a
- compileO tok_b ctx $ \ty_b (TermO b) ->
- compileO tok_a ctx $ \ty_a (TermO a) ->
- check_TyCon (At (Just tok_a) (ty @Integral :$ ty_b)) $ \TyCon ->
- check_TyCon (At (Just tok_a) (ty @Semigroup :$ ty_a)) $ \TyCon ->
- k ty_a $ TermO $
- \c -> stimes (b c) (a c)
-instance -- TokenizeT
- Inj_Token meta ts Semigroup =>
- TokenizeT meta ts (Proxy Semigroup) where
- tokenizeT _t = mempty
- { tokenizers_infix = tokenizeTMod []
- [ tokenize1 "<>" (infixR 6) Token_Term_Semigroup_sappend
- , tokenize2 "stimes" infixN5 Token_Term_Semigroup_stimes
- ]
- }
-instance Gram_Term_AtomsT meta ts (Proxy Semigroup) g
+-- Compiling
+instance Gram_Term_AtomsFor src ss g Semigroup
+instance (Source src, SymInj ss Semigroup) => ModuleFor src ss Semigroup where
+ moduleFor = ["Semigroup"] `moduleWhere`
+ [ "<>" `withInfixR` 6 := teSemigroup_sappend
+ , "stimes" := teSemigroup_stimes
+ ]
+
+-- ** 'Type's
+tySemigroup :: Source src => Type src vs a -> Type src vs (Semigroup a)
+tySemigroup a = tyConstLen @(K Semigroup) @Semigroup (lenVars a) `tyApp` a
+
+-- ** 'Term's
+teSemigroup_sappend :: TermDef Semigroup '[Proxy a] (Semigroup a #> (a -> a -> a))
+teSemigroup_sappend = Term (tySemigroup a0) (a0 ~> a0 ~> a0) $ teSym @Semigroup $ lam2 (<>)
+
+teSemigroup_stimes :: TermDef Semigroup '[Proxy a, Proxy b] (Semigroup a # Integral b #> (b -> a -> a))
+teSemigroup_stimes = Term (tySemigroup a0 # tyIntegral b1) (b1 ~> a0 ~> a0) $ teSym @Semigroup $ lam2 stimes
sourcephile / git / haskell / symantic.git / blobdiff