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