src/Symantic/Parser/Grammar/Combinators.hs

   1 {-# LANGUAGE DefaultSignatures #-}
   2 -- The default type signature of type class methods are changed to introduce a Liftable constraint and the same type class but on the 'Unlift' repr, this setup avoids to define the method with boilerplate code when its default definition with lift* and 'unlift' does what is expected by an instance of the type class. This is almost as explained in: https://ro-che.info/articles/2016-02-03-finally-tagless-boilerplate
   3 {-# LANGUAGE TemplateHaskell #-}
   4 module Symantic.Parser.Grammar.Combinators where
   5
   6 import Data.Bool (Bool(..), not, (||))
   7 import Data.Char (Char)
   8 import Data.Either (Either(..))
   9 import Data.Eq (Eq(..))
  10 import Data.Function ((.), flip, const)
  11 import Data.Int (Int)
  12 import Data.Maybe (Maybe(..))
  13 import Data.String (String)
  14 import Language.Haskell.TH (TExpQ)
  15 import qualified Data.List as List
  16 import qualified Prelude as Pre
  17
  18 import Symantic.Base.Univariant
  19 import qualified Symantic.Parser.Staging as Hask
  20
  21 -- * Class 'Applicable'
  22 -- | This is like the usual 'Functor' and 'Applicative' type classes from the @base@ package, but using @('Hask.Runtime' a)@ instead of just @(a)@ to be able to use and pattern match on some usual terms of type @(a)@ (like 'Hask.id') and thus apply some optimizations.
  23 -- @(repr)@ , for "representation", is the usual tagless-final abstraction over the many semantics that this syntax (formed by the methods of type class like this one) will be interpreted.
  24 class Applicable repr where
  25   -- | @(a2b '<$>' ra)@ parses like @(ra)@ but maps its returned value with @(a2b)@.
  26   (<$>) :: Hask.Runtime (a -> b) -> repr a -> repr b
  27   (<$>) f = (pure f <*>)
  28
  29   -- | Like '<$>' but with its arguments 'flip'-ped.
  30   (<&>) :: repr a -> Hask.Runtime (a -> b) -> repr b
  31   (<&>) = flip (<$>)
  32
  33   -- | @(a '<$' rb)@ parses like @(rb)@ but discards its returned value by replacing it with @(a)@.
  34   (<$) :: Hask.Runtime a -> repr b -> repr a
  35   (<$) x = (pure x <*)
  36
  37   -- | @(ra '$>' b)@ parses like @(ra)@ but discards its returned value by replacing it with @(b)@.
  38   ($>) :: repr a -> Hask.Runtime b -> repr b
  39   ($>) = flip (<$)
  40
  41   -- | @('pure' a)@ parses the empty string, always succeeding in returning @(a)@.
  42   pure :: Hask.Runtime a -> repr a
  43   default pure ::
  44     Liftable repr => Applicable (Unlift repr) =>
  45     Hask.Runtime a -> repr a
  46   pure = lift . pure
  47
  48   -- | @(ra2b '<*>' ra)@ parses sequentially @(ra2b)@ and then @(ra)@, and returns the application of the function returned by @(ra2b)@ to the value returned by @(ra)@.
  49   (<*>) :: repr (a -> b) -> repr a -> repr b
  50   default (<*>) ::
  51     Liftable repr => Applicable (Unlift repr) =>
  52     repr (a -> b) -> repr a -> repr b
  53   (<*>) = lift2 (<*>)
  54
  55   -- | @('liftA2' a2b2c ra rb)@ parses sequentially @(ra)@ and then @(rb)@, and returns the application of @(a2b2c)@ to the values returned by those parsers.
  56   liftA2 :: Hask.Runtime (a -> b -> c) -> repr a -> repr b -> repr c
  57   liftA2 f x = (<*>) (f <$> x)
  58
  59   -- | @(ra '<*' rb)@ parses sequentially @(ra)@ and then @(rb)@, and returns like @(ra)@, discarding the return value of @(rb)@.
  60   (<*) :: repr a -> repr b -> repr a
  61   (<*) = liftA2 Hask.const
  62
  63   -- | @(ra '*>' rb)@ parses sequentially @(ra)@ and then @(rb)@, and returns like @(rb)@, discarding the return value of @(ra)@.
  64   (*>) :: repr a -> repr b -> repr b
  65   x *> y = (Hask.id <$ x) <*> y
  66
  67   -- | Like '<*>' but with its arguments 'flip'-ped.
  68   (<**>) :: repr a -> repr (a -> b) -> repr b
  69   (<**>) = liftA2 (Hask.flip Hask..@ (Hask.$))
  70   {-
  71   (<**>) :: repr a -> repr (a -> b) -> repr b
  72   (<**>) = liftA2 (\a f -> f a)
  73   -}
  74 infixl 4 <$>, <&>, <$, $>, <*>, <*, *>, <**>
  75
  76 -- * Class 'Alternable'
  77 class Alternable repr where
  78   -- | @(rl '<|>' rr)@ parses @(rl)@ and return its return value or, if it fails, parses @(rr)@ from where @(rl)@ has left the input stream, and returns its return value.
  79   (<|>) :: repr a -> repr a -> repr a
  80   -- | @(empty)@ parses nothing, always failing to return a value.
  81   empty :: repr a
  82   -- | @('try' ra)@ records the input stream position, then parses like @(ra)@ and either returns its value it it succeeds or fails if it fails but with a reset of the input stream to the recorded position.
  83   -- Generally used on the first alternative: @('try' rl '<|>' rr)@.
  84   try :: repr a -> repr a
  85   default (<|>) ::
  86     Liftable repr => Alternable (Unlift repr) =>
  87     repr a -> repr a -> repr a
  88   default empty ::
  89     Liftable repr => Alternable (Unlift repr) =>
  90     repr a
  91   default try ::
  92     Liftable repr => Alternable (Unlift repr) =>
  93     repr a -> repr a
  94   (<|>) = lift2 (<|>)
  95   empty = lift empty
  96   try = lift1 try
  97   -- | Like @('<|>')@ but with different returning types for the alternatives, and a return value wrapped in an 'Either' accordingly.
  98   (<+>) :: Applicable repr => Alternable repr => repr a -> repr b -> repr (Either a b)
  99   p <+> q =
 100     Hask.Runtime (Hask.Eval Left) (Hask.Code [||Left||]) <$> p
 101     <|>
 102     Hask.Runtime (Hask.Eval Right) (Hask.Code [||Right||]) <$> q
 103 infixl 3 <|>, <+>
 104
 105 optionally :: Applicable repr => Alternable repr => repr a -> Hask.Runtime b -> repr b
 106 optionally p x = p $> x <|> pure x
 107
 108 optional :: Applicable repr => Alternable repr => repr a -> repr ()
 109 optional = flip optionally Hask.unit
 110
 111 option :: Applicable repr => Alternable repr => Hask.Runtime a -> repr a -> repr a
 112 option x p = p <|> pure x
 113
 114 choice :: Alternable repr => [repr a] -> repr a
 115 choice = List.foldr (<|>) empty
 116  -- FIXME: Here hlint suggests to use Data.Foldable.asum,
 117  -- but at this point there is no asum for our own (<|>)
 118
 119 maybeP :: Applicable repr => Alternable repr => repr a -> repr (Maybe a)
 120 maybeP p = option (Hask.Runtime (Hask.Eval Nothing) (Hask.Code [||Nothing||]))
 121                   (Hask.Runtime (Hask.Eval Just) (Hask.Code [||Just||]) <$> p)
 122
 123 manyTill :: Applicable repr => Alternable repr => repr a -> repr b -> repr [a]
 124 manyTill p end = let go = end $> Hask.nil <|> p <:> go in go
 125
 126 -- * Class 'Selectable'
 127 class Selectable repr where
 128   branch :: repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
 129   default branch ::
 130     Liftable repr => Selectable (Unlift repr) =>
 131     repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
 132   branch = lift3 branch
 133
 134 class Matchable repr where
 135   conditional ::
 136     Eq a => [Hask.Runtime (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b
 137   default conditional ::
 138     Unliftable repr => Liftable repr => Matchable (Unlift repr) =>
 139     Eq a => [Hask.Runtime (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b
 140   conditional cs bs = lift2 (conditional cs (unlift Pre.<$> bs))
 141
 142   match :: Eq a => [Hask.Runtime a] -> repr a -> (Hask.Runtime a -> repr b) -> repr b -> repr b
 143   match as a a2b = conditional (Hask.eq Pre.<$> as) (a2b Pre.<$> as) a
 144
 145 -- * Class 'Foldable'
 146 class Foldable repr where
 147   chainPre  :: repr (a -> a) -> repr a -> repr a
 148   chainPost :: repr a -> repr (a -> a) -> repr a
 149   default chainPre ::
 150     Liftable repr => Foldable (Unlift repr) =>
 151     repr (a -> a) -> repr a -> repr a
 152   default chainPost ::
 153     Liftable repr => Foldable (Unlift repr) =>
 154     repr a -> repr (a -> a) -> repr a
 155   chainPre = lift2 chainPre
 156   chainPost = lift2 chainPost
 157
 158 {-
 159 conditional :: Selectable repr => [(Hask.Runtime (a -> Bool), repr b)] -> repr a -> repr b -> repr b
 160 conditional cs p def = match p fs qs def
 161   where (fs, qs) = List.unzip cs
 162 -}
 163
 164 -- * Class 'Charable'
 165 class Charable repr where
 166   satisfy :: Hask.Runtime (Char -> Bool) -> repr Char
 167   default satisfy ::
 168     Liftable repr => Charable (Unlift repr) =>
 169     Hask.Runtime (Char -> Bool) -> repr Char
 170   satisfy = lift . satisfy
 171
 172 -- * Class 'Lookable'
 173 class Lookable repr where
 174   look :: repr a -> repr a
 175   negLook :: repr a -> repr ()
 176   default look :: Liftable repr => Lookable (Unlift repr) => repr a -> repr a
 177   default negLook :: Liftable repr => Lookable (Unlift repr) => repr a -> repr ()
 178   look = lift1 look
 179   negLook = lift1 negLook
 180
 181 {-# INLINE (<:>) #-}
 182 infixl 4 <:>
 183 (<:>) :: Applicable repr => repr a -> repr [a] -> repr [a]
 184 (<:>) = liftA2 Hask.cons
 185
 186 sequence :: Applicable repr => [repr a] -> repr [a]
 187 sequence = List.foldr (<:>) (pure Hask.nil)
 188
 189 traverse :: Applicable repr => (a -> repr b) -> [a] -> repr [b]
 190 traverse f = sequence . List.map f
 191  -- FIXME: Here hlint suggests to use Control.Monad.mapM,
 192  -- but at this point there is no mapM for our own sequence
 193
 194 repeat :: Applicable repr => Int -> repr a -> repr [a]
 195 repeat n p = traverse (const p) [1..n]
 196
 197 between :: Applicable repr => repr o -> repr c -> repr a -> repr a
 198 between open close p = open *> p <* close
 199
 200 string :: Applicable repr => Charable repr => String -> repr String
 201 string = traverse char
 202
 203 -- oneOf :: [Char] -> repr Char
 204 -- oneOf cs = satisfy (makeQ (flip elem cs) [||\c -> $$(ofChars cs [||c||])||])
 205
 206 noneOf :: Charable repr => String -> repr Char
 207 noneOf cs = satisfy (Hask.Runtime (Hask.Eval (not . flip List.elem cs)) (Hask.Code [||\c -> not $$(ofChars cs [||c||])||]))
 208
 209 ofChars :: String -> TExpQ Char -> TExpQ Bool
 210 ofChars = List.foldr (\c rest qc -> [|| c == $$qc || $$(rest qc) ||]) (const [||False||])
 211
 212 token :: Applicable repr => Alternable repr => Charable repr => String -> repr String
 213 token = try . string
 214
 215 eof :: Charable repr => Lookable repr => repr ()
 216 eof = negLook item
 217
 218 more :: Applicable repr => Charable repr => Lookable repr => repr ()
 219 more = look (void item)
 220
 221 char :: Applicable repr => Charable repr => Char -> repr Char
 222 char c = satisfy (Hask.eq (Hask.char c)) $> Hask.char c
 223
 224 item :: Charable repr => repr Char
 225 item = satisfy (Hask.const Hask..@ Hask.bool True)
 226
 227 -- Composite Combinators
 228 -- someTill :: repr a -> repr b -> repr [a]
 229 -- someTill p end = negLook end *> (p <:> manyTill p end)
 230
 231 void :: Applicable repr => repr a -> repr ()
 232 void p = p *> unit
 233
 234 unit :: Applicable repr => repr ()
 235 unit = pure Hask.unit
 236
 237 {-
 238
 239 constp :: Applicable repr => repr a -> repr (b -> a)
 240 constp = (Hask.const <$>)
 241
 242
 243 -- Alias Operations
 244 infixl 1 >>
 245 (>>) :: Applicable repr => repr a -> repr b -> repr b
 246 (>>) = (*>)
 247
 248 -- Monoidal Operations
 249
 250 infixl 4 <~>
 251 (<~>) :: Applicable repr => repr a -> repr b -> repr (a, b)
 252 (<~>) = liftA2 (Hask.runtime (,))
 253
 254 infixl 4 <~
 255 (<~) :: Applicable repr => repr a -> repr b -> repr a
 256 (<~) = (<*)
 257
 258 infixl 4 ~>
 259 (~>) :: Applicable repr => repr a -> repr b -> repr b
 260 (~>) = (*>)
 261
 262 -- Lift Operations
 263 liftA2 ::
 264  Applicable repr =>
 265  Hask.Runtime (a -> b -> c) -> repr a -> repr b -> repr c
 266 liftA2 f x = (<*>) (fmap f x)
 267
 268 liftA3 ::
 269  Applicable repr =>
 270  Hask.Runtime (a -> b -> c -> d) -> repr a -> repr b -> repr c -> repr d
 271 liftA3 f a b c = liftA2 f a b <*> c
 272
 273 -}
 274
 275 -- Parser Folds
 276 pfoldr ::
 277  Applicable repr => Foldable repr =>
 278  Hask.Runtime (a -> b -> b) -> Hask.Runtime b -> repr a -> repr b
 279 pfoldr f k p = chainPre (f <$> p) (pure k)
 280
 281 pfoldr1 ::
 282  Applicable repr => Foldable repr =>
 283  Hask.Runtime (a -> b -> b) -> Hask.Runtime b -> repr a -> repr b
 284 pfoldr1 f k p = f <$> p <*> pfoldr f k p
 285
 286 pfoldl ::
 287  Applicable repr => Foldable repr =>
 288  Hask.Runtime (b -> a -> b) -> Hask.Runtime b -> repr a -> repr b
 289 pfoldl f k p = chainPost (pure k) ((Hask.flip <$> pure f) <*> p)
 290
 291 pfoldl1 ::
 292  Applicable repr => Foldable repr =>
 293  Hask.Runtime (b -> a -> b) -> Hask.Runtime b -> repr a -> repr b
 294 pfoldl1 f k p = chainPost (f <$> pure k <*> p) ((Hask.flip <$> pure f) <*> p)
 295
 296 -- Chain Combinators
 297 chainl1' ::
 298  Applicable repr => Foldable repr =>
 299  Hask.Runtime (a -> b) -> repr a -> repr (b -> a -> b) -> repr b
 300 chainl1' f p op = chainPost (f <$> p) (Hask.flip <$> op <*> p)
 301
 302 chainl1 ::
 303  Applicable repr => Foldable repr =>
 304  repr a -> repr (a -> a -> a) -> repr a
 305 chainl1 = chainl1' Hask.id
 306
 307 {-
 308 chainr1' :: ParserOps rep => rep (a -> b) -> repr a -> repr (a -> b -> b) -> repr b
 309 chainr1' f p op = newRegister_ Hask.id $ \acc ->
 310   let go = bind p $ \x ->
 311            modify acc (Hask.flip (Hask..@) <$> (op <*> x)) *> go
 312        <|> f <$> x
 313   in go <**> get acc
 314
 315 chainr1 :: repr a -> repr (a -> a -> a) -> repr a
 316 chainr1 = chainr1' Hask.id
 317
 318 chainr :: repr a -> repr (a -> a -> a) -> Hask.Runtime a -> repr a
 319 chainr p op x = option x (chainr1 p op)
 320 -}
 321
 322 chainl ::
 323  Applicable repr => Alternable repr => Foldable repr =>
 324  repr a -> repr (a -> a -> a) -> Hask.Runtime a -> repr a
 325 chainl p op x = option x (chainl1 p op)
 326
 327 -- Derived Combinators
 328 many ::
 329  Applicable repr => Foldable repr =>
 330  repr a -> repr [a]
 331 many = pfoldr Hask.cons Hask.nil
 332
 333 manyN ::
 334  Applicable repr => Foldable repr =>
 335  Int -> repr a -> repr [a]
 336 manyN n p = List.foldr (const (p <:>)) (many p) [1..n]
 337
 338 some ::
 339  Applicable repr => Foldable repr =>
 340  repr a -> repr [a]
 341 some = manyN 1
 342
 343 skipMany ::
 344  Applicable repr => Foldable repr =>
 345  repr a -> repr ()
 346 --skipMany p = let skipManyp = p *> skipManyp <|> unit in skipManyp
 347 skipMany = void . pfoldl Hask.const Hask.unit -- the void here will encourage the optimiser to recognise that the register is unused
 348
 349 skipManyN ::
 350  Applicable repr => Foldable repr =>
 351  Int -> repr a -> repr ()
 352 skipManyN n p = List.foldr (const (p *>)) (skipMany p) [1..n]
 353
 354 skipSome ::
 355  Applicable repr => Foldable repr =>
 356  repr a -> repr ()
 357 skipSome = skipManyN 1
 358
 359 sepBy ::
 360  Applicable repr => Alternable repr => Foldable repr =>
 361  repr a -> repr b -> repr [a]
 362 sepBy p sep = option Hask.nil (sepBy1 p sep)
 363
 364 sepBy1 ::
 365  Applicable repr => Alternable repr => Foldable repr =>
 366  repr a -> repr b -> repr [a]
 367 sepBy1 p sep = p <:> many (sep *> p)
 368
 369 endBy ::
 370  Applicable repr => Alternable repr => Foldable repr =>
 371  repr a -> repr b -> repr [a]
 372 endBy p sep = many (p <* sep)
 373
 374 endBy1 ::
 375  Applicable repr => Alternable repr => Foldable repr =>
 376  repr a -> repr b -> repr [a]
 377 endBy1 p sep = some (p <* sep)
 378
 379 sepEndBy ::
 380  Applicable repr => Alternable repr => Foldable repr =>
 381  repr a -> repr b -> repr [a]
 382 sepEndBy p sep = option Hask.nil (sepEndBy1 p sep)
 383
 384 sepEndBy1 ::
 385  Applicable repr => Alternable repr => Foldable repr =>
 386  repr a -> repr b -> repr [a]
 387 sepEndBy1 p sep =
 388   let seb1 = p <**> (sep *> (Hask.flip Hask..@ Hask.cons <$> option Hask.nil seb1)
 389                  <|> pure (Hask.flip Hask..@ Hask.cons Hask..@ Hask.nil))
 390   in seb1
 391
 392 {-
 393 sepEndBy1 :: repr a -> repr b -> repr [a]
 394 sepEndBy1 p sep = newRegister_ Hask.id $ \acc ->
 395   let go = modify acc ((Hask.flip (Hask..)) Hask..@ Hask.cons <$> p)
 396          *> (sep *> (go <|> get acc) <|> get acc)
 397   in go <*> pure Hask.nil
 398 -}