{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Primus.Error (
forceRight,
forceRightP,
fr,
frp,
fromList1,
fromList1P,
ne,
nep,
programmError,
normalError,
compileError,
lmsg,
(.@),
) where
import Control.Arrow
import Data.List.NonEmpty (NonEmpty (..))
import GHC.Stack
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
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
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
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
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
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
""
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
""
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
)
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
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
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
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
(.@) :: (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 .@