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.Haskell 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.Haskell' 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.Haskell (a -> b) -> repr a -> repr b
  42   (<$>) f = (pure f <*>)
  43
  44   -- | Like '<$>' but with its arguments 'flip'-ped.
  45   (<&>) :: repr a -> H.Haskell (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.Haskell 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.Haskell b -> repr b
  54   ($>) = flip (<$)
  55
  56   -- | @('pure' a)@ parses the empty string, always succeeding in returning @(a)@.
  57   pure :: H.Haskell a -> repr a
  58   default pure ::
  59     Sym.Liftable repr => Applicable (Sym.Output repr) =>
  60     H.Haskell 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.Haskell (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.Haskell 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.Haskell 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.Haskell (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.Haskell (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.Haskell a] -> repr a -> (H.Haskell 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.Haskell (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.Haskell (tok -> Bool) -> repr tok
 203   default satisfy ::
 204     Sym.Liftable repr => Satisfiable (Sym.Output repr) tok =>
 205     [ErrorItem tok] ->
 206     H.Haskell (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   |  ErrorItemEnd
 214 deriving instance Eq tok => Eq (ErrorItem tok)
 215 deriving instance Ord tok => Ord (ErrorItem tok)
 216 deriving instance Show tok => Show (ErrorItem tok)
 217 deriving instance TH.Lift tok => TH.Lift (ErrorItem tok)
 218
 219 -- * Class 'Lookable'
 220 class Lookable repr where
 221   look :: repr a -> repr a
 222   negLook :: repr a -> repr ()
 223   default look :: Sym.Liftable1 repr => Lookable (Sym.Output repr) => repr a -> repr a
 224   default negLook :: Sym.Liftable1 repr => Lookable (Sym.Output repr) => repr a -> repr ()
 225   look = Sym.lift1 look
 226   negLook = Sym.lift1 negLook
 227
 228   eof :: repr ()
 229   eof = Sym.lift eof
 230   default eof :: Sym.Liftable repr => Lookable (Sym.Output repr) => repr ()
 231   -- eof = negLook (satisfy @_ @Char [ErrorItemAny] (H.const H..@ H.bool True))
 232              -- (item @_ @Char)
 233
 234 {-# INLINE (<:>) #-}
 235 infixl 4 <:>
 236 (<:>) :: Applicable repr => repr a -> repr [a] -> repr [a]
 237 (<:>) = liftA2 H.cons
 238
 239 sequence :: Applicable repr => [repr a] -> repr [a]
 240 sequence = List.foldr (<:>) (pure H.nil)
 241
 242 traverse :: Applicable repr => (a -> repr b) -> [a] -> repr [b]
 243 traverse f = sequence . List.map f
 244  -- FIXME: Here hlint suggests to use Control.Monad.mapM,
 245  -- but at this point there is no mapM for our own sequence
 246
 247 repeat :: Applicable repr => Int -> repr a -> repr [a]
 248 repeat n p = traverse (const p) [1..n]
 249
 250 between :: Applicable repr => repr o -> repr c -> repr a -> repr a
 251 between open close p = open *> p <* close
 252
 253 string :: Applicable repr => Satisfiable repr Char => [Char] -> repr [Char]
 254 string = traverse char
 255
 256 -- oneOf :: [Char] -> repr Char
 257 -- oneOf cs = satisfy [] (makeQ (flip elem cs) [||\c -> $$(ofChars cs [||c||])||])
 258
 259 noneOf :: TH.Lift tok => Eq tok => Satisfiable repr tok => [tok] -> repr tok
 260 noneOf cs = satisfy (ErrorItemToken Functor.<$> cs) (H.Haskell H.ValueCode{..})
 261   where
 262   value = H.Value (not . flip List.elem cs)
 263   code = [||\c -> not $$(ofChars cs [||c||])||]
 264
 265 ofChars :: TH.Lift tok => Eq tok => [tok] -> CodeQ tok -> CodeQ Bool
 266 ofChars = List.foldr (\c rest qc -> [|| c == $$qc || $$(rest qc) ||]) (const [||False||])
 267
 268 more :: Applicable repr => Satisfiable repr Char => Lookable repr => repr ()
 269 more = look (void (item @_ @Char))
 270
 271 char :: Applicable repr => Satisfiable repr Char => Char -> repr Char
 272 char c = satisfy [ErrorItemToken c] (H.eq (H.char c)) $> H.char c
 273
 274 anyChar :: Satisfiable repr Char => repr Char
 275 anyChar = satisfy [] (H.const H..@ H.bool True)
 276
 277 token ::
 278   TH.Lift tok => Eq tok => Applicable repr =>
 279   Satisfiable repr tok => tok -> repr tok
 280 token tok = satisfy [ErrorItemToken tok] (H.eq (H.char tok)) $> H.char tok
 281
 282 tokens ::
 283   TH.Lift tok => Eq tok => Applicable repr => Alternable repr =>
 284   Satisfiable repr tok => [tok] -> repr [tok]
 285 tokens = try . traverse token
 286
 287 item :: Satisfiable repr tok => repr tok
 288 item = satisfy [] (H.const H..@ H.bool True)
 289
 290 -- Composite Combinators
 291 -- someTill :: repr a -> repr b -> repr [a]
 292 -- someTill p end = negLook end *> (p <:> manyTill p end)
 293
 294 void :: Applicable repr => repr a -> repr ()
 295 void p = p *> unit
 296
 297 unit :: Applicable repr => repr ()
 298 unit = pure H.unit
 299
 300 {-
 301 constp :: Applicable repr => repr a -> repr (b -> a)
 302 constp = (H.const <$>)
 303
 304
 305 -- Alias Operations
 306 infixl 1 >>
 307 (>>) :: Applicable repr => repr a -> repr b -> repr b
 308 (>>) = (*>)
 309
 310 -- Monoidal Operations
 311
 312 infixl 4 <~>
 313 (<~>) :: Applicable repr => repr a -> repr b -> repr (a, b)
 314 (<~>) = liftA2 (H.runtime (,))
 315
 316 infixl 4 <~
 317 (<~) :: Applicable repr => repr a -> repr b -> repr a
 318 (<~) = (<*)
 319
 320 infixl 4 ~>
 321 (~>) :: Applicable repr => repr a -> repr b -> repr b
 322 (~>) = (*>)
 323
 324 -- Lift Operations
 325 liftA2 ::
 326  Applicable repr =>
 327  H.Haskell (a -> b -> c) -> repr a -> repr b -> repr c
 328 liftA2 f x = (<*>) (fmap f x)
 329
 330 liftA3 ::
 331  Applicable repr =>
 332  H.Haskell (a -> b -> c -> d) -> repr a -> repr b -> repr c -> repr d
 333 liftA3 f a b c = liftA2 f a b <*> c
 334
 335 -}
 336
 337 -- Parser Folds
 338 pfoldr ::
 339  Applicable repr => Foldable repr =>
 340  H.Haskell (a -> b -> b) -> H.Haskell b -> repr a -> repr b
 341 pfoldr f k p = chainPre (f <$> p) (pure k)
 342
 343 pfoldr1 ::
 344  Applicable repr => Foldable repr =>
 345  H.Haskell (a -> b -> b) -> H.Haskell b -> repr a -> repr b
 346 pfoldr1 f k p = f <$> p <*> pfoldr f k p
 347
 348 pfoldl ::
 349  Applicable repr => Foldable repr =>
 350  H.Haskell (b -> a -> b) -> H.Haskell b -> repr a -> repr b
 351 pfoldl f k p = chainPost (pure k) ((H.flip <$> pure f) <*> p)
 352
 353 pfoldl1 ::
 354  Applicable repr => Foldable repr =>
 355  H.Haskell (b -> a -> b) -> H.Haskell b -> repr a -> repr b
 356 pfoldl1 f k p = chainPost (f <$> pure k <*> p) ((H.flip <$> pure f) <*> p)
 357
 358 -- Chain Combinators
 359 chainl1' ::
 360  Applicable repr => Foldable repr =>
 361  H.Haskell (a -> b) -> repr a -> repr (b -> a -> b) -> repr b
 362 chainl1' f p op = chainPost (f <$> p) (H.flip <$> op <*> p)
 363
 364 chainl1 ::
 365  Applicable repr => Foldable repr =>
 366  repr a -> repr (a -> a -> a) -> repr a
 367 chainl1 = chainl1' H.id
 368
 369 {-
 370 chainr1' :: ParserOps rep => rep (a -> b) -> repr a -> repr (a -> b -> b) -> repr b
 371 chainr1' f p op = newRegister_ H.id $ \acc ->
 372   let go = bind p $ \x ->
 373            modify acc (H.flip (H..@) <$> (op <*> x)) *> go
 374        <|> f <$> x
 375   in go <**> get acc
 376
 377 chainr1 :: repr a -> repr (a -> a -> a) -> repr a
 378 chainr1 = chainr1' H.id
 379
 380 chainr :: repr a -> repr (a -> a -> a) -> H.Haskell a -> repr a
 381 chainr p op x = option x (chainr1 p op)
 382 -}
 383
 384 chainl ::
 385  Applicable repr => Alternable repr => Foldable repr =>
 386  repr a -> repr (a -> a -> a) -> H.Haskell a -> repr a
 387 chainl p op x = option x (chainl1 p op)
 388
 389 -- Derived Combinators
 390 many ::
 391  Applicable repr => Foldable repr =>
 392  repr a -> repr [a]
 393 many = pfoldr H.cons H.nil
 394
 395 manyN ::
 396  Applicable repr => Foldable repr =>
 397  Int -> repr a -> repr [a]
 398 manyN n p = List.foldr (const (p <:>)) (many p) [1..n]
 399
 400 some ::
 401  Applicable repr => Foldable repr =>
 402  repr a -> repr [a]
 403 some = manyN 1
 404
 405 skipMany ::
 406  Applicable repr => Foldable repr =>
 407  repr a -> repr ()
 408 --skipMany p = let skipManyp = p *> skipManyp <|> unit in skipManyp
 409 skipMany = void . pfoldl H.const H.unit -- the void here will encourage the optimiser to recognise that the register is unused
 410
 411 skipManyN ::
 412  Applicable repr => Foldable repr =>
 413  Int -> repr a -> repr ()
 414 skipManyN n p = List.foldr (const (p *>)) (skipMany p) [1..n]
 415
 416 skipSome ::
 417  Applicable repr => Foldable repr =>
 418  repr a -> repr ()
 419 skipSome = skipManyN 1
 420
 421 sepBy ::
 422  Applicable repr => Alternable repr => Foldable repr =>
 423  repr a -> repr b -> repr [a]
 424 sepBy p sep = option H.nil (sepBy1 p sep)
 425
 426 sepBy1 ::
 427  Applicable repr => Alternable repr => Foldable repr =>
 428  repr a -> repr b -> repr [a]
 429 sepBy1 p sep = p <:> many (sep *> p)
 430
 431 endBy ::
 432  Applicable repr => Alternable repr => Foldable repr =>
 433  repr a -> repr b -> repr [a]
 434 endBy p sep = many (p <* sep)
 435
 436 endBy1 ::
 437  Applicable repr => Alternable repr => Foldable repr =>
 438  repr a -> repr b -> repr [a]
 439 endBy1 p sep = some (p <* sep)
 440
 441 sepEndBy ::
 442  Applicable repr => Alternable repr => Foldable repr =>
 443  repr a -> repr b -> repr [a]
 444 sepEndBy p sep = option H.nil (sepEndBy1 p sep)
 445
 446 sepEndBy1 ::
 447  Applicable repr => Alternable repr => Foldable repr =>
 448  repr a -> repr b -> repr [a]
 449 sepEndBy1 p sep =
 450   let seb1 = p <**> (sep *> (H.flip H..@ H.cons <$> option H.nil seb1)
 451                  <|> pure (H.flip H..@ H.cons H..@ H.nil))
 452   in seb1
 453
 454 {-
 455 sepEndBy1 :: repr a -> repr b -> repr [a]
 456 sepEndBy1 p sep = newRegister_ H.id $ \acc ->
 457   let go = modify acc ((H.flip (H..)) H..@ H.cons <$> p)
 458          *> (sep *> (go <|> get acc) <|> get acc)
 459   in go <*> pure H.nil
 460 -}
 461
 462 {-
 463 -- Combinators interpreters for 'Sym.Any'.
 464 instance Applicable repr => Applicable (Sym.Any repr)
 465 instance Satisfiable repr => Satisfiable (Sym.Any repr)
 466 instance Alternable repr => Alternable (Sym.Any repr)
 467 instance Selectable repr => Selectable (Sym.Any repr)
 468 instance Matchable repr => Matchable (Sym.Any repr)
 469 instance Lookable repr => Lookable (Sym.Any repr)
 470 instance Foldable repr => Foldable (Sym.Any repr)
 471 -}