]> Git — Sourcephile - haskell/symantic.git/blob - Language/Symantic/Compiling/Alternative.hs
Add Parsing.Grammar.
[haskell/symantic.git] / Language / Symantic / Compiling / Alternative.hs
1 {-# LANGUAGE UndecidableInstances #-}
2 {-# OPTIONS_GHC -fno-warn-orphans #-}
3 -- | Symantic for 'Alternative'.
4 module Language.Symantic.Compiling.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.Text (Text)
12 import Data.Type.Equality ((:~:)(Refl))
13 import Prelude hiding (Functor(..), (<$>), id, const, Monoid(..))
14
15 import Language.Symantic.Parsing
16 import Language.Symantic.Typing
17 import Language.Symantic.Compiling.Term
18 import Language.Symantic.Compiling.Functor (Sym_Functor(..))
19 import Language.Symantic.Interpreting
20 import Language.Symantic.Transforming.Trans
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
27 default empty :: (Trans t term, Alternative f) => t term (f a)
28 default (<|>) :: (Trans t term, Alternative f)
29 => t term (f a) -> t term (f a) -> t term (f a)
30
31 empty = trans_lift empty
32 (<|>) = trans_map2 (<|>)
33
34 infixl 3 <|>
35
36 type instance Sym_of_Iface (Proxy Alternative) = Sym_Alternative
37 type instance Consts_of_Iface (Proxy Alternative) = Proxy Alternative ': Consts_imported_by Alternative
38 type instance Consts_imported_by Alternative = '[]
39
40 instance Sym_Alternative HostI where
41 empty = HostI Alternative.empty
42 (<|>) = liftM2 (Alternative.<|>)
43 instance Sym_Alternative TextI where
44 empty = textI0 "empty"
45 (<|>) = textI_infix "<|>" (Precedence 3)
46 instance (Sym_Alternative r1, Sym_Alternative r2) => Sym_Alternative (DupI r1 r2) where
47 empty = dupI0 (Proxy @Sym_Alternative) empty
48 (<|>) = dupI2 (Proxy @Sym_Alternative) (<|>)
49
50 instance
51 ( Read_TypeNameR Text cs rs
52 , Inj_Const cs Alternative
53 ) => Read_TypeNameR Text cs (Proxy Alternative ': rs) where
54 read_typenameR _cs "Alternative" k = k (ty @Alternative)
55 read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k
56 instance Show_Const cs => Show_Const (Proxy Alternative ': cs) where
57 show_const ConstZ{} = "Alternative"
58 show_const (ConstS c) = show_const c
59
60 instance Proj_ConC cs (Proxy Alternative)
61 data instance TokenT meta (ts::[*]) (Proxy Alternative)
62 = Token_Term_Alternative_empty (EToken meta '[Proxy Token_Type]) (EToken meta '[Proxy Token_Type])
63 | Token_Term_Alternative_alt (EToken meta ts)
64 deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Alternative))
65 deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Alternative))
66 instance -- CompileI
67 ( Read_TypeName Name_LamVar (Consts_of_Ifaces is)
68 , Inj_Const (Consts_of_Ifaces is) Alternative
69 , Inj_Const (Consts_of_Ifaces is) (->)
70 , Proj_Con (Consts_of_Ifaces is)
71 , Compile is
72 ) => CompileI is (Proxy Alternative) where
73 compileI tok ctx k =
74 case tok of
75 Token_Term_Alternative_empty tok_ty_f tok_ty_a ->
76 -- empty :: Alternative f => f a
77 compile_type tok_ty_f $ \(ty_f::Type (Consts_of_Ifaces is) f) ->
78 compile_type tok_ty_a $ \(ty_a::Type (Consts_of_Ifaces is) a) ->
79 check_kind
80 (At Nothing $ SKiType `SKiArrow` SKiType)
81 (At (Just tok_ty_f) $ kind_of ty_f) $ \Refl ->
82 check_con (At (Just tok_ty_f) (ty @Alternative :$ ty_f)) $ \Con ->
83 check_kind
84 (At Nothing $ SKiType)
85 (At (Just tok_ty_a) $ kind_of ty_a) $ \Refl ->
86 k (ty_f :$ ty_a) $ TermO $
87 Fun.const empty
88 Token_Term_Alternative_alt tok_fl ->
89 -- (<|>) :: Alternative f => f a -> f a -> f a
90 compileO tok_fl ctx $ \ty_fa (TermO fl) ->
91 check_con1 (ty @Alternative)
92 (At (Just tok_fl) ty_fa) $ \Refl Con _ty_f _ty_a ->
93 k (ty_fa ~> ty_fa) $ TermO $
94 \c -> lam $ \fr -> (<|>) (fl c) fr