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