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(..))
   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 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 NameTyOf Alternative where
  43         nameTyOf _c = ["Alternative"] `Mod` "Alternative"
  44 instance FixityOf Alternative
  45 instance ClassInstancesFor Alternative
  46 instance TypeInstancesFor Alternative
  47
  48 -- Compiling
  49 instance Gram_Term_AtomsFor src ss g Alternative
  50 instance (Source src, SymInj ss Alternative) => ModuleFor src ss Alternative where
  51         moduleFor = ["Alternative"] `moduleWhere`
  52          [ "empty" := teAlternative_empty
  53          , "<|>" `withInfixL` 3 := teAlternative_alt
  54          ]
  55
  56 -- ** 'Type's
  57 tyAlternative :: Source src => Type src vs a -> Type src vs (Alternative a)
  58 tyAlternative a = tyConstLen @(K Alternative) @Alternative (lenVars a) `tyApp` a
  59
  60 -- ** 'Term's
  61 teAlternative_empty :: TermDef Alternative '[Proxy a, Proxy f] (Alternative f #> f a)
  62 teAlternative_empty = Term (tyAlternative f1) (f1 `tyApp` a0) $ teSym @Alternative $ empty
  63
  64 teAlternative_alt :: TermDef Alternative '[Proxy a, Proxy f] (Alternative f #> (f a -> f a -> f a))
  65 teAlternative_alt = Term (tyAlternative f1) (f1 `tyApp` a0 ~> f1 `tyApp` a0 ~> f1 `tyApp` a0) $ teSym @Alternative $ lam2 (<|>)