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 ((.), flip, const)
   6 import Data.Bool (Bool(..), not, (||))
   7 import Data.Char (Char)
   8 import Data.Either (Either(..))
   9 import Data.Eq (Eq(..))
  10 import Data.Int (Int)
  11 import Data.Kind (Type)
  12 import Data.Maybe (Maybe(..))
  13 import Data.String (String)
  14 import Language.Haskell.TH (TExpQ)
  15 import qualified Data.Functor as F
  16 import qualified Prelude as Pre
  17 import qualified Data.List as List
  18
  19 import Symantic.Base.Univariant
  20 import qualified Symantic.Parser.Staging as S
  21
  22 -- * Class 'Applicable'
  23 class Applicable repr where
  24   (<$>) :: S.Runtime (a -> b) -> repr a -> repr b
  25   (<$>) f = (pure f <*>)
  26
  27   (<&>) :: repr a -> S.Runtime (a -> b) -> repr b
  28   (<&>) = flip (<$>)
  29
  30   (<$) :: S.Runtime a -> repr b -> repr a
  31   (<$) x = (pure x <*)
  32
  33   ($>) :: repr a -> S.Runtime b -> repr b
  34   ($>) = flip (<$)
  35
  36   --type Pure repr :: Type -> Type
  37   pure :: S.Runtime a -> repr a
  38   default pure ::
  39     Liftable repr => Applicable (Unlift repr) =>
  40     S.Runtime a -> repr a
  41   pure = lift . pure
  42
  43   (<*>) :: repr (a -> b) -> repr a -> repr b
  44   default (<*>) ::
  45     Liftable repr => Applicable (Unlift repr) =>
  46     repr (a -> b) -> repr a -> repr b
  47   (<*>) = lift2 (<*>)
  48
  49   liftA2 :: S.Runtime (a -> b -> c) -> repr a -> repr b -> repr c
  50   liftA2 f x = (<*>) (f <$> x)
  51
  52   (*>) :: repr a -> repr b -> repr b
  53   x *> y = (S.id <$ x) <*> y
  54
  55   (<*) :: repr a -> repr b -> repr a
  56   (<*) = liftA2 S.const
  57
  58   {-
  59   (<**>) :: repr a -> repr (a -> b) -> repr b
  60   (<**>) = liftA2 (\a f -> f a)
  61   -}
  62 infixl 4 <$>, <&>, <$, $>, <*>, <*, *>
  63
  64 infixl 4 <**>
  65 (<**>) :: Applicable repr => repr a -> repr (a -> b) -> repr b
  66 (<**>) = liftA2 (S.flip S..@ (S.$))
  67
  68 -- * Class 'Alternable'
  69 class Alternable repr where
  70   (<|>) :: repr a -> repr a -> repr a
  71   empty :: repr a
  72   try :: repr a -> repr a
  73   default (<|>) ::
  74     Liftable repr => Alternable (Unlift repr) =>
  75     repr a -> repr a -> repr a
  76   default empty ::
  77     Liftable repr => Alternable (Unlift repr) =>
  78     repr a
  79   default try ::
  80     Liftable repr => Alternable (Unlift repr) =>
  81     repr a -> repr a
  82   (<|>) = lift2 (<|>)
  83   empty = lift empty
  84   try = lift1 try
  85 infixl 3 <|>
  86
  87 infixl 3 <+>
  88 (<+>) :: Applicable repr => Alternable repr => repr a -> repr b -> repr (Either a b)
  89 p <+> q = S.Runtime (S.Eval Left) (S.Code [||Left||]) <$> p <|>
  90           S.Runtime (S.Eval Right) (S.Code [||Right||]) <$> q
  91
  92 optionally :: Applicable repr => Alternable repr => repr a -> S.Runtime b -> repr b
  93 optionally p x = p $> x <|> pure x
  94
  95 optional :: Applicable repr => Alternable repr => repr a -> repr ()
  96 optional = flip optionally S.unit
  97
  98 option :: Applicable repr => Alternable repr => S.Runtime a -> repr a -> repr a
  99 option x p = p <|> pure x
 100
 101 choice :: Alternable repr => [repr a] -> repr a
 102 choice = List.foldr (<|>) empty
 103
 104 maybeP :: Applicable repr => Alternable repr => repr a -> repr (Maybe a)
 105 maybeP p = option (S.Runtime (S.Eval Nothing) (S.Code [||Nothing||]))
 106                   (S.Runtime (S.Eval Just) (S.Code [||Just||]) <$> p)
 107
 108 manyTill :: Applicable repr => Alternable repr => repr a -> repr b -> repr [a]
 109 manyTill p end = let go = end $> S.nil <|> p <:> go in go
 110
 111 -- * Class 'Selectable'
 112 class Selectable repr where
 113   branch :: repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
 114   default branch ::
 115     Liftable repr => Selectable (Unlift repr) =>
 116     repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
 117   branch  = lift3 branch
 118
 119 class Matchable repr where
 120   conditional ::
 121     Eq a => [S.Runtime (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b
 122   default conditional ::
 123     Unliftable repr => Liftable repr => Matchable (Unlift repr) =>
 124     Eq a => [S.Runtime (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b
 125   conditional cs bs = lift2 (conditional cs (unlift Pre.<$> bs))
 126
 127   match :: Eq a => [S.Runtime a] -> repr a -> (S.Runtime a -> repr b) -> repr b -> repr b
 128   match as a a2b b = conditional (S.eq Pre.<$> as) (a2b Pre.<$> as) a b
 129
 130 -- * Class 'Foldable'
 131 class Foldable repr where
 132   chainPre  :: repr (a -> a) -> repr a -> repr a
 133   chainPost :: repr a -> repr (a -> a) -> repr a
 134   default chainPre ::
 135     Liftable repr => Foldable (Unlift repr) =>
 136     repr (a -> a) -> repr a -> repr a
 137   default chainPost ::
 138     Liftable repr => Foldable (Unlift repr) =>
 139     repr a -> repr (a -> a) -> repr a
 140   chainPre = lift2 chainPre
 141   chainPost = lift2 chainPost
 142
 143 {-
 144 conditional :: Selectable repr => [(S.Runtime (a -> Bool), repr b)] -> repr a -> repr b -> repr b
 145 conditional cs p def = match p fs qs def
 146   where (fs, qs) = List.unzip cs
 147 -}
 148
 149 -- * Class 'Charable'
 150 class Charable repr where
 151   satisfy :: S.Runtime (Char -> Bool) -> repr Char
 152   default satisfy ::
 153     Liftable repr => Charable (Unlift repr) =>
 154     S.Runtime (Char -> Bool) -> repr Char
 155   satisfy = lift . satisfy
 156
 157 -- * Class 'Lookable'
 158 class Lookable repr where
 159   look :: repr a -> repr a
 160   negLook :: repr a -> repr ()
 161   default look    :: Liftable repr => Lookable (Unlift repr) => repr a -> repr a
 162   default negLook :: Liftable repr => Lookable (Unlift repr) => repr a -> repr ()
 163   look    = lift1 look
 164   negLook = lift1 negLook
 165
 166 {-# INLINE (<:>) #-}
 167 infixl 4 <:>
 168 (<:>) :: Applicable repr => repr a -> repr [a] -> repr [a]
 169 (<:>) = liftA2 S.cons
 170
 171 sequence :: Applicable repr => [repr a] -> repr [a]
 172 sequence = List.foldr (<:>) (pure S.nil)
 173
 174 traverse :: Applicable repr => (a -> repr b) -> [a] -> repr [b]
 175 traverse f = sequence . List.map f
 176
 177 repeat :: Applicable repr => Int -> repr a -> repr [a]
 178 repeat n p = traverse (const p) [1..n]
 179
 180 between :: Applicable repr => repr o -> repr c -> repr a -> repr a
 181 between open close p = open *> p <* close
 182
 183 string :: Applicable repr => Charable repr => String -> repr String
 184 string = traverse char
 185
 186 -- oneOf :: [Char] -> repr Char
 187 -- oneOf cs = satisfy (makeQ (flip elem cs) [||\c -> $$(ofChars cs [||c||])||])
 188
 189 noneOf :: Charable repr => [Char] -> repr Char
 190 noneOf cs = satisfy ((S.Runtime (S.Eval (not . flip List.elem cs)) (S.Code [||\c -> not $$(ofChars cs [||c||])||])))
 191
 192 ofChars :: [Char] -> TExpQ Char -> TExpQ Bool
 193 ofChars = List.foldr (\c rest qc -> [|| c == $$qc || $$(rest qc) ||]) (const [||False||])
 194
 195 token :: Applicable repr => Alternable repr => Charable repr => String -> repr String
 196 token = try . string
 197
 198 eof :: Charable repr => Lookable repr => repr ()
 199 eof = negLook item
 200
 201 more :: Applicable repr => Charable repr => Lookable repr => repr ()
 202 more = look (void item)
 203
 204 char :: Applicable repr => Charable repr => Char -> repr Char
 205 char c = satisfy (S.eq (S.char c)) $> S.char c
 206
 207 item :: Charable repr => repr Char
 208 item = satisfy (S.const S..@ S.bool True)
 209
 210 -- Composite Combinators
 211 -- someTill :: repr a -> repr b -> repr [a]
 212 -- someTill p end = negLook end *> (p <:> manyTill p end)
 213
 214 void :: Applicable repr => repr a -> repr ()
 215 void p = p *> unit
 216
 217 unit :: Applicable repr => repr ()
 218 unit = pure S.unit
 219
 220 {-
 221
 222 constp :: Applicable repr => repr a -> repr (b -> a)
 223 constp = (S.const <$>)
 224
 225
 226 -- Alias Operations
 227 infixl 1 >>
 228 (>>) :: Applicable repr => repr a -> repr b -> repr b
 229 (>>) = (*>)
 230
 231 -- Monoidal Operations
 232
 233 infixl 4 <~>
 234 (<~>) :: Applicable repr => repr a -> repr b -> repr (a, b)
 235 (<~>) = liftA2 (S.runtime (,))
 236
 237 infixl 4 <~
 238 (<~) :: Applicable repr => repr a -> repr b -> repr a
 239 (<~) = (<*)
 240
 241 infixl 4 ~>
 242 (~>) :: Applicable repr => repr a -> repr b -> repr b
 243 (~>) = (*>)
 244
 245 -- Lift Operations
 246 liftA2 ::
 247  Applicable repr =>
 248  S.Runtime (a -> b -> c) -> repr a -> repr b -> repr c
 249 liftA2 f x = (<*>) (fmap f x)
 250
 251 liftA3 ::
 252  Applicable repr =>
 253  S.Runtime (a -> b -> c -> d) -> repr a -> repr b -> repr c -> repr d
 254 liftA3 f a b c = liftA2 f a b <*> c
 255
 256 -}
 257
 258 -- Parser Folds
 259 pfoldr ::
 260  Applicable repr => Foldable repr =>
 261  S.Runtime (a -> b -> b) -> S.Runtime b -> repr a -> repr b
 262 pfoldr f k p = chainPre (f <$> p) (pure k)
 263
 264 pfoldr1 ::
 265  Applicable repr => Foldable repr =>
 266  S.Runtime (a -> b -> b) -> S.Runtime b -> repr a -> repr b
 267 pfoldr1 f k p = f <$> p <*> pfoldr f k p
 268
 269 pfoldl ::
 270  Applicable repr => Foldable repr =>
 271  S.Runtime (b -> a -> b) -> S.Runtime b -> repr a -> repr b
 272 pfoldl f k p = chainPost (pure k) ((S.flip <$> pure f) <*> p)
 273
 274 pfoldl1 ::
 275  Applicable repr => Foldable repr =>
 276  S.Runtime (b -> a -> b) -> S.Runtime b -> repr a -> repr b
 277 pfoldl1 f k p = chainPost (f <$> pure k <*> p) ((S.flip <$> pure f) <*> p)
 278
 279 -- Chain Combinators
 280 chainl1' ::
 281  Applicable repr => Foldable repr =>
 282  S.Runtime (a -> b) -> repr a -> repr (b -> a -> b) -> repr b
 283 chainl1' f p op = chainPost (f <$> p) (S.flip <$> op <*> p)
 284
 285 chainl1 ::
 286  Applicable repr => Foldable repr =>
 287  repr a -> repr (a -> a -> a) -> repr a
 288 chainl1 = chainl1' S.id
 289
 290 {-
 291 chainr1' :: ParserOps rep => rep (a -> b) -> repr a -> repr (a -> b -> b) -> repr b
 292 chainr1' f p op = newRegister_ S.id $ \acc ->
 293   let go = bind p $ \x ->
 294            modify acc (S.flip (S..@) <$> (op <*> x)) *> go
 295        <|> f <$> x
 296   in go <**> get acc
 297
 298 chainr1 :: repr a -> repr (a -> a -> a) -> repr a
 299 chainr1 = chainr1' S.id
 300
 301 chainr :: repr a -> repr (a -> a -> a) -> S.Runtime a -> repr a
 302 chainr p op x = option x (chainr1 p op)
 303 -}
 304
 305 chainl ::
 306  Applicable repr => Alternable repr => Foldable repr =>
 307  repr a -> repr (a -> a -> a) -> S.Runtime a -> repr a
 308 chainl p op x = option x (chainl1 p op)
 309
 310 -- Derived Combinators
 311 many ::
 312  Applicable repr => Foldable repr =>
 313  repr a -> repr [a]
 314 many = pfoldr S.cons S.nil
 315
 316 manyN ::
 317  Applicable repr => Foldable repr =>
 318  Int -> repr a -> repr [a]
 319 manyN n p = List.foldr (const (p <:>)) (many p) [1..n]
 320
 321 some ::
 322  Applicable repr => Foldable repr =>
 323  repr a -> repr [a]
 324 some = manyN 1
 325
 326 skipMany ::
 327  Applicable repr => Foldable repr =>
 328  repr a -> repr ()
 329 --skipMany p = let skipManyp = p *> skipManyp <|> unit in skipManyp
 330 skipMany = void . pfoldl S.const S.unit -- the void here will encourage the optimiser to recognise that the register is unused
 331
 332 skipManyN ::
 333  Applicable repr => Foldable repr =>
 334  Int -> repr a -> repr ()
 335 skipManyN n p = List.foldr (const (p *>)) (skipMany p) [1..n]
 336
 337 skipSome ::
 338  Applicable repr => Foldable repr =>
 339  repr a -> repr ()
 340 skipSome = skipManyN 1
 341
 342 sepBy ::
 343  Applicable repr => Alternable repr => Foldable repr =>
 344  repr a -> repr b -> repr [a]
 345 sepBy p sep = option S.nil (sepBy1 p sep)
 346
 347 sepBy1 ::
 348  Applicable repr => Alternable repr => Foldable repr =>
 349  repr a -> repr b -> repr [a]
 350 sepBy1 p sep = p <:> many (sep *> p)
 351
 352 endBy ::
 353  Applicable repr => Alternable repr => Foldable repr =>
 354  repr a -> repr b -> repr [a]
 355 endBy p sep = many (p <* sep)
 356
 357 endBy1 ::
 358  Applicable repr => Alternable repr => Foldable repr =>
 359  repr a -> repr b -> repr [a]
 360 endBy1 p sep = some (p <* sep)
 361
 362 sepEndBy ::
 363  Applicable repr => Alternable repr => Foldable repr =>
 364  repr a -> repr b -> repr [a]
 365 sepEndBy p sep = option S.nil (sepEndBy1 p sep)
 366
 367 sepEndBy1 ::
 368  Applicable repr => Alternable repr => Foldable repr =>
 369  repr a -> repr b -> repr [a]
 370 sepEndBy1 p sep =
 371   let seb1 = p <**> (sep *> (S.flip S..@ S.cons <$> option S.nil seb1)
 372                  <|> pure (S.flip S..@ S.cons S..@ S.nil))
 373   in seb1
 374
 375 {-
 376 sepEndBy1 :: repr a -> repr b -> repr [a]
 377 sepEndBy1 p sep = newRegister_ S.id $ \acc ->
 378   let go = modify acc ((S.flip (S..)) S..@ S.cons <$> p)
 379          *> (sep *> (go <|> get acc) <|> get acc)
 380   in go <*> pure S.nil
 381 -}