]> Git — Sourcephile - haskell/symantic.git/blob - symantic-lib/Language/Symantic/Lib/Alternative.hs
Fix comment typo.
[haskell/symantic.git] / symantic-lib / Language / Symantic / Lib / Alternative.hs
1 {-# LANGUAGE UndecidableInstances #-}
2 {-# OPTIONS_GHC -fno-warn-orphans #-}
3 -- | Symantic for 'Alternative'.
4 module Language.Symantic.Lib.Alternative where
5
6 import Control.Applicative (Alternative)
7 import qualified Control.Applicative as Alternative
8 import Control.Monad (liftM2)
9 import qualified Data.Function as Fun
10 import Data.Proxy
11 import Data.Type.Equality ((:~:)(Refl))
12 import Prelude hiding (Functor(..), (<$>), id, const)
13
14 import Language.Symantic.Parsing hiding (Alter(..))
15 import Language.Symantic.Typing
16 import Language.Symantic.Compiling
17 import Language.Symantic.Lib.Lambda
18 import Language.Symantic.Lib.Functor (Sym_Functor(..))
19 import Language.Symantic.Interpreting
20 import Language.Symantic.Transforming
21
22 -- * Class 'Sym_Alternative'
23 class Sym_Functor term => Sym_Alternative term where
24 empty :: Alternative f => term (f a)
25 (<|>) :: Alternative f => term (f a) -> term (f a) -> term (f a)
26 infixl 3 <|>
27
28 default empty :: (Trans t term, Alternative f) => t term (f a)
29 default (<|>) :: (Trans t term, Alternative f)
30 => t term (f a) -> t term (f a) -> t term (f a)
31
32 empty = trans_lift empty
33 (<|>) = trans_map2 (<|>)
34
35 type instance Sym_of_Iface (Proxy Alternative) = Sym_Alternative
36 type instance TyConsts_of_Iface (Proxy Alternative) = Proxy Alternative ': TyConsts_imported_by Alternative
37 type instance TyConsts_imported_by Alternative = '[]
38
39 instance Sym_Alternative HostI where
40 empty = HostI Alternative.empty
41 (<|>) = liftM2 (Alternative.<|>)
42 instance Sym_Alternative TextI where
43 empty = textI0 "empty"
44 (<|>) = textI_infix "<|>" (infixL 3)
45 instance (Sym_Alternative r1, Sym_Alternative r2) => Sym_Alternative (DupI r1 r2) where
46 empty = dupI0 @Sym_Alternative empty
47 (<|>) = dupI2 @Sym_Alternative (<|>)
48
49 instance
50 ( Read_TyNameR TyName cs rs
51 , Inj_TyConst cs Alternative
52 ) => Read_TyNameR TyName cs (Proxy Alternative ': rs) where
53 read_TyNameR _cs (TyName "Alternative") k = k (ty @Alternative)
54 read_TyNameR _rs raw k = read_TyNameR (Proxy @rs) raw k
55 instance Show_TyConst cs => Show_TyConst (Proxy Alternative ': cs) where
56 show_TyConst TyConstZ{} = "Alternative"
57 show_TyConst (TyConstS c) = show_TyConst c
58
59 instance Proj_TyConC cs (Proxy Alternative)
60 data instance TokenT meta (ts::[*]) (Proxy Alternative)
61 = Token_Term_Alternative_empty (EToken meta '[Proxy Token_Type]) (EToken meta '[Proxy Token_Type])
62 | Token_Term_Alternative_alt (EToken meta ts)
63 deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Alternative))
64 deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Alternative))
65 instance -- CompileI
66 ( Read_TyName TyName (TyConsts_of_Ifaces is)
67 , Inj_TyConst (TyConsts_of_Ifaces is) Alternative
68 , Inj_TyConst (TyConsts_of_Ifaces is) (->)
69 , Proj_TyCon (TyConsts_of_Ifaces is)
70 , Compile is
71 ) => CompileI is (Proxy Alternative) where
72 compileI tok ctx k =
73 case tok of
74 Token_Term_Alternative_empty tok_ty_f tok_ty_a ->
75 -- empty :: Alternative f => f a
76 compile_Type tok_ty_f $ \(ty_f::Type (TyConsts_of_Ifaces is) f) ->
77 compile_Type tok_ty_a $ \(ty_a::Type (TyConsts_of_Ifaces is) a) ->
78 check_Kind
79 (At Nothing $ SKiType `SKiArrow` SKiType)
80 (At (Just tok_ty_f) $ kind_of ty_f) $ \Refl ->
81 check_TyCon (At (Just tok_ty_f) (ty @Alternative :$ ty_f)) $ \TyCon ->
82 check_Kind
83 (At Nothing $ SKiType)
84 (At (Just tok_ty_a) $ kind_of ty_a) $ \Refl ->
85 k (ty_f :$ ty_a) $ TermO $
86 Fun.const empty
87 Token_Term_Alternative_alt tok_fl ->
88 -- (<|>) :: Alternative f => f a -> f a -> f a
89 compileO tok_fl ctx $ \ty_fa (TermO fl) ->
90 check_TyCon1 (ty @Alternative)
91 (At (Just tok_fl) ty_fa) $ \Refl TyCon _ty_f _ty_a ->
92 k (ty_fa ~> ty_fa) $ TermO $
93 \c -> lam $ \fr -> (<|>) (fl c) fr
94 instance -- TokenizeT
95 Inj_Token meta ts Alternative =>
96 TokenizeT meta ts (Proxy Alternative) where
97 tokenizeT _t = mempty
98 { tokenizers_infix = tokenizeTMod []
99 [ (Term_Name "empty",) Term_ProTok
100 { term_protok = \meta -> ProTokPi $ \f -> ProTokPi $ \a ->
101 ProTok $ inj_EToken meta $ Token_Term_Alternative_empty f a
102 , term_fixity = infixN5
103 }
104 , tokenize1 "<|>" (infixL 3) Token_Term_Alternative_alt
105 ]
106 }
107 instance Gram_Term_AtomsT meta ts (Proxy Alternative) g