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