module Language.Symantic.Lib.Alternative where
import Control.Applicative (Alternative)
-import qualified Control.Applicative as Alternative
-import Control.Monad (liftM2)
-import qualified Data.Function as Fun
-import Data.Proxy
-import Data.Type.Equality ((:~:)(Refl))
import Prelude hiding (Functor(..), (<$>), id, const)
+import qualified Control.Applicative as Alternative
-import Language.Symantic.Parsing hiding (Alter(..))
-import Language.Symantic.Typing
-import Language.Symantic.Compiling
-import Language.Symantic.Lib.Lambda
-import Language.Symantic.Lib.Functor (Sym_Functor(..))
-import Language.Symantic.Interpreting
-import Language.Symantic.Transforming
+import Language.Symantic
+import Language.Symantic.Lib.Functor (Sym_Functor(..), f1)
+import Language.Symantic.Lib.Function (a0)
-- * Class 'Sym_Alternative'
+type instance Sym Alternative = Sym_Alternative
class Sym_Functor term => Sym_Alternative term where
empty :: Alternative f => term (f a)
(<|>) :: Alternative f => term (f a) -> term (f a) -> term (f a)
+ infixl 3 <|>
- default empty :: (Trans t term, Alternative f) => t term (f a)
- default (<|>) :: (Trans t term, Alternative f)
- => t term (f a) -> t term (f a) -> t term (f a)
+ default empty :: Sym_Alternative (UnT term) => Trans term => Alternative f => term (f a)
+ default (<|>) :: Sym_Alternative (UnT term) => Trans term => Alternative f => term (f a) -> term (f a) -> term (f a)
- empty = trans_lift empty
- (<|>) = trans_map2 (<|>)
+ empty = trans empty
+ (<|>) = trans2 (<|>)
+
+-- Interpreting
+instance Sym_Alternative Eval where
+ empty = Eval Alternative.empty
+ (<|>) = eval2 (Alternative.<|>)
+instance Sym_Alternative View where
+ empty = view0 "empty"
+ (<|>) = viewInfix "<|>" (infixL 3)
+instance (Sym_Alternative r1, Sym_Alternative r2) => Sym_Alternative (Dup r1 r2) where
+ empty = dup0 @Sym_Alternative empty
+ (<|>) = dup2 @Sym_Alternative (<|>)
+
+-- Transforming
+instance (Sym_Lambda term, Sym_Alternative term) => Sym_Alternative (BetaT term)
-infixl 3 <|>
+-- Typing
+instance NameTyOf Alternative where
+ nameTyOf _c = ["Alternative"] `Mod` "Alternative"
+instance FixityOf Alternative
+instance ClassInstancesFor Alternative
+instance TypeInstancesFor Alternative
-type instance Sym_of_Iface (Proxy Alternative) = Sym_Alternative
-type instance TyConsts_of_Iface (Proxy Alternative) = Proxy Alternative ': TyConsts_imported_by Alternative
-type instance TyConsts_imported_by Alternative = '[]
+-- Compiling
+instance Gram_Term_AtomsFor src ss g Alternative
+instance (Source src, SymInj ss Alternative) => ModuleFor src ss Alternative where
+ moduleFor = ["Alternative"] `moduleWhere`
+ [ "empty" := teAlternative_empty
+ , "<|>" `withInfixL` 3 := teAlternative_alt
+ ]
-instance Sym_Alternative HostI where
- empty = HostI Alternative.empty
- (<|>) = liftM2 (Alternative.<|>)
-instance Sym_Alternative TextI where
- empty = textI0 "empty"
- (<|>) = textI_infix "<|>" (infixL 3)
-instance (Sym_Alternative r1, Sym_Alternative r2) => Sym_Alternative (DupI r1 r2) where
- empty = dupI0 (Proxy @Sym_Alternative) empty
- (<|>) = dupI2 (Proxy @Sym_Alternative) (<|>)
+-- ** 'Type's
+tyAlternative :: Source src => Type src vs a -> Type src vs (Alternative a)
+tyAlternative a = tyConstLen @(K Alternative) @Alternative (lenVars a) `tyApp` a
-instance
- ( Read_TyNameR TyName cs rs
- , Inj_TyConst cs Alternative
- ) => Read_TyNameR TyName cs (Proxy Alternative ': rs) where
- read_TyNameR _cs (TyName "Alternative") k = k (ty @Alternative)
- read_TyNameR _rs raw k = read_TyNameR (Proxy @rs) raw k
-instance Show_TyConst cs => Show_TyConst (Proxy Alternative ': cs) where
- show_TyConst TyConstZ{} = "Alternative"
- show_TyConst (TyConstS c) = show_TyConst c
+-- ** 'Term's
+teAlternative_empty :: TermDef Alternative '[Proxy a, Proxy f] (Alternative f #> f a)
+teAlternative_empty = Term (tyAlternative f1) (f1 `tyApp` a0) $ teSym @Alternative $ empty
-instance Proj_TyConC cs (Proxy Alternative)
-data instance TokenT meta (ts::[*]) (Proxy Alternative)
- = Token_Term_Alternative_empty (EToken meta '[Proxy Token_Type]) (EToken meta '[Proxy Token_Type])
- | Token_Term_Alternative_alt (EToken meta ts)
-deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Alternative))
-deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Alternative))
-instance -- CompileI
- ( Read_TyName TyName (TyConsts_of_Ifaces is)
- , Inj_TyConst (TyConsts_of_Ifaces is) Alternative
- , Inj_TyConst (TyConsts_of_Ifaces is) (->)
- , Proj_TyCon (TyConsts_of_Ifaces is)
- , Compile is
- ) => CompileI is (Proxy Alternative) where
- compileI tok ctx k =
- case tok of
- Token_Term_Alternative_empty tok_ty_f tok_ty_a ->
- -- empty :: Alternative f => f a
- compile_Type tok_ty_f $ \(ty_f::Type (TyConsts_of_Ifaces is) f) ->
- compile_Type tok_ty_a $ \(ty_a::Type (TyConsts_of_Ifaces is) a) ->
- check_Kind
- (At Nothing $ SKiType `SKiArrow` SKiType)
- (At (Just tok_ty_f) $ kind_of ty_f) $ \Refl ->
- check_TyCon (At (Just tok_ty_f) (ty @Alternative :$ ty_f)) $ \TyCon ->
- check_Kind
- (At Nothing $ SKiType)
- (At (Just tok_ty_a) $ kind_of ty_a) $ \Refl ->
- k (ty_f :$ ty_a) $ TermO $
- Fun.const empty
- Token_Term_Alternative_alt tok_fl ->
- -- (<|>) :: Alternative f => f a -> f a -> f a
- compileO tok_fl ctx $ \ty_fa (TermO fl) ->
- check_TyCon1 (ty @Alternative)
- (At (Just tok_fl) ty_fa) $ \Refl TyCon _ty_f _ty_a ->
- k (ty_fa ~> ty_fa) $ TermO $
- \c -> lam $ \fr -> (<|>) (fl c) fr
-instance -- TokenizeT
- Inj_Token meta ts Alternative =>
- TokenizeT meta ts (Proxy Alternative) where
- tokenizeT _t = mempty
- { tokenizers_infix = tokenizeTMod []
- [ (Term_Name "empty",) Term_ProTok
- { term_protok = \meta -> ProTokPi $ \f -> ProTokPi $ \a ->
- ProTok $ inj_EToken meta $ Token_Term_Alternative_empty f a
- , term_fixity = infixN5
- }
- , tokenize1 "<|>" (infixL 3) Token_Term_Alternative_alt
- ]
- }
-instance Gram_Term_AtomsT meta ts (Proxy Alternative) g
+teAlternative_alt :: TermDef Alternative '[Proxy a, Proxy f] (Alternative f #> (f a -> f a -> f a))
+teAlternative_alt = Term (tyAlternative f1) (f1 `tyApp` a0 ~> f1 `tyApp` a0 ~> f1 `tyApp` a0) $ teSym @Alternative $ lam2 (<|>)
sourcephile / git / haskell / symantic.git / blobdiff