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