src/Symantic/Parser/Grammar/Combinators.hs

   1 {-# LANGUAGE DefaultSignatures #-}
   2 {-# LANGUAGE PatternSynonyms #-}
   3 {-# LANGUAGE TemplateHaskell #-}
   4 module Symantic.Parser.Grammar.Combinators where
   5 import Data.Function ((.))
   6 import Data.Bool (Bool)
   7 import Data.Char (Char)
   8 import Data.Kind (Type)
   9 import Data.Either (Either)
  10
  11 import Symantic.Base.Univariant
  12
  13 -- * Class 'Applicable'
  14 class Applicable repr where
  15   type Pure repr :: Type -> Type
  16   pure :: Pure repr a -> repr a
  17   (<$>) :: Pure repr (a -> b) -> repr a -> repr b
  18   (<*>) :: repr (a -> b) -> repr a -> repr b
  19   (<*) :: repr a -> repr b -> repr a
  20   (*>) :: repr a -> repr b -> repr b
  21   default pure ::
  22     Liftable repr => Applicable (Unlift repr) =>
  23     Pure (Unlift repr) ~ Pure repr =>
  24     Pure repr a -> repr a
  25   default (<$>) ::
  26     Liftable repr => Applicable (Unlift repr) =>
  27     Pure (Unlift repr) ~ Pure repr =>
  28     Pure repr (a -> b) -> repr a -> repr b
  29   default (<*>) ::
  30     Liftable repr => Applicable (Unlift repr) =>
  31     repr (a -> b) -> repr a -> repr b
  32   default (<*) ::
  33     Liftable repr => Applicable (Unlift repr) =>
  34     repr a -> repr b -> repr a
  35   default (*>) ::
  36     Liftable repr => Applicable (Unlift repr) =>
  37     repr a -> repr b -> repr b
  38   pure = lift . pure
  39   (<$>) f = lift1 (f <$>)
  40   (<*>) = lift2 (<*>)
  41   (<*) = lift2 (<*)
  42   (*>) = lift2 (*>)
  43 infixl 4 <$>, <*>, <*, *>
  44
  45 -- * Class 'Alternable'
  46 class Alternable repr where
  47   (<|>) :: repr a -> repr a -> repr a
  48   empty :: repr a
  49   try :: repr a -> repr a
  50   default (<|>) ::
  51     Liftable repr => Alternable (Unlift repr) =>
  52     repr a -> repr a -> repr a
  53   default empty ::
  54     Liftable repr => Alternable (Unlift repr) =>
  55     repr a
  56   default try ::
  57     Liftable repr => Alternable (Unlift repr) =>
  58     repr a -> repr a
  59   (<|>) = lift2 (<|>)
  60   empty = lift empty
  61   try = lift1 try
  62 infixl 3 <|>
  63
  64 -- * Class 'Selectable'
  65 class Selectable repr where
  66   branch :: repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
  67   default branch ::
  68     Liftable repr => Selectable (Unlift repr) =>
  69     repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
  70   branch  = lift3 branch
  71
  72 -- * Class 'Charable'
  73 class Charable repr where
  74   satisfy :: Pure repr (Char -> Bool) -> repr Char
  75   default satisfy ::
  76     Pure (Unlift repr) ~ Pure repr =>
  77     Liftable repr => Charable (Unlift repr) =>
  78     Pure repr (Char -> Bool) -> repr Char
  79   satisfy = lift . satisfy
  80
  81 -- * Class 'Lookable'
  82 class Lookable repr where
  83   look :: repr a -> repr a
  84   negLook :: repr a -> repr ()
  85   default look    :: Liftable repr => Lookable (Unlift repr) => repr a -> repr a
  86   default negLook :: Liftable repr => Lookable (Unlift repr) => repr a -> repr ()
  87   look    = lift1 look
  88   negLook = lift1 negLook
  89