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 tok repr where
 206   satisfy :: [ErrorItem tok] -> TermGrammar (tok -> Bool) -> repr tok
 207   default satisfy ::
 208     Sym.Liftable repr => Satisfiable tok (Sym.Output repr) =>
 209     [ErrorItem tok] ->
 210     TermGrammar (tok -> Bool) -> repr tok
 211   satisfy es = Sym.lift . satisfy es
 212
 213   item :: repr tok
 214   item = satisfy [] (H.const H..@ H.bool True)
 215
 216 -- ** Type 'ErrorItem'
 217 data ErrorItem tok
 218   =  ErrorItemToken tok
 219   |  ErrorItemLabel String
 220   |  ErrorItemHorizon Int
 221   |  ErrorItemEnd
 222 deriving instance Eq tok => Eq (ErrorItem tok)
 223 deriving instance Ord tok => Ord (ErrorItem tok)
 224 deriving instance Show tok => Show (ErrorItem tok)
 225 deriving instance TH.Lift tok => TH.Lift (ErrorItem tok)
 226
 227 -- * Class 'Lookable'
 228 class Lookable repr where
 229   look :: repr a -> repr a
 230   negLook :: repr a -> repr ()
 231   default look :: Sym.Liftable1 repr => Lookable (Sym.Output repr) => repr a -> repr a
 232   default negLook :: Sym.Liftable1 repr => Lookable (Sym.Output repr) => repr a -> repr ()
 233   look = Sym.lift1 look
 234   negLook = Sym.lift1 negLook
 235
 236   eof :: repr ()
 237   eof = Sym.lift eof
 238   default eof :: Sym.Liftable repr => Lookable (Sym.Output repr) => repr ()
 239   -- eof = negLook (satisfy @Char [ErrorItemAny] (H.const H..@ H.bool True))
 240              -- (item @Char)
 241
 242 {-# INLINE (<:>) #-}
 243 infixl 4 <:>
 244 (<:>) :: Applicable repr => repr a -> repr [a] -> repr [a]
 245 (<:>) = liftA2 H.cons
 246
 247 sequence :: Applicable repr => [repr a] -> repr [a]
 248 sequence = List.foldr (<:>) (pure H.nil)
 249
 250 traverse :: Applicable repr => (a -> repr b) -> [a] -> repr [b]
 251 traverse f = sequence . List.map f
 252  -- FIXME: Here hlint suggests to use Control.Monad.mapM,
 253  -- but at this point there is no mapM for our own sequence
 254
 255 repeat :: Applicable repr => Int -> repr a -> repr [a]
 256 repeat n p = traverse (const p) [1..n]
 257
 258 between :: Applicable repr => repr o -> repr c -> repr a -> repr a
 259 between open close p = open *> p <* close
 260
 261 string ::
 262   Applicable repr => Alternable repr =>
 263   Satisfiable Char repr =>
 264   [Char] -> repr [Char]
 265 string = try . traverse char
 266
 267 oneOf ::
 268   TH.Lift tok => Eq tok =>
 269   Satisfiable tok repr =>
 270   [tok] -> repr tok
 271 oneOf ts = satisfy [ErrorItemLabel "oneOf"]
 272   (Sym.trans H.ValueCode
 273     { value = (`List.elem` ts)
 274     , code = [||\t -> $$(ofChars ts [||t||])||] })
 275
 276 noneOf ::
 277   TH.Lift tok => Eq tok =>
 278   Satisfiable tok repr =>
 279   [tok] -> repr tok
 280 noneOf cs = satisfy (ErrorItemToken Functor.<$> cs) (Sym.trans H.ValueCode
 281   { value = not . (`List.elem` cs)
 282   , code = [||\c -> not $$(ofChars cs [||c||])||]
 283   })
 284
 285 ofChars ::
 286   TH.Lift tok => Eq tok =>
 287   {-alternatives-}[tok] ->
 288   {-input-}TH.CodeQ tok ->
 289   TH.CodeQ Bool
 290 ofChars = List.foldr (\alt acc ->
 291   \inp -> [|| alt == $$inp || $$(acc inp) ||])
 292   (const [||False||])
 293
 294 more :: Applicable repr => Satisfiable Char repr => Lookable repr => repr ()
 295 more = look (void (item @Char))
 296
 297 char ::
 298   Applicable repr => Satisfiable Char repr =>
 299   Char -> repr Char
 300 char c = satisfy [ErrorItemToken c] (H.eq H..@ H.char c) $> H.char c
 301 -- char c = satisfy [ErrorItemToken c] (H.eq H..@ H.qual H..@ H.char c) $> H.char c
 302
 303 anyChar :: Satisfiable Char repr => repr Char
 304 anyChar = satisfy [] (H.const H..@ H.bool True)
 305
 306 token ::
 307   TH.Lift tok => Show tok => Eq tok =>
 308   Applicable repr => Satisfiable tok repr =>
 309   tok -> repr tok
 310 token tok = satisfy [ErrorItemToken tok] (H.eq H..@ H.char tok) $> H.char tok
 311 -- token tok = satisfy [ErrorItemToken tok] (H.eq H..@ H.qual H..@ H.char tok) $> H.char tok
 312
 313 tokens ::
 314   TH.Lift tok => Eq tok => Show tok =>
 315   Applicable repr => Alternable repr =>
 316   Satisfiable tok repr => [tok] -> repr [tok]
 317 tokens = try . traverse token
 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 -}