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 Prelude hiding (Functor(..), (<$>), id, const)
   8 import qualified Control.Applicative as Alternative
   9
  10 import Language.Symantic
  11 import Language.Symantic.Lib.Functor (Sym_Functor(..), f1)
  12 import Language.Symantic.Lib.Function (a0)
  13
  14 -- * Class 'Sym_Alternative'
  15 type instance Sym (Proxy Alternative) = Sym_Alternative
  16 class Sym_Functor term => Sym_Alternative term where
  17         empty :: Alternative f => term (f a)
  18         (<|>) :: Alternative f => term (f a) -> term (f a) -> term (f a)
  19         infixl 3 <|>
  20
  21         default empty :: Sym_Alternative (UnT term) => Trans term => Alternative f => term (f a)
  22         default (<|>) :: Sym_Alternative (UnT term) => Trans term => Alternative f => term (f a) -> term (f a) -> term (f a)
  23
  24         empty = trans empty
  25         (<|>) = trans2 (<|>)
  26
  27 -- Interpreting
  28 instance Sym_Alternative Eval where
  29         empty = Eval Alternative.empty
  30         (<|>) = eval2 (Alternative.<|>)
  31 instance Sym_Alternative View where
  32         empty = view0 "empty"
  33         (<|>) = viewInfix "<|>" (infixL 3)
  34 instance (Sym_Alternative r1, Sym_Alternative r2) => Sym_Alternative (Dup r1 r2) where
  35         empty = dup0 @Sym_Alternative empty
  36         (<|>) = dup2 @Sym_Alternative (<|>)
  37
  38 -- Transforming
  39 instance (Sym_Lambda term, Sym_Alternative term) => Sym_Alternative (BetaT term)
  40
  41 -- Typing
  42 instance FixityOf Alternative
  43 instance ClassInstancesFor Alternative
  44 instance TypeInstancesFor Alternative
  45
  46 -- Compiling
  47 instance Gram_Term_AtomsFor src ss g Alternative
  48 instance (Source src, Inj_Sym ss Alternative) => ModuleFor src ss Alternative where
  49         moduleFor = ["Alternative"] `moduleWhere`
  50          [ "empty" := teAlternative_empty
  51          , "<|>" `withInfixL` 3 := teAlternative_alt
  52          ]
  53
  54 -- ** 'Type's
  55 tyAlternative :: Source src => Type src vs a -> Type src vs (Alternative a)
  56 tyAlternative a = tyConstLen @(K Alternative) @Alternative (lenVars a) `tyApp` a
  57
  58 -- ** 'Term's
  59 teAlternative_empty :: TermDef Alternative '[Proxy a, Proxy f] (Alternative f #> f a)
  60 teAlternative_empty = Term (tyAlternative f1) (f1 `tyApp` a0) $ teSym @Alternative $ empty
  61
  62 teAlternative_alt :: TermDef Alternative '[Proxy a, Proxy f] (Alternative f #> (f a -> f a -> f a))
  63 teAlternative_alt = Term (tyAlternative f1) (f1 `tyApp` a0 ~> f1 `tyApp` a0 ~> f1 `tyApp` a0) $ teSym @Alternative $ lam2 (<|>)