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 -- Typing
  39 instance FixityOf Alternative
  40 instance ClassInstancesFor Alternative
  41 instance TypeInstancesFor Alternative
  42
  43 -- Compiling
  44 instance Gram_Term_AtomsFor src ss g Alternative
  45 instance (Source src, Inj_Sym ss Alternative) => Module src ss Alternative where
  46         module_ _s = [] `moduleWhere`
  47          [ "empty" := teAlternative_empty
  48          , "<|>" `withInfixL` 3 := teAlternative_alt
  49          ]
  50
  51 -- ** 'Type's
  52 tyAlternative :: Source src => Type src vs a -> Type src vs (Alternative a)
  53 tyAlternative a = tyConstLen @(K Alternative) @Alternative (lenVars a) `tyApp` a
  54
  55 -- ** 'Term's
  56 teAlternative_empty :: TermDef Alternative '[Proxy a, Proxy f] (Alternative f #> f a)
  57 teAlternative_empty = Term (tyAlternative f1) (f1 `tyApp` a0) $ teSym @Alternative $ empty
  58
  59 teAlternative_alt :: TermDef Alternative '[Proxy a, Proxy f] (Alternative f #> (f a -> f a -> f a))
  60 teAlternative_alt = Term (tyAlternative f1) (f1 `tyApp` a0 ~> f1 `tyApp` a0 ~> f1 `tyApp` a0) $ teSym @Alternative $ lam2 (<|>)