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 'Unlift' repr, this setup avoids to define the method with boilerplate code when its default definition with lift* and 'unlift' 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.List as List
  16 import qualified Prelude as Pre
  17
  18 import Symantic.Base.Univariant
  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     Liftable repr => Applicable (Unlift repr) =>
  45     Hask.Haskell a -> repr a
  46   pure = 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     Liftable repr => Applicable (Unlift repr) =>
  52     repr (a -> b) -> repr a -> repr b
  53   (<*>) = 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     Liftable repr => Alternable (Unlift repr) =>
  87     repr a -> repr a -> repr a
  88   default empty ::
  89     Liftable repr => Alternable (Unlift repr) =>
  90     repr a
  91   default try ::
  92     Liftable repr => Alternable (Unlift repr) =>
  93     repr a -> repr a
  94   (<|>) = lift2 (<|>)
  95   empty = lift empty
  96   try = 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     Liftable repr => Selectable (Unlift repr) =>
 127     repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
 128   branch = lift3 branch
 129
 130 class Matchable repr where
 131   conditional ::
 132     Eq a => [Hask.Haskell (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b
 133   default conditional ::
 134     Unliftable repr => Liftable repr => Matchable (Unlift repr) =>
 135     Eq a => [Hask.Haskell (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b
 136   conditional cs bs = lift2 (conditional cs (unlift Pre.<$> bs))
 137
 138   match :: Eq a => [Hask.Haskell a] -> repr a -> (Hask.Haskell a -> repr b) -> repr b -> repr b
 139   match as a a2b = conditional (Hask.eq Pre.<$> as) (a2b Pre.<$> as) a
 140
 141 -- * Class 'Foldable'
 142 class Foldable repr where
 143   chainPre  :: repr (a -> a) -> repr a -> repr a
 144   chainPost :: repr a -> repr (a -> a) -> repr a
 145   default chainPre ::
 146     Liftable repr => Foldable (Unlift repr) =>
 147     repr (a -> a) -> repr a -> repr a
 148   default chainPost ::
 149     Liftable repr => Foldable (Unlift repr) =>
 150     repr a -> repr (a -> a) -> repr a
 151   chainPre = lift2 chainPre
 152   chainPost = lift2 chainPost
 153
 154 {-
 155 conditional :: Selectable repr => [(Hask.Haskell (a -> Bool), repr b)] -> repr a -> repr b -> repr b
 156 conditional cs p def = match p fs qs def
 157   where (fs, qs) = List.unzip cs
 158 -}
 159
 160 -- * Class 'Charable'
 161 class Charable repr where
 162   satisfy :: Hask.Haskell (Char -> Bool) -> repr Char
 163   default satisfy ::
 164     Liftable repr => Charable (Unlift repr) =>
 165     Hask.Haskell (Char -> Bool) -> repr Char
 166   satisfy = lift . satisfy
 167
 168 -- * Class 'Lookable'
 169 class Lookable repr where
 170   look :: repr a -> repr a
 171   negLook :: repr a -> repr ()
 172   default look :: Liftable repr => Lookable (Unlift repr) => repr a -> repr a
 173   default negLook :: Liftable repr => Lookable (Unlift repr) => repr a -> repr ()
 174   look = lift1 look
 175   negLook = lift1 negLook
 176
 177 {-# INLINE (<:>) #-}
 178 infixl 4 <:>
 179 (<:>) :: Applicable repr => repr a -> repr [a] -> repr [a]
 180 (<:>) = liftA2 Hask.cons
 181
 182 sequence :: Applicable repr => [repr a] -> repr [a]
 183 sequence = List.foldr (<:>) (pure Hask.nil)
 184
 185 traverse :: Applicable repr => (a -> repr b) -> [a] -> repr [b]
 186 traverse f = sequence . List.map f
 187  -- FIXME: Here hlint suggests to use Control.Monad.mapM,
 188  -- but at this point there is no mapM for our own sequence
 189
 190 repeat :: Applicable repr => Int -> repr a -> repr [a]
 191 repeat n p = traverse (const p) [1..n]
 192
 193 between :: Applicable repr => repr o -> repr c -> repr a -> repr a
 194 between open close p = open *> p <* close
 195
 196 string :: Applicable repr => Charable repr => String -> repr String
 197 string = traverse char
 198
 199 -- oneOf :: [Char] -> repr Char
 200 -- oneOf cs = satisfy (makeQ (flip elem cs) [||\c -> $$(ofChars cs [||c||])||])
 201
 202 noneOf :: Charable repr => String -> repr Char
 203 noneOf cs = satisfy (Hask.Haskell Hask.ValueCode{..})
 204   where
 205   value = Hask.Value (not . flip List.elem cs)
 206   code = Hask.Code [||\c -> not $$(ofChars cs [||c||])||]
 207
 208 ofChars :: String -> TExpQ Char -> TExpQ Bool
 209 ofChars = List.foldr (\c rest qc -> [|| c == $$qc || $$(rest qc) ||]) (const [||False||])
 210
 211 token :: Applicable repr => Alternable repr => Charable repr => String -> repr String
 212 token = try . string
 213
 214 eof :: Charable repr => Lookable repr => repr ()
 215 eof = negLook item
 216
 217 more :: Applicable repr => Charable repr => Lookable repr => repr ()
 218 more = look (void item)
 219
 220 char :: Applicable repr => Charable repr => Char -> repr Char
 221 char c = satisfy (Hask.eq (Hask.char c)) $> Hask.char c
 222
 223 item :: Charable repr => repr Char
 224 item = satisfy (Hask.const Hask..@ Hask.bool True)
 225
 226 -- Composite Combinators
 227 -- someTill :: repr a -> repr b -> repr [a]
 228 -- someTill p end = negLook end *> (p <:> manyTill p end)
 229
 230 void :: Applicable repr => repr a -> repr ()
 231 void p = p *> unit
 232
 233 unit :: Applicable repr => repr ()
 234 unit = pure Hask.unit
 235
 236 {-
 237
 238 constp :: Applicable repr => repr a -> repr (b -> a)
 239 constp = (Hask.const <$>)
 240
 241
 242 -- Alias Operations
 243 infixl 1 >>
 244 (>>) :: Applicable repr => repr a -> repr b -> repr b
 245 (>>) = (*>)
 246
 247 -- Monoidal Operations
 248
 249 infixl 4 <~>
 250 (<~>) :: Applicable repr => repr a -> repr b -> repr (a, b)
 251 (<~>) = liftA2 (Hask.runtime (,))
 252
 253 infixl 4 <~
 254 (<~) :: Applicable repr => repr a -> repr b -> repr a
 255 (<~) = (<*)
 256
 257 infixl 4 ~>
 258 (~>) :: Applicable repr => repr a -> repr b -> repr b
 259 (~>) = (*>)
 260
 261 -- Lift Operations
 262 liftA2 ::
 263  Applicable repr =>
 264  Hask.Haskell (a -> b -> c) -> repr a -> repr b -> repr c
 265 liftA2 f x = (<*>) (fmap f x)
 266
 267 liftA3 ::
 268  Applicable repr =>
 269  Hask.Haskell (a -> b -> c -> d) -> repr a -> repr b -> repr c -> repr d
 270 liftA3 f a b c = liftA2 f a b <*> c
 271
 272 -}
 273
 274 -- Parser Folds
 275 pfoldr ::
 276  Applicable repr => Foldable repr =>
 277  Hask.Haskell (a -> b -> b) -> Hask.Haskell b -> repr a -> repr b
 278 pfoldr f k p = chainPre (f <$> p) (pure k)
 279
 280 pfoldr1 ::
 281  Applicable repr => Foldable repr =>
 282  Hask.Haskell (a -> b -> b) -> Hask.Haskell b -> repr a -> repr b
 283 pfoldr1 f k p = f <$> p <*> pfoldr f k p
 284
 285 pfoldl ::
 286  Applicable repr => Foldable repr =>
 287  Hask.Haskell (b -> a -> b) -> Hask.Haskell b -> repr a -> repr b
 288 pfoldl f k p = chainPost (pure k) ((Hask.flip <$> pure f) <*> p)
 289
 290 pfoldl1 ::
 291  Applicable repr => Foldable repr =>
 292  Hask.Haskell (b -> a -> b) -> Hask.Haskell b -> repr a -> repr b
 293 pfoldl1 f k p = chainPost (f <$> pure k <*> p) ((Hask.flip <$> pure f) <*> p)
 294
 295 -- Chain Combinators
 296 chainl1' ::
 297  Applicable repr => Foldable repr =>
 298  Hask.Haskell (a -> b) -> repr a -> repr (b -> a -> b) -> repr b
 299 chainl1' f p op = chainPost (f <$> p) (Hask.flip <$> op <*> p)
 300
 301 chainl1 ::
 302  Applicable repr => Foldable repr =>
 303  repr a -> repr (a -> a -> a) -> repr a
 304 chainl1 = chainl1' Hask.id
 305
 306 {-
 307 chainr1' :: ParserOps rep => rep (a -> b) -> repr a -> repr (a -> b -> b) -> repr b
 308 chainr1' f p op = newRegister_ Hask.id $ \acc ->
 309   let go = bind p $ \x ->
 310            modify acc (Hask.flip (Hask..@) <$> (op <*> x)) *> go
 311        <|> f <$> x
 312   in go <**> get acc
 313
 314 chainr1 :: repr a -> repr (a -> a -> a) -> repr a
 315 chainr1 = chainr1' Hask.id
 316
 317 chainr :: repr a -> repr (a -> a -> a) -> Hask.Haskell a -> repr a
 318 chainr p op x = option x (chainr1 p op)
 319 -}
 320
 321 chainl ::
 322  Applicable repr => Alternable repr => Foldable repr =>
 323  repr a -> repr (a -> a -> a) -> Hask.Haskell a -> repr a
 324 chainl p op x = option x (chainl1 p op)
 325
 326 -- Derived Combinators
 327 many ::
 328  Applicable repr => Foldable repr =>
 329  repr a -> repr [a]
 330 many = pfoldr Hask.cons Hask.nil
 331
 332 manyN ::
 333  Applicable repr => Foldable repr =>
 334  Int -> repr a -> repr [a]
 335 manyN n p = List.foldr (const (p <:>)) (many p) [1..n]
 336
 337 some ::
 338  Applicable repr => Foldable repr =>
 339  repr a -> repr [a]
 340 some = manyN 1
 341
 342 skipMany ::
 343  Applicable repr => Foldable repr =>
 344  repr a -> repr ()
 345 --skipMany p = let skipManyp = p *> skipManyp <|> unit in skipManyp
 346 skipMany = void . pfoldl Hask.const Hask.unit -- the void here will encourage the optimiser to recognise that the register is unused
 347
 348 skipManyN ::
 349  Applicable repr => Foldable repr =>
 350  Int -> repr a -> repr ()
 351 skipManyN n p = List.foldr (const (p *>)) (skipMany p) [1..n]
 352
 353 skipSome ::
 354  Applicable repr => Foldable repr =>
 355  repr a -> repr ()
 356 skipSome = skipManyN 1
 357
 358 sepBy ::
 359  Applicable repr => Alternable repr => Foldable repr =>
 360  repr a -> repr b -> repr [a]
 361 sepBy p sep = option Hask.nil (sepBy1 p sep)
 362
 363 sepBy1 ::
 364  Applicable repr => Alternable repr => Foldable repr =>
 365  repr a -> repr b -> repr [a]
 366 sepBy1 p sep = p <:> many (sep *> p)
 367
 368 endBy ::
 369  Applicable repr => Alternable repr => Foldable repr =>
 370  repr a -> repr b -> repr [a]
 371 endBy p sep = many (p <* sep)
 372
 373 endBy1 ::
 374  Applicable repr => Alternable repr => Foldable repr =>
 375  repr a -> repr b -> repr [a]
 376 endBy1 p sep = some (p <* sep)
 377
 378 sepEndBy ::
 379  Applicable repr => Alternable repr => Foldable repr =>
 380  repr a -> repr b -> repr [a]
 381 sepEndBy p sep = option Hask.nil (sepEndBy1 p sep)
 382
 383 sepEndBy1 ::
 384  Applicable repr => Alternable repr => Foldable repr =>
 385  repr a -> repr b -> repr [a]
 386 sepEndBy1 p sep =
 387   let seb1 = p <**> (sep *> (Hask.flip Hask..@ Hask.cons <$> option Hask.nil seb1)
 388                  <|> pure (Hask.flip Hask..@ Hask.cons Hask..@ Hask.nil))
 389   in seb1
 390
 391 {-
 392 sepEndBy1 :: repr a -> repr b -> repr [a]
 393 sepEndBy1 p sep = newRegister_ Hask.id $ \acc ->
 394   let go = modify acc ((Hask.flip (Hask..)) Hask..@ Hask.cons <$> p)
 395          *> (sep *> (go <|> get acc) <|> get acc)
 396   in go <*> pure Hask.nil
 397 -}