{-# LANGUAGE GADTs #-}
-- | Defines Exceptions that can occur while using the call-alloy library

module Language.Alloy.Exceptions (
  CallAlloyException (..),
  AlloyLookupFailed (..),
  AlloyObjectNameMismatch (..),
  AlloyResponseFailure (..),
  UnexpectedAlloyRelation (..),
  Alternatives (..),
  Expected (..),
  Got (..),
  RelationName (..),
  ) where

import qualified Data.Map                         as M (keys)

import Control.Exception (
  Exception (fromException, toException),
  SomeException,
  )
import Data.List                        (intercalate)
import Data.Typeable                    (cast)
import Language.Alloy.Types (
  AlloyInstance,
  Signature (..),
  showSignature,
  )
import Text.Trifecta.Result             (ErrInfo)

data CallAlloyException where
  CallAlloyException :: Exception e => e -> CallAlloyException

instance Show CallAlloyException where
    show :: CallAlloyException -> String
show (CallAlloyException e
e) = e -> String
forall a. Show a => a -> String
show e
e

instance Exception CallAlloyException

alloyExceptionToException :: Exception e => e -> SomeException
alloyExceptionToException :: forall e. Exception e => e -> SomeException
alloyExceptionToException = CallAlloyException -> SomeException
forall e. Exception e => e -> SomeException
toException (CallAlloyException -> SomeException)
-> (e -> CallAlloyException) -> e -> SomeException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> CallAlloyException
forall e. Exception e => e -> CallAlloyException
CallAlloyException

alloyExceptionFromException :: Exception e => SomeException -> Maybe e
alloyExceptionFromException :: forall e. Exception e => SomeException -> Maybe e
alloyExceptionFromException SomeException
x = do
  CallAlloyException e
a <- SomeException -> Maybe CallAlloyException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
x
  e -> Maybe e
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
a

newtype AlloyResponseFailure
  = ParsingAlloyResponseFailed ErrInfo
  deriving Int -> AlloyResponseFailure -> ShowS
[AlloyResponseFailure] -> ShowS
AlloyResponseFailure -> String
(Int -> AlloyResponseFailure -> ShowS)
-> (AlloyResponseFailure -> String)
-> ([AlloyResponseFailure] -> ShowS)
-> Show AlloyResponseFailure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AlloyResponseFailure -> ShowS
showsPrec :: Int -> AlloyResponseFailure -> ShowS
$cshow :: AlloyResponseFailure -> String
show :: AlloyResponseFailure -> String
$cshowList :: [AlloyResponseFailure] -> ShowS
showList :: [AlloyResponseFailure] -> ShowS
Show

instance Exception AlloyResponseFailure where
  toException :: AlloyResponseFailure -> SomeException
toException = AlloyResponseFailure -> SomeException
forall e. Exception e => e -> SomeException
alloyExceptionToException
  fromException :: SomeException -> Maybe AlloyResponseFailure
fromException = SomeException -> Maybe AlloyResponseFailure
forall e. Exception e => SomeException -> Maybe e
alloyExceptionFromException

newtype Expected = Expected {Expected -> String
unExpected :: String}
newtype Got = Got {Got -> String
unGot :: String}

data AlloyObjectNameMismatch
  = AlloyObjectNameMismatch !Expected !Got

instance Show AlloyObjectNameMismatch where
  show :: AlloyObjectNameMismatch -> String
show (AlloyObjectNameMismatch Expected
expected Got
got)
    = String
"AlloyObjectNameMismatch: "
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"expected an object of name " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Expected -> String
unExpected Expected
expected
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" but got an object of name " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Got -> String
unGot Got
got

instance Exception AlloyObjectNameMismatch where
  toException :: AlloyObjectNameMismatch -> SomeException
toException = AlloyObjectNameMismatch -> SomeException
forall e. Exception e => e -> SomeException
alloyExceptionToException
  fromException :: SomeException -> Maybe AlloyObjectNameMismatch
fromException = SomeException -> Maybe AlloyObjectNameMismatch
forall e. Exception e => SomeException -> Maybe e
alloyExceptionFromException

newtype RelationName = RelationName {RelationName -> String
unRelationName :: String}
newtype Alternatives a = Alternatives {forall a. Alternatives a -> [a]
unAlternatives :: [a]}

data AlloyLookupFailed
  = LookupAlloySignatureFailed !Signature !AlloyInstance
  | LookupAlloyRelationFailed !RelationName !(Alternatives RelationName)

instance Show AlloyLookupFailed where
  show :: AlloyLookupFailed -> String
show (LookupAlloySignatureFailed Signature
s AlloyInstance
insta) = String
"LookupAlloySignatureFailed: "
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Signature -> String
showSignature Signature
s
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is missing in the Alloy instance"
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"; available are: \""
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\", " (Signature -> String
showSignature (Signature -> String) -> [Signature] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AlloyInstance -> [Signature]
forall k a. Map k a -> [k]
M.keys AlloyInstance
insta)
  show (LookupAlloyRelationFailed RelationName
rel Alternatives RelationName
xs) = String
"LookupAlloyRelationFailed: "
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"relation " String -> ShowS
forall a. [a] -> [a] -> [a]
++ RelationName -> String
unRelationName RelationName
rel
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is missing in the Alloy instance"
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"; available are: "
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((RelationName -> String) -> [RelationName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map RelationName -> String
unRelationName ([RelationName] -> [String]) -> [RelationName] -> [String]
forall a b. (a -> b) -> a -> b
$ Alternatives RelationName -> [RelationName]
forall a. Alternatives a -> [a]
unAlternatives Alternatives RelationName
xs)

instance Exception AlloyLookupFailed where
  toException :: AlloyLookupFailed -> SomeException
toException = AlloyLookupFailed -> SomeException
forall e. Exception e => e -> SomeException
alloyExceptionToException
  fromException :: SomeException -> Maybe AlloyLookupFailed
fromException = SomeException -> Maybe AlloyLookupFailed
forall e. Exception e => SomeException -> Maybe e
alloyExceptionFromException

data UnexpectedAlloyRelation
  = ExpectedIdenticalRelationship
  | ExpectedSingleRelationship
  | ExpectedDoubleRelationship
  | ExpectedTripleRelationship

instance Show UnexpectedAlloyRelation where
  show :: UnexpectedAlloyRelation -> String
show UnexpectedAlloyRelation
ExpectedIdenticalRelationship
    = String
"ExpectedIdenticalRelationship: "
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"Relation is (unexpectedly) not exactly a single element"
  show UnexpectedAlloyRelation
ExpectedSingleRelationship
    = String
"ExpectedSingleRelationship: "
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"Relation is (unexpectedly) a mapping"
  show UnexpectedAlloyRelation
ExpectedDoubleRelationship
    = String
"ExpectedDoubleRelationship: "
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"Relation is not a binary mapping"
  show UnexpectedAlloyRelation
ExpectedTripleRelationship
    = String
"ExpectedTripleRelationship: "
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"Relation is not a ternary mapping"

instance Exception UnexpectedAlloyRelation where
  toException :: UnexpectedAlloyRelation -> SomeException
toException = UnexpectedAlloyRelation -> SomeException
forall e. Exception e => e -> SomeException
alloyExceptionToException
  fromException :: SomeException -> Maybe UnexpectedAlloyRelation
fromException = SomeException -> Maybe UnexpectedAlloyRelation
forall e. Exception e => SomeException -> Maybe e
alloyExceptionFromException