{-
    BNF Converter: Haskell error monad
    Copyright (C) 2004-2007  Author:  Markus Forsberg, Peter Gammie,
                                      Aarne Ranta, Björn Bringert
    Copyright (C) 2019 Author: Andreas Abel

-}

{-# LANGUAGE OverloadedStrings #-}

module BNFC.Backend.Haskell.MkErrM where

import BNFC.PrettyPrint

mkErrM :: String -> Doc
mkErrM :: String -> Doc
mkErrM String
errMod = [Doc] -> Doc
vcat
    [ Doc
"{-# LANGUAGE CPP #-}"
    , Doc
""
    , Doc
"#if __GLASGOW_HASKELL__ >= 708"
    , Doc
"---------------------------------------------------------------------------"
    , Doc
"-- Pattern synonyms exist since ghc 7.8."
    , Doc
""
    , Doc
"-- | BNF Converter: Error Monad."
    , Doc
"--"
    , Doc
"-- Module for backwards compatibility."
    , Doc
"--"
    , Doc
"-- The generated parser now uses @'Either' String@ as error monad."
    , Doc
"-- This module defines a type synonym 'Err' and pattern synonyms"
    , Doc
"-- 'Bad' and 'Ok' for 'Left' and 'Right'."
    , Doc
""
    , Doc
"{-# LANGUAGE PatternSynonyms #-}"
    , Doc
"{-# LANGUAGE FlexibleInstances #-}"
    , Doc
""
    , Doc
"module" Doc -> Doc -> Doc
<+> String -> Doc
text String
errMod Doc -> Doc -> Doc
<+> Doc
"where"
    , Doc
""
    , Doc
"import Prelude             (id, const, Either(..), String)"
    , Doc
""
    , Doc
"import Control.Monad       (MonadPlus(..))"
    , Doc
"import Control.Applicative (Alternative(..))"
    , Doc
"#if __GLASGOW_HASKELL__ >= 808"
    , Doc
"import Control.Monad       (MonadFail(..))"
    , Doc
"#endif"
    , Doc
""
    , Doc
"-- | Error monad with 'String' error messages."
    , Doc
"type Err = Either String"
    , Doc
""
    , Doc
"pattern Bad msg = Left msg"
    , Doc
"pattern Ok  a   = Right a"
    , Doc
""
    , Doc
"#if __GLASGOW_HASKELL__ >= 808"
    , Doc
"instance MonadFail Err where"
    , Doc
"  fail = Bad"
    , Doc
"#endif"
    , Doc
""
    , Doc
"instance Alternative Err where"
    , Doc
"  empty           = Left \"Err.empty\""
    , Doc
"  (<|>) Left{}    = id"
    , Doc
"  (<|>) x@Right{} = const x"
    , Doc
""
    , Doc
"instance MonadPlus Err where"
    , Doc
"  mzero = empty"
    , Doc
"  mplus = (<|>)"
    , Doc
""
    , Doc
"#else"
    , Doc
"---------------------------------------------------------------------------"
    , Doc
"-- ghc 7.6 and before: use old definition as data type."
    , Doc
""
    , Doc
"-- | BNF Converter: Error Monad"
    , Doc
""
    , Doc
"-- Copyright (C) 2004  Author:  Aarne Ranta"
    , Doc
"-- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE."
    , Doc
""
    , Doc
"module" Doc -> Doc -> Doc
<+> String -> Doc
text String
errMod Doc -> Doc -> Doc
<+> Doc
"where"
    , Doc
""
    , Doc
"-- the Error monad: like Maybe type with error msgs"
    , Doc
""
    , Doc
"import Control.Applicative (Applicative(..), Alternative(..))"
    , Doc
"import Control.Monad       (MonadPlus(..), liftM)"
    , Doc
""
    , Doc
"data Err a = Ok a | Bad String"
    , Doc
"  deriving (Read, Show, Eq, Ord)"
    , Doc
""
    , Doc
"instance Monad Err where"
    , Doc
"  return      = Ok"
    , Doc
"  Ok a  >>= f = f a"
    , Doc
"  Bad s >>= _ = Bad s"
    , Doc
""
    , Doc
"instance Applicative Err where"
    , Doc
"  pure = Ok"
    , Doc
"  (Bad s) <*> _ = Bad s"
    , Doc
"  (Ok f) <*> o  = liftM f o"
    , Doc
""
    , Doc
"instance Functor Err where"
    , Doc
"  fmap = liftM"
    , Doc
""
    , Doc
"instance MonadPlus Err where"
    , Doc
"  mzero = Bad \"Err.mzero\""
    , Doc
"  mplus (Bad _) y = y"
    , Doc
"  mplus x       _ = x"
    , Doc
""
    , Doc
"instance Alternative Err where"
    , Doc
"  empty = mzero"
    , Doc
"  (<|>) = mplus"
    , Doc
""
    , Doc
"#endif"
    ]