src/Symantic/Parser/Grammar/Combinators.hs

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