{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
module Distribution.Fields.Parser (
Field(..),
Name(..),
FieldLine(..),
SectionArg(..),
readFields,
readFields',
#ifdef CABAL_PARSEC_DEBUG
parseFile,
parseStr,
parseBS,
#endif
) where
import qualified Data.ByteString.Char8 as B8
import Data.Functor.Identity
import Distribution.Compat.Prelude
import Distribution.Fields.Field
import Distribution.Fields.Lexer
import Distribution.Fields.LexerMonad
(LexResult (..), LexState (..), LexWarning (..), unLex)
import Distribution.Parsec.Position (Position (..))
import Prelude ()
import Text.Parsec.Combinator hiding (eof, notFollowedBy)
import Text.Parsec.Error
import Text.Parsec.Pos
import Text.Parsec.Prim hiding (many, (<|>))
#ifdef CABAL_PARSEC_DEBUG
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
#endif
data LexState' = LexState' !LexState (LToken, LexState')
mkLexState' :: LexState -> LexState'
mkLexState' :: LexState -> LexState'
mkLexState' LexState
st = LexState -> (LToken, LexState') -> LexState'
LexState' LexState
st
(case forall a. Lex a -> LexState -> LexResult a
unLex Lex LToken
lexToken LexState
st of LexResult LexState
st' LToken
tok -> (LToken
tok, LexState -> LexState'
mkLexState' LexState
st'))
type Parser a = ParsecT LexState' () Identity a
instance Stream LexState' Identity LToken where
uncons :: LexState' -> Identity (Maybe (LToken, LexState'))
uncons (LexState' LexState
_ (LToken
tok, LexState'
st')) =
case LToken
tok of
L Position
_ Token
EOF -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
LToken
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (LToken
tok, LexState'
st'))
getLexerWarnings :: Parser [LexWarning]
getLexerWarnings :: Parser [LexWarning]
getLexerWarnings = do
LexState' (LexState { warnings :: LexState -> [LexWarning]
warnings = [LexWarning]
ws }) (LToken, LexState')
_ <- forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput
forall (m :: * -> *) a. Monad m => a -> m a
return [LexWarning]
ws
setLexerMode :: Int -> Parser ()
setLexerMode :: Int -> Parser ()
setLexerMode Int
code = do
LexState' LexState
ls (LToken, LexState')
_ <- forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput
forall (m :: * -> *) s u. Monad m => s -> ParsecT s u m ()
setInput forall a b. (a -> b) -> a -> b
$! LexState -> LexState'
mkLexState' LexState
ls { curCode :: Int
curCode = Int
code }
getToken :: (Token -> Maybe a) -> Parser a
getToken :: forall a. (Token -> Maybe a) -> Parser a
getToken Token -> Maybe a
getTok = forall a. (LToken -> Maybe a) -> Parser a
getTokenWithPos (\(L Position
_ Token
t) -> Token -> Maybe a
getTok Token
t)
getTokenWithPos :: (LToken -> Maybe a) -> Parser a
getTokenWithPos :: forall a. (LToken -> Maybe a) -> Parser a
getTokenWithPos LToken -> Maybe a
getTok = forall s (m :: * -> *) t a u.
Stream s m t =>
(t -> [Char])
-> (SourcePos -> t -> s -> SourcePos)
-> (t -> Maybe a)
-> ParsecT s u m a
tokenPrim (\(L Position
_ Token
t) -> Token -> [Char]
describeToken Token
t) SourcePos -> LToken -> LexState' -> SourcePos
updatePos LToken -> Maybe a
getTok
where
updatePos :: SourcePos -> LToken -> LexState' -> SourcePos
updatePos :: SourcePos -> LToken -> LexState' -> SourcePos
updatePos SourcePos
pos (L (Position Int
col Int
line) Token
_) LexState'
_ = [Char] -> Int -> Int -> SourcePos
newPos (SourcePos -> [Char]
sourceName SourcePos
pos) Int
col Int
line
describeToken :: Token -> String
describeToken :: Token -> [Char]
describeToken Token
t = case Token
t of
TokSym ByteString
s -> [Char]
"symbol " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ByteString
s
TokStr ByteString
s -> [Char]
"string " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ByteString
s
TokOther ByteString
s -> [Char]
"operator " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ByteString
s
Indent Int
_ -> [Char]
"new line"
TokFieldLine ByteString
_ -> [Char]
"field content"
Token
Colon -> [Char]
"\":\""
Token
OpenBrace -> [Char]
"\"{\""
Token
CloseBrace -> [Char]
"\"}\""
Token
EOF -> [Char]
"end of file"
LexicalError ByteString
is -> [Char]
"character in input " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (ByteString -> Char
B8.head ByteString
is)
tokSym :: Parser (Name Position)
tokSym', tokStr, tokOther :: Parser (SectionArg Position)
tokIndent :: Parser Int
tokColon, tokOpenBrace, tokCloseBrace :: Parser ()
tokFieldLine :: Parser (FieldLine Position)
tokSym :: Parser (Name Position)
tokSym = forall a. (LToken -> Maybe a) -> Parser a
getTokenWithPos forall a b. (a -> b) -> a -> b
$ \LToken
t -> case LToken
t of L Position
pos (TokSym ByteString
x) -> forall a. a -> Maybe a
Just (forall ann. ann -> ByteString -> Name ann
mkName Position
pos ByteString
x); LToken
_ -> forall a. Maybe a
Nothing
tokSym' :: Parser (SectionArg Position)
tokSym' = forall a. (LToken -> Maybe a) -> Parser a
getTokenWithPos forall a b. (a -> b) -> a -> b
$ \LToken
t -> case LToken
t of L Position
pos (TokSym ByteString
x) -> forall a. a -> Maybe a
Just (forall ann. ann -> ByteString -> SectionArg ann
SecArgName Position
pos ByteString
x); LToken
_ -> forall a. Maybe a
Nothing
tokStr :: Parser (SectionArg Position)
tokStr = forall a. (LToken -> Maybe a) -> Parser a
getTokenWithPos forall a b. (a -> b) -> a -> b
$ \LToken
t -> case LToken
t of L Position
pos (TokStr ByteString
x) -> forall a. a -> Maybe a
Just (forall ann. ann -> ByteString -> SectionArg ann
SecArgStr Position
pos ByteString
x); LToken
_ -> forall a. Maybe a
Nothing
tokOther :: Parser (SectionArg Position)
tokOther = forall a. (LToken -> Maybe a) -> Parser a
getTokenWithPos forall a b. (a -> b) -> a -> b
$ \LToken
t -> case LToken
t of L Position
pos (TokOther ByteString
x) -> forall a. a -> Maybe a
Just (forall ann. ann -> ByteString -> SectionArg ann
SecArgOther Position
pos ByteString
x); LToken
_ -> forall a. Maybe a
Nothing
tokIndent :: Parser Int
tokIndent = forall a. (Token -> Maybe a) -> Parser a
getToken forall a b. (a -> b) -> a -> b
$ \Token
t -> case Token
t of Indent Int
x -> forall a. a -> Maybe a
Just Int
x; Token
_ -> forall a. Maybe a
Nothing
tokColon :: Parser ()
tokColon = forall a. (Token -> Maybe a) -> Parser a
getToken forall a b. (a -> b) -> a -> b
$ \Token
t -> case Token
t of Token
Colon -> forall a. a -> Maybe a
Just (); Token
_ -> forall a. Maybe a
Nothing
tokOpenBrace :: Parser ()
tokOpenBrace = forall a. (Token -> Maybe a) -> Parser a
getToken forall a b. (a -> b) -> a -> b
$ \Token
t -> case Token
t of Token
OpenBrace -> forall a. a -> Maybe a
Just (); Token
_ -> forall a. Maybe a
Nothing
tokCloseBrace :: Parser ()
tokCloseBrace = forall a. (Token -> Maybe a) -> Parser a
getToken forall a b. (a -> b) -> a -> b
$ \Token
t -> case Token
t of Token
CloseBrace -> forall a. a -> Maybe a
Just (); Token
_ -> forall a. Maybe a
Nothing
tokFieldLine :: Parser (FieldLine Position)
tokFieldLine = forall a. (LToken -> Maybe a) -> Parser a
getTokenWithPos forall a b. (a -> b) -> a -> b
$ \LToken
t -> case LToken
t of L Position
pos (TokFieldLine ByteString
s) -> forall a. a -> Maybe a
Just (forall ann. ann -> ByteString -> FieldLine ann
FieldLine Position
pos ByteString
s); LToken
_ -> forall a. Maybe a
Nothing
colon, openBrace, closeBrace :: Parser ()
sectionArg :: Parser (SectionArg Position)
sectionArg :: Parser (SectionArg Position)
sectionArg = Parser (SectionArg Position)
tokSym' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (SectionArg Position)
tokStr forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (SectionArg Position)
tokOther forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"section parameter"
fieldSecName :: Parser (Name Position)
fieldSecName :: Parser (Name Position)
fieldSecName = Parser (Name Position)
tokSym forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"field or section name"
colon :: Parser ()
colon = Parser ()
tokColon forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"\":\""
openBrace :: Parser ()
openBrace = Parser ()
tokOpenBrace forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"\"{\""
closeBrace :: Parser ()
closeBrace = Parser ()
tokCloseBrace forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"\"}\""
fieldContent :: Parser (FieldLine Position)
fieldContent :: Parser (FieldLine Position)
fieldContent = Parser (FieldLine Position)
tokFieldLine forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"field contents"
newtype IndentLevel = IndentLevel Int
zeroIndentLevel :: IndentLevel
zeroIndentLevel :: IndentLevel
zeroIndentLevel = Int -> IndentLevel
IndentLevel Int
0
incIndentLevel :: IndentLevel -> IndentLevel
incIndentLevel :: IndentLevel -> IndentLevel
incIndentLevel (IndentLevel Int
i) = Int -> IndentLevel
IndentLevel (forall a. Enum a => a -> a
succ Int
i)
indentOfAtLeast :: IndentLevel -> Parser IndentLevel
indentOfAtLeast :: IndentLevel -> Parser IndentLevel
indentOfAtLeast (IndentLevel Int
i) = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ do
Int
j <- Parser Int
tokIndent
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
j forall a. Ord a => a -> a -> Bool
>= Int
i) forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"indentation of at least " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
i
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IndentLevel
IndentLevel Int
j)
newtype LexerMode = LexerMode Int
inLexerMode :: LexerMode -> Parser p -> Parser p
inLexerMode :: forall p. LexerMode -> Parser p -> Parser p
inLexerMode (LexerMode Int
mode) Parser p
p =
do Int -> Parser ()
setLexerMode Int
mode; p
x <- Parser p
p; Int -> Parser ()
setLexerMode Int
in_section; forall (m :: * -> *) a. Monad m => a -> m a
return p
x
cabalStyleFile :: Parser [Field Position]
cabalStyleFile :: Parser [Field Position]
cabalStyleFile = do [Field Position]
es <- IndentLevel -> Parser [Field Position]
elements IndentLevel
zeroIndentLevel
Parser ()
eof
forall (m :: * -> *) a. Monad m => a -> m a
return [Field Position]
es
elements :: IndentLevel -> Parser [Field Position]
elements :: IndentLevel -> Parser [Field Position]
elements IndentLevel
ilevel = forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (IndentLevel -> Parser (Field Position)
element IndentLevel
ilevel)
element :: IndentLevel -> Parser (Field Position)
element :: IndentLevel -> Parser (Field Position)
element IndentLevel
ilevel =
(do IndentLevel
ilevel' <- IndentLevel -> Parser IndentLevel
indentOfAtLeast IndentLevel
ilevel
Name Position
name <- Parser (Name Position)
fieldSecName
IndentLevel -> Name Position -> Parser (Field Position)
elementInLayoutContext (IndentLevel -> IndentLevel
incIndentLevel IndentLevel
ilevel') Name Position
name)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (do Name Position
name <- Parser (Name Position)
fieldSecName
Name Position -> Parser (Field Position)
elementInNonLayoutContext Name Position
name)
elementInLayoutContext :: IndentLevel -> Name Position -> Parser (Field Position)
elementInLayoutContext :: IndentLevel -> Name Position -> Parser (Field Position)
elementInLayoutContext IndentLevel
ilevel Name Position
name =
(do Parser ()
colon; IndentLevel -> Name Position -> Parser (Field Position)
fieldLayoutOrBraces IndentLevel
ilevel Name Position
name)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (do [SectionArg Position]
args <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser (SectionArg Position)
sectionArg
[Field Position]
elems <- IndentLevel -> Parser [Field Position]
sectionLayoutOrBraces IndentLevel
ilevel
forall (m :: * -> *) a. Monad m => a -> m a
return (forall ann.
Name ann -> [SectionArg ann] -> [Field ann] -> Field ann
Section Name Position
name [SectionArg Position]
args [Field Position]
elems))
elementInNonLayoutContext :: Name Position -> Parser (Field Position)
elementInNonLayoutContext :: Name Position -> Parser (Field Position)
elementInNonLayoutContext Name Position
name =
(do Parser ()
colon; Name Position -> Parser (Field Position)
fieldInlineOrBraces Name Position
name)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (do [SectionArg Position]
args <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser (SectionArg Position)
sectionArg
Parser ()
openBrace
[Field Position]
elems <- IndentLevel -> Parser [Field Position]
elements IndentLevel
zeroIndentLevel
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
optional Parser Int
tokIndent
Parser ()
closeBrace
forall (m :: * -> *) a. Monad m => a -> m a
return (forall ann.
Name ann -> [SectionArg ann] -> [Field ann] -> Field ann
Section Name Position
name [SectionArg Position]
args [Field Position]
elems))
fieldLayoutOrBraces :: IndentLevel -> Name Position -> Parser (Field Position)
fieldLayoutOrBraces :: IndentLevel -> Name Position -> Parser (Field Position)
fieldLayoutOrBraces IndentLevel
ilevel Name Position
name = Parser (Field Position)
braces forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Field Position)
fieldLayout
where
braces :: Parser (Field Position)
braces = do
Parser ()
openBrace
[FieldLine Position]
ls <- forall p. LexerMode -> Parser p -> Parser p
inLexerMode (Int -> LexerMode
LexerMode Int
in_field_braces) (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser (FieldLine Position)
fieldContent)
Parser ()
closeBrace
forall (m :: * -> *) a. Monad m => a -> m a
return (forall ann. Name ann -> [FieldLine ann] -> Field ann
Field Name Position
name [FieldLine Position]
ls)
fieldLayout :: Parser (Field Position)
fieldLayout = forall p. LexerMode -> Parser p -> Parser p
inLexerMode (Int -> LexerMode
LexerMode Int
in_field_layout) forall a b. (a -> b) -> a -> b
$ do
Maybe (FieldLine Position)
l <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe Parser (FieldLine Position)
fieldContent
[FieldLine Position]
ls <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (do IndentLevel
_ <- IndentLevel -> Parser IndentLevel
indentOfAtLeast IndentLevel
ilevel; Parser (FieldLine Position)
fieldContent)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe (FieldLine Position)
l of
Maybe (FieldLine Position)
Nothing -> forall ann. Name ann -> [FieldLine ann] -> Field ann
Field Name Position
name [FieldLine Position]
ls
Just FieldLine Position
l' -> forall ann. Name ann -> [FieldLine ann] -> Field ann
Field Name Position
name (FieldLine Position
l' forall a. a -> [a] -> [a]
: [FieldLine Position]
ls)
sectionLayoutOrBraces :: IndentLevel -> Parser [Field Position]
sectionLayoutOrBraces :: IndentLevel -> Parser [Field Position]
sectionLayoutOrBraces IndentLevel
ilevel =
(do Parser ()
openBrace
[Field Position]
elems <- IndentLevel -> Parser [Field Position]
elements IndentLevel
zeroIndentLevel
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
optional Parser Int
tokIndent
Parser ()
closeBrace
forall (m :: * -> *) a. Monad m => a -> m a
return [Field Position]
elems)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (IndentLevel -> Parser [Field Position]
elements IndentLevel
ilevel)
fieldInlineOrBraces :: Name Position -> Parser (Field Position)
fieldInlineOrBraces :: Name Position -> Parser (Field Position)
fieldInlineOrBraces Name Position
name =
(do Parser ()
openBrace
[FieldLine Position]
ls <- forall p. LexerMode -> Parser p -> Parser p
inLexerMode (Int -> LexerMode
LexerMode Int
in_field_braces) (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser (FieldLine Position)
fieldContent)
Parser ()
closeBrace
forall (m :: * -> *) a. Monad m => a -> m a
return (forall ann. Name ann -> [FieldLine ann] -> Field ann
Field Name Position
name [FieldLine Position]
ls))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (do [FieldLine Position]
ls <- forall p. LexerMode -> Parser p -> Parser p
inLexerMode (Int -> LexerMode
LexerMode Int
in_field_braces) (forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option [] (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\FieldLine Position
l -> [FieldLine Position
l]) Parser (FieldLine Position)
fieldContent))
forall (m :: * -> *) a. Monad m => a -> m a
return (forall ann. Name ann -> [FieldLine ann] -> Field ann
Field Name Position
name [FieldLine Position]
ls))
readFields :: B8.ByteString -> Either ParseError [Field Position]
readFields :: ByteString -> Either ParseError [Field Position]
readFields ByteString
s = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst (ByteString -> Either ParseError ([Field Position], [LexWarning])
readFields' ByteString
s)
readFields' :: B8.ByteString -> Either ParseError ([Field Position], [LexWarning])
readFields' :: ByteString -> Either ParseError ([Field Position], [LexWarning])
readFields' ByteString
s = do
forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
parse ParsecT LexState' () Identity ([Field Position], [LexWarning])
parser [Char]
"the input" LexState'
lexSt
where
parser :: ParsecT LexState' () Identity ([Field Position], [LexWarning])
parser = do
[Field Position]
fields <- Parser [Field Position]
cabalStyleFile
[LexWarning]
ws <- Parser [LexWarning]
getLexerWarnings
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Field Position]
fields, [LexWarning]
ws)
lexSt :: LexState'
lexSt = LexState -> LexState'
mkLexState' (ByteString -> LexState
mkLexState ByteString
s)
#ifdef CABAL_PARSEC_DEBUG
parseTest' :: Show a => Parsec LexState' () a -> SourceName -> B8.ByteString -> IO ()
parseTest' p fname s =
case parse p fname (lexSt s) of
Left err -> putStrLn (formatError s err)
Right x -> print x
where
lexSt = mkLexState' . mkLexState
parseFile :: Show a => Parser a -> FilePath -> IO ()
parseFile p f = B8.readFile f >>= \s -> parseTest' p f s
parseStr :: Show a => Parser a -> String -> IO ()
parseStr p = parseBS p . B8.pack
parseBS :: Show a => Parser a -> B8.ByteString -> IO ()
parseBS p = parseTest' p "<input string>"
formatError :: B8.ByteString -> ParseError -> String
formatError input perr =
unlines
[ "Parse error "++ show (errorPos perr) ++ ":"
, errLine
, indicator ++ errmsg ]
where
pos = errorPos perr
ls = lines' (T.decodeUtf8With T.lenientDecode input)
errLine = T.unpack (ls !! (sourceLine pos - 1))
indicator = replicate (sourceColumn pos) ' ' ++ "^"
errmsg = showErrorMessages "or" "unknown parse error"
"expecting" "unexpected" "end of file"
(errorMessages perr)
lines' :: T.Text -> [T.Text]
lines' s1
| T.null s1 = []
| otherwise = case T.break (\c -> c == '\r' || c == '\n') s1 of
(l, s2) | Just (c,s3) <- T.uncons s2
-> case T.uncons s3 of
Just ('\n', s4) | c == '\r' -> l : lines' s4
_ -> l : lines' s3
| otherwise -> [l]
#endif
eof :: Parser ()
eof :: Parser ()
eof = Parser LToken -> Parser ()
notFollowedBy forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m t
anyToken forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"end of file"
where
notFollowedBy :: Parser LToken -> Parser ()
notFollowedBy :: Parser LToken -> Parser ()
notFollowedBy Parser LToken
p = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ( (do L Position
_ Token
t <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parser LToken
p; forall s (m :: * -> *) t u a.
Stream s m t =>
[Char] -> ParsecT s u m a
unexpected (Token -> [Char]
describeToken Token
t))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return ())