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