src/Symantic/Parser/Grammar/Combinators.hs

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