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