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 (TExpQ)
  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 Hask
  25
  26 -- * Class 'Applicable'
  27 -- | This is like the usual 'Functor' and 'Applicative' type classes
  28 -- from the @base@ package, but using @('Hask.Haskell' a)@ instead of just @(a)@
  29 -- to be able to use and pattern match on some usual terms of type @(a)@ (like
  30 -- 'Hask.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   (<$>) :: Hask.Haskell (a -> b) -> repr a -> repr b
  37   (<$>) f = (pure f <*>)
  38
  39   -- | Like '<$>' but with its arguments 'flip'-ped.
  40   (<&>) :: repr a -> Hask.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   (<$) :: Hask.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 -> Hask.Haskell b -> repr b
  49   ($>) = flip (<$)
  50
  51   -- | @('pure' a)@ parses the empty string, always succeeding in returning @(a)@.
  52   pure :: Hask.Haskell a -> repr a
  53   default pure ::
  54     Sym.Liftable repr => Applicable (Sym.Output repr) =>
  55     Hask.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 :: Hask.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 Hask.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 = (Hask.id <$ x) <*> y
  81
  82   -- | Like '<*>' but with its arguments 'flip'-ped.
  83   (<**>) :: repr a -> repr (a -> b) -> repr b
  84   (<**>) = liftA2 (Hask.flip Hask..@ (Hask.$))
  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 = Hask.left <$> p <|> Hask.right <$> q
 120 infixl 3 <|>, <+>
 121
 122 optionally :: Applicable repr => Alternable repr => repr a -> Hask.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 Hask.unit
 127
 128 option :: Applicable repr => Alternable repr => Hask.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 Hask.nothing (Hask.just <$> p)
 138
 139 manyTill :: Applicable repr => Alternable repr => repr a -> repr b -> repr [a]
 140 manyTill p end = let go = end $> Hask.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 => [Hask.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 => [Hask.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 => [Hask.Haskell a] -> repr a -> (Hask.Haskell a -> repr b) -> repr b -> repr b
 160   match as a a2b = conditional (Hask.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   default chainPre ::
 167     Sym.Liftable2 repr => Foldable (Sym.Output repr) =>
 168     repr (a -> a) -> repr a -> repr a
 169   default chainPost ::
 170     Sym.Liftable2 repr => Foldable (Sym.Output repr) =>
 171     repr a -> repr (a -> a) -> repr a
 172   chainPre = Sym.lift2 chainPre
 173   chainPost = Sym.lift2 chainPost
 174
 175 {-
 176 conditional :: Selectable repr => [(Hask.Haskell (a -> Bool), repr b)] -> repr a -> repr b -> repr b
 177 conditional cs p def = match p fs qs def
 178   where (fs, qs) = List.unzip cs
 179 -}
 180
 181 -- * Class 'Charable'
 182 class Charable repr where
 183   satisfy :: Hask.Haskell (Char -> Bool) -> repr Char
 184   default satisfy ::
 185     Sym.Liftable repr => Charable (Sym.Output repr) =>
 186     Hask.Haskell (Char -> Bool) -> repr Char
 187   satisfy = Sym.lift . satisfy
 188
 189 -- * Class 'Lookable'
 190 class Lookable repr where
 191   look :: repr a -> repr a
 192   negLook :: repr a -> repr ()
 193   default look :: Sym.Liftable1 repr => Lookable (Sym.Output repr) => repr a -> repr a
 194   default negLook :: Sym.Liftable1 repr => Lookable (Sym.Output repr) => repr a -> repr ()
 195   look = Sym.lift1 look
 196   negLook = Sym.lift1 negLook
 197
 198 {-# INLINE (<:>) #-}
 199 infixl 4 <:>
 200 (<:>) :: Applicable repr => repr a -> repr [a] -> repr [a]
 201 (<:>) = liftA2 Hask.cons
 202
 203 sequence :: Applicable repr => [repr a] -> repr [a]
 204 sequence = List.foldr (<:>) (pure Hask.nil)
 205
 206 traverse :: Applicable repr => (a -> repr b) -> [a] -> repr [b]
 207 traverse f = sequence . List.map f
 208  -- FIXME: Here hlint suggests to use Control.Monad.mapM,
 209  -- but at this point there is no mapM for our own sequence
 210
 211 repeat :: Applicable repr => Int -> repr a -> repr [a]
 212 repeat n p = traverse (const p) [1..n]
 213
 214 between :: Applicable repr => repr o -> repr c -> repr a -> repr a
 215 between open close p = open *> p <* close
 216
 217 string :: Applicable repr => Charable repr => String -> repr String
 218 string = traverse char
 219
 220 -- oneOf :: [Char] -> repr Char
 221 -- oneOf cs = satisfy (makeQ (flip elem cs) [||\c -> $$(ofChars cs [||c||])||])
 222
 223 noneOf :: Charable repr => String -> repr Char
 224 noneOf cs = satisfy (Hask.Haskell Hask.ValueCode{..})
 225   where
 226   value = Hask.Value (not . flip List.elem cs)
 227   code = Hask.Code [||\c -> not $$(ofChars cs [||c||])||]
 228
 229 ofChars :: String -> TExpQ Char -> TExpQ Bool
 230 ofChars = List.foldr (\c rest qc -> [|| c == $$qc || $$(rest qc) ||]) (const [||False||])
 231
 232 token :: Applicable repr => Alternable repr => Charable repr => String -> repr String
 233 token = try . string
 234
 235 eof :: Charable repr => Lookable repr => repr ()
 236 eof = negLook item
 237
 238 more :: Applicable repr => Charable repr => Lookable repr => repr ()
 239 more = look (void item)
 240
 241 char :: Applicable repr => Charable repr => Char -> repr Char
 242 char c = satisfy (Hask.eq (Hask.char c)) $> Hask.char c
 243
 244 item :: Charable repr => repr Char
 245 item = satisfy (Hask.const Hask..@ Hask.bool True)
 246
 247 -- Composite Combinators
 248 -- someTill :: repr a -> repr b -> repr [a]
 249 -- someTill p end = negLook end *> (p <:> manyTill p end)
 250
 251 void :: Applicable repr => repr a -> repr ()
 252 void p = p *> unit
 253
 254 unit :: Applicable repr => repr ()
 255 unit = pure Hask.unit
 256
 257 {-
 258
 259 constp :: Applicable repr => repr a -> repr (b -> a)
 260 constp = (Hask.const <$>)
 261
 262
 263 -- Alias Operations
 264 infixl 1 >>
 265 (>>) :: Applicable repr => repr a -> repr b -> repr b
 266 (>>) = (*>)
 267
 268 -- Monoidal Operations
 269
 270 infixl 4 <~>
 271 (<~>) :: Applicable repr => repr a -> repr b -> repr (a, b)
 272 (<~>) = liftA2 (Hask.runtime (,))
 273
 274 infixl 4 <~
 275 (<~) :: Applicable repr => repr a -> repr b -> repr a
 276 (<~) = (<*)
 277
 278 infixl 4 ~>
 279 (~>) :: Applicable repr => repr a -> repr b -> repr b
 280 (~>) = (*>)
 281
 282 -- Lift Operations
 283 liftA2 ::
 284  Applicable repr =>
 285  Hask.Haskell (a -> b -> c) -> repr a -> repr b -> repr c
 286 liftA2 f x = (<*>) (fmap f x)
 287
 288 liftA3 ::
 289  Applicable repr =>
 290  Hask.Haskell (a -> b -> c -> d) -> repr a -> repr b -> repr c -> repr d
 291 liftA3 f a b c = liftA2 f a b <*> c
 292
 293 -}
 294
 295 -- Parser Folds
 296 pfoldr ::
 297  Applicable repr => Foldable repr =>
 298  Hask.Haskell (a -> b -> b) -> Hask.Haskell b -> repr a -> repr b
 299 pfoldr f k p = chainPre (f <$> p) (pure k)
 300
 301 pfoldr1 ::
 302  Applicable repr => Foldable repr =>
 303  Hask.Haskell (a -> b -> b) -> Hask.Haskell b -> repr a -> repr b
 304 pfoldr1 f k p = f <$> p <*> pfoldr f k p
 305
 306 pfoldl ::
 307  Applicable repr => Foldable repr =>
 308  Hask.Haskell (b -> a -> b) -> Hask.Haskell b -> repr a -> repr b
 309 pfoldl f k p = chainPost (pure k) ((Hask.flip <$> pure f) <*> p)
 310
 311 pfoldl1 ::
 312  Applicable repr => Foldable repr =>
 313  Hask.Haskell (b -> a -> b) -> Hask.Haskell b -> repr a -> repr b
 314 pfoldl1 f k p = chainPost (f <$> pure k <*> p) ((Hask.flip <$> pure f) <*> p)
 315
 316 -- Chain Combinators
 317 chainl1' ::
 318  Applicable repr => Foldable repr =>
 319  Hask.Haskell (a -> b) -> repr a -> repr (b -> a -> b) -> repr b
 320 chainl1' f p op = chainPost (f <$> p) (Hask.flip <$> op <*> p)
 321
 322 chainl1 ::
 323  Applicable repr => Foldable repr =>
 324  repr a -> repr (a -> a -> a) -> repr a
 325 chainl1 = chainl1' Hask.id
 326
 327 {-
 328 chainr1' :: ParserOps rep => rep (a -> b) -> repr a -> repr (a -> b -> b) -> repr b
 329 chainr1' f p op = newRegister_ Hask.id $ \acc ->
 330   let go = bind p $ \x ->
 331            modify acc (Hask.flip (Hask..@) <$> (op <*> x)) *> go
 332        <|> f <$> x
 333   in go <**> get acc
 334
 335 chainr1 :: repr a -> repr (a -> a -> a) -> repr a
 336 chainr1 = chainr1' Hask.id
 337
 338 chainr :: repr a -> repr (a -> a -> a) -> Hask.Haskell a -> repr a
 339 chainr p op x = option x (chainr1 p op)
 340 -}
 341
 342 chainl ::
 343  Applicable repr => Alternable repr => Foldable repr =>
 344  repr a -> repr (a -> a -> a) -> Hask.Haskell a -> repr a
 345 chainl p op x = option x (chainl1 p op)
 346
 347 -- Derived Combinators
 348 many ::
 349  Applicable repr => Foldable repr =>
 350  repr a -> repr [a]
 351 many = pfoldr Hask.cons Hask.nil
 352
 353 manyN ::
 354  Applicable repr => Foldable repr =>
 355  Int -> repr a -> repr [a]
 356 manyN n p = List.foldr (const (p <:>)) (many p) [1..n]
 357
 358 some ::
 359  Applicable repr => Foldable repr =>
 360  repr a -> repr [a]
 361 some = manyN 1
 362
 363 skipMany ::
 364  Applicable repr => Foldable repr =>
 365  repr a -> repr ()
 366 --skipMany p = let skipManyp = p *> skipManyp <|> unit in skipManyp
 367 skipMany = void . pfoldl Hask.const Hask.unit -- the void here will encourage the optimiser to recognise that the register is unused
 368
 369 skipManyN ::
 370  Applicable repr => Foldable repr =>
 371  Int -> repr a -> repr ()
 372 skipManyN n p = List.foldr (const (p *>)) (skipMany p) [1..n]
 373
 374 skipSome ::
 375  Applicable repr => Foldable repr =>
 376  repr a -> repr ()
 377 skipSome = skipManyN 1
 378
 379 sepBy ::
 380  Applicable repr => Alternable repr => Foldable repr =>
 381  repr a -> repr b -> repr [a]
 382 sepBy p sep = option Hask.nil (sepBy1 p sep)
 383
 384 sepBy1 ::
 385  Applicable repr => Alternable repr => Foldable repr =>
 386  repr a -> repr b -> repr [a]
 387 sepBy1 p sep = p <:> many (sep *> p)
 388
 389 endBy ::
 390  Applicable repr => Alternable repr => Foldable repr =>
 391  repr a -> repr b -> repr [a]
 392 endBy p sep = many (p <* sep)
 393
 394 endBy1 ::
 395  Applicable repr => Alternable repr => Foldable repr =>
 396  repr a -> repr b -> repr [a]
 397 endBy1 p sep = some (p <* sep)
 398
 399 sepEndBy ::
 400  Applicable repr => Alternable repr => Foldable repr =>
 401  repr a -> repr b -> repr [a]
 402 sepEndBy p sep = option Hask.nil (sepEndBy1 p sep)
 403
 404 sepEndBy1 ::
 405  Applicable repr => Alternable repr => Foldable repr =>
 406  repr a -> repr b -> repr [a]
 407 sepEndBy1 p sep =
 408   let seb1 = p <**> (sep *> (Hask.flip Hask..@ Hask.cons <$> option Hask.nil seb1)
 409                  <|> pure (Hask.flip Hask..@ Hask.cons Hask..@ Hask.nil))
 410   in seb1
 411
 412 {-
 413 sepEndBy1 :: repr a -> repr b -> repr [a]
 414 sepEndBy1 p sep = newRegister_ Hask.id $ \acc ->
 415   let go = modify acc ((Hask.flip (Hask..)) Hask..@ Hask.cons <$> p)
 416          *> (sep *> (go <|> get acc) <|> get acc)
 417   in go <*> pure Hask.nil
 418 -}
 419
 420 -- Combinators interpreters for 'Sym.Any'.
 421 instance Applicable repr => Applicable (Sym.Any repr)
 422 instance Charable repr => Charable (Sym.Any repr)
 423 instance Alternable repr => Alternable (Sym.Any repr)
 424 instance Selectable repr => Selectable (Sym.Any repr)
 425 instance Matchable repr => Matchable (Sym.Any repr)
 426 instance Lookable repr => Lookable (Sym.Any repr)
 427 instance Foldable repr => Foldable (Sym.Any repr)