{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

{- |
Module      : Primus.Error
Description : error methods
Copyright   : (c) Grant Weyburne, 2022
License     : BSD-3
-}
module Primus.Error (
  -- * force conversion from an Either
  forceRight,
  forceRightP,
  fr,
  frp,

  -- * force conversion from a nonempty list
  fromList1,
  fromList1P,
  ne,
  nep,

  -- * error types
  programmError,
  normalError,
  compileError,

  -- * decorate an error
  lmsg,

  -- * miscellaneous
  (.@),
) where

import Control.Arrow
import Data.List.NonEmpty (NonEmpty (..))
import GHC.Stack

-- | indicates a programmer error
programmError :: HasCallStack => String -> a
programmError :: String -> a
programmError String
s = (HasCallStack => a) -> a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => a) -> a) -> (HasCallStack => a) -> a
forall a b. (a -> b) -> a -> b
$ String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"programm error:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s

-- | indicates a user error
normalError :: HasCallStack => String -> a
normalError :: String -> a
normalError String
s = (HasCallStack => a) -> a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => a) -> a) -> (HasCallStack => a) -> a
forall a b. (a -> b) -> a -> b
$ String -> a
forall a. HasCallStack => String -> a
error String
s

-- | indicates a compiler error
compileError :: HasCallStack => String -> a
compileError :: String -> a
compileError String
s = (HasCallStack => a) -> a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => a) -> a) -> (HasCallStack => a) -> a
forall a b. (a -> b) -> a -> b
$ String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"should be a compile error (check the constraints):" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s

-- | unsafe force an error if 'Left'
forceRight :: HasCallStack => String -> Either String a -> a
forceRight :: String -> Either String a -> a
forceRight String
s = \case
  Left String
e -> (HasCallStack => a) -> a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => a) -> a) -> (HasCallStack => a) -> a
forall a b. (a -> b) -> a -> b
$ String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"forceRight:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" e=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e
  Right a
a -> a
a

-- | unsafe force an error if 'Left'
forceRightP :: HasCallStack => String -> Either String a -> a
forceRightP :: String -> Either String a -> a
forceRightP String
s = \case
  Left String
e -> (HasCallStack => a) -> a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => a) -> a) -> (HasCallStack => a) -> a
forall a b. (a -> b) -> a -> b
$ String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"programmer error:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" e=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e
  Right a
a -> a
a

-- | unsafe force an error if 'Left'
fr :: HasCallStack => Either String a -> a
fr :: Either String a -> a
fr = String -> Either String a -> a
forall a. HasCallStack => String -> Either String a -> a
forceRight String
""

-- | unsafe force an error if 'Left'
frp :: HasCallStack => Either String a -> a
frp :: Either String a -> a
frp = String -> Either String a -> a
forall a. HasCallStack => String -> Either String a -> a
forceRightP String
""

-- | prepend an error message
lmsg :: String -> Either String a -> Either String a
lmsg :: String -> Either String a -> Either String a
lmsg String
s =
  (String -> String) -> Either String a -> Either String a
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left
    ( \String
e -> case String
s of
        [] -> String
e
        Char
_ : String
_ -> String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
e
    )

-- | unsafe conversion from list to a nonempty list
ne :: HasCallStack => [a] -> NonEmpty a
ne :: [a] -> NonEmpty a
ne =
  \case
    [] -> String -> NonEmpty a
forall a. HasCallStack => String -> a
normalError String
"ne:list is empty"
    a
x : [a]
xs -> a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
xs

-- | unsafe conversion from list to a nonempty list
nep :: HasCallStack => [a] -> NonEmpty a
nep :: [a] -> NonEmpty a
nep =
  \case
    [] -> String -> NonEmpty a
forall a. HasCallStack => String -> a
programmError String
"nep:list is empty"
    a
x : [a]
xs -> a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
xs

-- | unsafe conversion from list to a nonempty list
fromList1 :: HasCallStack => String -> [a] -> NonEmpty a
fromList1 :: String -> [a] -> NonEmpty a
fromList1 String
msg =
  \case
    [] -> String -> NonEmpty a
forall a. HasCallStack => String -> a
normalError (String -> NonEmpty a) -> String -> NonEmpty a
forall a b. (a -> b) -> a -> b
$ String
"fromList1:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
    a
x : [a]
xs -> a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
xs

-- | unsafe conversion from list to a nonempty list
fromList1P :: HasCallStack => String -> [a] -> NonEmpty a
fromList1P :: String -> [a] -> NonEmpty a
fromList1P String
msg =
  \case
    [] -> String -> NonEmpty a
forall a. HasCallStack => String -> a
programmError (String -> NonEmpty a) -> String -> NonEmpty a
forall a b. (a -> b) -> a -> b
$ String
"fromList1P:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
    a
x : [a]
xs -> a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
xs

-- | compose a two arg function followed by a one arg function
(.@) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
.@ :: (c -> d) -> (a -> b -> c) -> a -> b -> d
(.@) = ((b -> c) -> b -> d) -> (a -> b -> c) -> a -> b -> d
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) (((b -> c) -> b -> d) -> (a -> b -> c) -> a -> b -> d)
-> ((c -> d) -> (b -> c) -> b -> d)
-> (c -> d)
-> (a -> b -> c)
-> a
-> b
-> d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c -> d) -> (b -> c) -> b -> d
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)

infixr 8 .@