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 Const_from Text cs => Const_from Text (Proxy Alternative ': cs) where
  51         const_from "Alternative" k = k (ConstZ kind)
  52         const_from s k = const_from s $ k . ConstS
  53 instance Show_Const cs => Show_Const (Proxy Alternative ': cs) where
  54         show_const ConstZ{} = "Alternative"
  55         show_const (ConstS c) = show_const c
  56
  57 instance Proj_ConC cs (Proxy Alternative)
  58 data instance TokenT meta (ts::[*]) (Proxy Alternative)
  59  = Token_Term_Alternative_empty (EToken meta '[Proxy Token_Type]) (EToken meta '[Proxy Token_Type])
  60  | Token_Term_Alternative_alt   (EToken meta ts)
  61 deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Alternative))
  62 deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Alternative))
  63 instance -- CompileI
  64  ( Const_from Name_LamVar (Consts_of_Ifaces is)
  65  , Inj_Const  (Consts_of_Ifaces is) Alternative
  66  , Inj_Const  (Consts_of_Ifaces is) (->)
  67  , Proj_Con   (Consts_of_Ifaces is)
  68  , Compile is
  69  ) => CompileI is (Proxy Alternative) where
  70         compileI tok ctx k =
  71                 case tok of
  72                  Token_Term_Alternative_empty tok_ty_f tok_ty_a ->
  73                         -- empty :: Alternative f => f a
  74                         compile_type tok_ty_f $ \(ty_f::Type (Consts_of_Ifaces is) f) ->
  75                         compile_type tok_ty_a $ \(ty_a::Type (Consts_of_Ifaces is) a) ->
  76                         check_kind
  77                          (At Nothing $ SKiType `SKiArrow` SKiType)
  78                          (At (Just tok_ty_f) $ kind_of ty_f) $ \Refl ->
  79                         check_con (At (Just tok_ty_f) (ty @Alternative :$ ty_f)) $ \Con ->
  80                         check_kind
  81                          (At Nothing $ SKiType)
  82                          (At (Just tok_ty_a) $ kind_of ty_a) $ \Refl ->
  83                         k (ty_f :$ ty_a) $ TermO $
  84                          Fun.const empty
  85                  Token_Term_Alternative_alt tok_fl ->
  86                         -- (<|>) :: Alternative f => f a -> f a -> f a
  87                         compileO tok_fl ctx $ \ty_fa (TermO fl) ->
  88                         check_con1 (ty @Alternative)
  89                          (At (Just tok_fl) ty_fa) $ \Refl Con _ty_f _ty_a ->
  90                         k (ty_fa ~> ty_fa) $ TermO $
  91                          \c -> lam $ \fr -> (<|>) (fl c) fr