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