{-# Language BlockArguments, TemplateHaskell, ViewPatterns #-}
{-|
Module      : Advent.Format
Description : Input file format quasiquoter
Copyright   : (c) Eric Mertens, 2018-2021
License     : ISC
Maintainer  : emertens@gmail.com

Usage: @[format|<day> <format string>|]@

When day is specified as @0@ the quasiquoter returns a pure
parser function. Otherwise day uses command line arguments
to find the input file and parses it as an IO action.

A format string can optionally be specified across multiple
lines. In this case the day number goes on the first line and
the pattern starts on the second line. All common leading white
space from all the remaining lines is trimmed off and newlines
are discarded (use @%n@ for matching newlines)

The following are identical:

@
example1 = [format|2021 1
    %s%n
    %s%n|]

example2 = [format|2021 1 %s%n%s%n|]
@

Patterns:

    * @%u@ unsigned integer as 'Int'
    * @%d@ signed integer as 'Int'
    * @%x@ unsigned hexadecimal as 'Int'
    * @%lu@ unsigned integer as 'Integer'
    * @%ld@ signed integer as 'Integer'
    * @%lx@ unsigned hexadecimal as 'Integer'
    * @%s@ non-empty list of non-space characters as 'String'
    * @%c@ single, non-newline character as 'Char'
    * @%a@ single ASCII letter as 'Char'
    * @%n@ single newline character
    * other characters match literally
    * use @%@ to escape literal matches of special characters
    * @\@A@ matches the names of the constructors of type @A@ as an @A@

Structures:

    * @p|q@ combine alternatives @p@ and @q@
    * @(pq)@ group subpattern @pq@
    * @p*@ zero-to-many repititions of @p@ as a '[]'
    * @p+@ one-to-many repititions of @p@ as a '[]'
    * @p&q@ zero-to-many repititions of @p@ separated by @q@ as a '[]'
    * @p!@ returns the characters that matched pattern @p@ as a 'String'

-}
module Advent.Format (format) where

import Advent.Format.Enum (enumCases)
import Advent.Format.Lexer (alexScanTokens, AlexPosn(..))
import Advent.Format.Parser (parseFormat, ParseError(..))
import Advent.Format.Show (showFormat, showToken)
import Advent.Format.Types (Format(..))
import Advent.Format.Utils
import Advent.Input (getRawInput)
import Advent.Prelude (countBy)
import Control.Applicative ((<|>), some)
import Control.Monad ((<=<), when, void)
import Data.Char (isDigit, isSpace, isUpper, isAsciiLower, isAsciiUpper, isHexDigit)
import Data.Maybe (listToMaybe)
import Language.Haskell.TH
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Numeric (readHex)
import Text.ParserCombinators.ReadP

parse :: String -> Q Format
parse :: String -> Q Format
parse String
txt =
  case [(AlexPosn, Token)] -> Either ParseError Format
parseFormat (String -> [(AlexPosn, Token)]
alexScanTokens String
txt) of
    Right Format
fmt                -> Format -> Q Format
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Format -> Format
simplify Format
fmt)
    Left (Unclosed AlexPosn
p)        -> AlexPosn -> String -> Q Format
forall a. AlexPosn -> String -> Q a
failAt AlexPosn
p String
"Unclosed parenthesis"
    Left (UnexpectedToken AlexPosn
p Token
t) -> AlexPosn -> String -> Q Format
forall a. AlexPosn -> String -> Q a
failAt AlexPosn
p (String
"Unexpected token " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Token -> String
showToken Token
t)
    Left ParseError
UnexpectedEOF       -> String -> Q Format
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Format parse error, unexpected end-of-input"

failAt :: AlexPosn -> String -> Q a
failAt :: forall a. AlexPosn -> String -> Q a
failAt (AlexPn Int
_ Int
line Int
col) String
msg = String -> Q a
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Format parse error at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
line String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
col String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg)

-- | Constructs an input parser. See "Advent.Format"
format :: QuasiQuoter
format :: QuasiQuoter
format = QuasiQuoter
  { quoteExp :: String -> Q Exp
quoteExp  = (Maybe (Int, Int) -> String -> Q Exp)
-> (Maybe (Int, Int), String) -> Q Exp
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe (Int, Int) -> String -> Q Exp
makeParser ((Maybe (Int, Int), String) -> Q Exp)
-> (String -> Q (Maybe (Int, Int), String)) -> String -> Q Exp
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> Q (Maybe (Int, Int), String)
prepare
  , quotePat :: String -> Q Pat
quotePat  = \String
_ -> String -> Q Pat
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"format: patterns not supported"
  , quoteType :: String -> Q Type
quoteType = Format -> Q Type
toType (Format -> Q Type) -> (String -> Q Format) -> String -> Q Type
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> Q Format
parse (String -> Q Format)
-> ((Maybe (Int, Int), String) -> String)
-> (Maybe (Int, Int), String)
-> Q Format
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Int, Int), String) -> String
forall a b. (a, b) -> b
snd ((Maybe (Int, Int), String) -> Q Format)
-> (String -> Q (Maybe (Int, Int), String)) -> String -> Q Format
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> Q (Maybe (Int, Int), String)
prepare
  , quoteDec :: String -> Q [Dec]
quoteDec  = String -> Q [Dec]
makeDecs
  }

prepare :: String -> Q (Maybe (Int, Int), String)
prepare :: String -> Q (Maybe (Int, Int), String)
prepare String
str =
  -- Git on Windows has a bad behavior where it can add \r to files
  case String -> [String]
lines ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char
'\r' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=) String
str) of
    []   -> String -> Q (Maybe (Int, Int), String)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Empty input format"
    [String
x]
      | Just (Maybe (Int, Int)
yd, String
str') <- String -> Maybe (Maybe (Int, Int), String)
splitLeader String
x -> (Maybe (Int, Int), String) -> Q (Maybe (Int, Int), String)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Int, Int)
yd, String
str')
      | Bool
otherwise -> String -> Q (Maybe (Int, Int), String)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Failed to parse single-line input pattern"
    String
x:[String]
xs
      | Just (Maybe (Int, Int)
yd, String
"") <- String -> Maybe (Maybe (Int, Int), String)
splitLeader String
x ->
        (Maybe (Int, Int), String) -> Q (Maybe (Int, Int), String)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Int, Int)
yd, (String -> String) -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
indent) [String]
xs1)
      where
        xs1 :: [String]
xs1    = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char
' ' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=)) [String]
xs
        indent :: Int
indent = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ((String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> (String -> String) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char
' 'Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==)) [String]
xs1)
    [String]
_ -> String -> Q (Maybe (Int, Int), String)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Failed to parse multi-line input pattern"

splitLeader :: String -> Maybe (Maybe (Int, Int), String)
splitLeader :: String -> Maybe (Maybe (Int, Int), String)
splitLeader (ReadS Int
forall a. Read a => ReadS a
reads -> [(Int
y,ReadS Int
forall a. Read a => ReadS a
reads -> [(Int
d, String
rest)])]) = (Maybe (Int, Int), String) -> Maybe (Maybe (Int, Int), String)
forall a. a -> Maybe a
Just ((Int, Int) -> Maybe (Int, Int)
forall a. a -> Maybe a
Just (Int
y, Int
d), (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char
' 'Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) String
rest)
splitLeader (ReadS String
lex   -> [(String
"-", String
rest)]) = (Maybe (Int, Int), String) -> Maybe (Maybe (Int, Int), String)
forall a. a -> Maybe a
Just (Maybe (Int, Int)
forall a. Maybe a
Nothing, (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char
' 'Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) String
rest)
splitLeader String
_ = Maybe (Maybe (Int, Int), String)
forall a. Maybe a
Nothing

makeDecs :: String -> DecsQ
makeDecs :: String -> Q [Dec]
makeDecs String
str =
 do fmt <- String -> Q Format
parse String
str
    [d|
      type Input = $(toType fmt)

      parseInput :: String -> Input
      parseInput str =
        case readP_to_S ($(toReadP fmt) <* eof) str of
          (x, _) : _ -> x
          _          -> error "bad input parse"

      getInput :: Int -> Int -> IO Input
      getInput y d = parseInput <$> getRawInput y d
      |]

makeParser :: Maybe (Int, Int) -> String -> ExpQ
makeParser :: Maybe (Int, Int) -> String -> Q Exp
makeParser Maybe (Int, Int)
mb String
str =
  do fmt <- String -> Q Format
parse String
str
     let formats = [| readP_to_S ($(Format -> Q Exp
toReadP Format
fmt) <* eof) |]
     let qf = [| maybe (error "bad input parse") fst . listToMaybe . $Q Exp
formats |]
     case mb of
       Maybe (Int, Int)
Nothing    -> Q Exp
qf
       Just (Int
y,Int
d) -> [| $Q Exp
qf <$> getRawInput y d |]

toReadP :: Format -> ExpQ
toReadP :: Format -> Q Exp
toReadP Format
s =
  case Format
s of
    Literal String
xs -> [| void (string xs) |]

    Gather Format
p
      | Format -> Bool
interesting Format
p -> [|         gather $(Format -> Q Exp
toReadP Format
p) |]
      | Bool
otherwise     -> [| fst <$> gather $(Format -> Q Exp
toReadP Format
p) |]

    Named String
n
      | Char -> Bool
isUpper (String -> Char
forall a. HasCallStack => [a] -> a
head String
n) -> String -> Q Exp
enumParser String
n
      | Bool
otherwise -> Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
n)

    Format
UnsignedInteger -> [| (read :: String -> Integer) <$>                                      munch1 isDigit  |]
    Format
SignedInteger   -> [| (read :: String -> Integer) <$> ((++) <$> option "" (string "-") <*> munch1 isDigit) |]
    Format
UnsignedInt     -> [| (read :: String -> Int    ) <$>                                      munch1 isDigit  |]
    Format
SignedInt       -> [| (read :: String -> Int    ) <$> ((++) <$> option "" (string "-") <*> munch1 isDigit) |]

    Format
HexInteger      -> [| (fst . head . readHex :: String -> Integer) <$> munch1 isHexDigit |]
    Format
HexInt          -> [| (fst . head . readHex :: String -> Int    ) <$> munch1 isHexDigit |]

    Format
Char      -> [| satisfy ('\n' /=) |]
    Format
Letter    -> [| satisfy (\x -> isAsciiLower x || isAsciiUpper x) |]
    Format
Word      -> [| some (satisfy (not . isSpace)) |]

    Many Format
x ->
     do Q Bool -> Q () -> Q ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Format -> Q Bool
acceptsEmpty Format
x) (String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Argument to * accepts ε: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Format -> String -> String
showFormat Int
0 Format
s String
""))
        if Format -> Bool
interesting Format
x then
          [| many $(Format -> Q Exp
toReadP Format
x) |]
        else
          [| void (many $(Format -> Q Exp
toReadP Format
x)) |]

    Some Format
x ->
     do Q Bool -> Q () -> Q ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Format -> Q Bool
acceptsEmpty Format
x) (String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Argument to + accepts ε: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Format -> String -> String
showFormat Int
0 Format
s String
""))
        if Format -> Bool
interesting Format
x then
          [| some $(Format -> Q Exp
toReadP Format
x) |]
        else
          [| void (some $(Format -> Q Exp
toReadP Format
x)) |]

    SepBy Format
x Format
y ->
     do Q Bool -> Q () -> Q ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((Format -> Q Bool) -> [Format] -> Q Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM Format -> Q Bool
acceptsEmpty [Format
x, Format
y]) (String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Both arguments to & accept ε: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Format -> String -> String
showFormat Int
0 Format
s String
""))
        if Format -> Bool
interesting Format
x then
          [| sepBy $(Format -> Q Exp
toReadP Format
x) $(Format -> Q Exp
toReadP Format
y) |]
        else
          [| void (sepBy $(Format -> Q Exp
toReadP Format
x) $(Format -> Q Exp
toReadP Format
y)) |]

    Alt Format
x Format
y
      | Bool
xi, Bool
yi    -> [| Left    <$> $Q Exp
xp <|> Right   <$> $Q Exp
yp |]
      | Bool
xi        -> [| Just    <$> $Q Exp
xp <|> Nothing <$  $Q Exp
yp |]
      |     Bool
yi    -> [| Nothing <$  $Q Exp
xp <|> Just    <$> $Q Exp
yp |]
      | Bool
otherwise -> [|             $Q Exp
xp <|>             $Q Exp
yp |]
      where
        xi :: Bool
xi = Format -> Bool
interesting Format
x
        yi :: Bool
yi = Format -> Bool
interesting Format
y
        xp :: Q Exp
xp = Format -> Q Exp
toReadP Format
x
        yp :: Q Exp
yp = Format -> Q Exp
toReadP Format
y

    Group Format
x -> Format -> Q Exp
toReadP Format
x

    Follow [Format]
xs ->
      case [(Format -> Bool
interesting Format
x, Format -> Q Exp
toReadP Format
x) | Format
x <- [Format]
xs] of
        [] -> [| pure () |]
        xxs :: [(Bool, Q Exp)]
xxs@((Bool
ix,Q Exp
x):[(Bool, Q Exp)]
xs)
          | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0    -> (Q Exp -> (Bool, Q Exp) -> Q Exp)
-> Q Exp -> [(Bool, Q Exp)] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> (Bool, Q Exp) -> Q Exp
forall {m :: * -> *} {a}. Quote m => m Exp -> (a, m Exp) -> m Exp
apply0 Q Exp
x [(Bool, Q Exp)]
xs
          | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1    -> (Q Exp -> (Bool, Q Exp) -> Q Exp)
-> Q Exp -> [(Bool, Q Exp)] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> (Bool, Q Exp) -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> (Bool, m Exp) -> m Exp
apply1 Q Exp
x [(Bool, Q Exp)]
xs
          | Bool
ix        -> (Q Exp -> (Bool, Q Exp) -> Q Exp)
-> Q Exp -> [(Bool, Q Exp)] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> (Bool, Q Exp) -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> (Bool, m Exp) -> m Exp
applyN [| $Q Exp
tup <$> $Q Exp
x |] [(Bool, Q Exp)]
xs
          | Bool
otherwise -> (Q Exp -> (Bool, Q Exp) -> Q Exp)
-> Q Exp -> [(Bool, Q Exp)] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> (Bool, Q Exp) -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> (Bool, m Exp) -> m Exp
applyN [| $Q Exp
tup <$  $Q Exp
x |] [(Bool, Q Exp)]
xs
          where
            tup :: Q Exp
tup            = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE (Int -> Name
tupleDataName Int
n)
            n :: Int
n              = ((Bool, Q Exp) -> Bool) -> [(Bool, Q Exp)] -> Int
forall (f :: * -> *) a. Foldable f => (a -> Bool) -> f a -> Int
countBy (Bool, Q Exp) -> Bool
forall a b. (a, b) -> a
fst [(Bool, Q Exp)]
xxs
            apply0 :: m Exp -> (a, m Exp) -> m Exp
apply0 m Exp
l (a
_,m Exp
r) = [| $m Exp
l *> $m Exp
r |]
            apply1 :: m Exp -> (Bool, m Exp) -> m Exp
apply1 m Exp
l (Bool
i,m Exp
r) = if Bool
i then [| $m Exp
l  *> $m Exp
r |] else [| $m Exp
l <* $m Exp
r |]
            applyN :: m Exp -> (Bool, m Exp) -> m Exp
applyN m Exp
l (Bool
i,m Exp
r) = if Bool
i then [| $m Exp
l <*> $m Exp
r |] else [| $m Exp
l <* $m Exp
r |]

toType :: Format -> TypeQ
toType :: Format -> Q Type
toType Format
fmt =
  case Format
fmt of
    Literal String
_ -> [t| () |]

    Gather Format
x
      | Format -> Bool
interesting Format
x -> [t| (String, $(Format -> Q Type
toType Format
x)) |]
      | Bool
otherwise     -> [t| String |]

    Named String
n
      | Char -> Bool
isUpper (String -> Char
forall a. HasCallStack => [a] -> a
head String
n) -> Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (String -> Name
mkName String
n)
      | Bool
otherwise -> String -> Q Type
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"toType: not implemented for variable yet"

    Format
UnsignedInteger -> [t| Integer |]
    Format
SignedInteger   -> [t| Integer |]
    Format
HexInteger      -> [t| Integer |]
    Format
UnsignedInt     -> [t| Int |]
    Format
SignedInt       -> [t| Int |]
    Format
HexInt          -> [t| Int |]

    Format
Char      -> [t| Char |]
    Format
Letter    -> [t| Char |]
    Format
Word      -> [t| String |]

    Many Format
x ->
     do Q Bool -> Q () -> Q ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Format -> Q Bool
acceptsEmpty Format
x) (String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Argument to * accepts ε: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Format -> String -> String
showFormat Int
0 Format
fmt String
""))
        if Format -> Bool
interesting Format
x then
          [t| [$(Format -> Q Type
toType Format
x)] |]
        else
          [t| () |]

    Some Format
x ->
     do Q Bool -> Q () -> Q ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Format -> Q Bool
acceptsEmpty Format
x) (String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Argument to + accepts ε: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Format -> String -> String
showFormat Int
0 Format
fmt String
""))
        if Format -> Bool
interesting Format
x then
          [t| [$(Format -> Q Type
toType Format
x)] |]
        else
          [t| () |]

    SepBy Format
x Format
y ->
     do Q Bool -> Q () -> Q ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((Format -> Q Bool) -> [Format] -> Q Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM Format -> Q Bool
acceptsEmpty [Format
x, Format
y]) (String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Both arguments to & accept ε: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Format -> String -> String
showFormat Int
0 Format
fmt String
""))
        if Format -> Bool
interesting Format
x then
          [t| [$(Format -> Q Type
toType Format
x)] |]
        else
          [t| () |]

    Alt Format
x Format
y
      | Bool
xi, Bool
yi    -> [t| Either $Q Type
xt $Q Type
yt |]
      | Bool
xi        -> [t| Maybe $Q Type
xt |]
      |     Bool
yi    -> [t| Maybe $Q Type
yt |]
      | Bool
otherwise -> [t| () |]
      where
        xi :: Bool
xi = Format -> Bool
interesting Format
x
        yi :: Bool
yi = Format -> Bool
interesting Format
y
        xt :: Q Type
xt = Format -> Q Type
toType Format
x
        yt :: Q Type
yt = Format -> Q Type
toType Format
y

    Group Format
x -> Format -> Q Type
toType Format
x

    Follow [Format]
xs ->
      case [Format -> Q Type
toType Format
x | Format
x <- [Format]
xs, Format -> Bool
interesting Format
x] of
        [] -> [t| () |]
        [Q Type
t] -> Q Type
t
        [Q Type]
ts -> (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Int -> Q Type
forall (m :: * -> *). Quote m => Int -> m Type
tupleT ([Q Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Q Type]
ts)) [Q Type]
ts

enumParser :: String -> ExpQ
enumParser :: String -> Q Exp
enumParser String
nameStr =
  do entries <- String -> Q [(Name, String)]
enumCases String
nameStr
     let parsers = [[| $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name) <$ string str |] | (Name
name, String
str) <- [(Name, String)]
entries]
     [| choice $(listE parsers) |]

whenM :: Monad m => m Bool -> m () -> m ()
whenM :: forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM m Bool
pm m ()
m = m Bool
pm m Bool -> (Bool -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
p -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
p m ()
m