{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE OverloadedStrings #-}

module Kempe.Error ( Error (..)
                   , mErr
                   ) where

import           Control.DeepSeq   (NFData)
import           Control.Exception (Exception)
import           Data.Semigroup    ((<>))
import           Data.Typeable     (Typeable)
import           GHC.Generics      (Generic)
import           Kempe.AST
import           Kempe.Name
import           Prettyprinter     (Pretty (pretty), comma, squotes, (<+>))

-- reject mutually recursive types? idk :p
data Error a = PoorScope a (Name a)
             | MismatchedLengths a (StackType a) (StackType a)
             | UnificationFailed a (KempeTy a) (KempeTy a) -- TODO: include atom expression?
             | TyVarExt a (Name a)
             | MonoFailed a
             | LessGeneral a (StackType a) (StackType a)
             | InvalidCExport a (Name a)
             | InvalidCImport a (Name a)
             | IllKinded a (KempeTy a)
             | BadType a
             | FatSumType a (TyName a)
             | InexhaustiveMatch a
             deriving ((forall x. Error a -> Rep (Error a) x)
-> (forall x. Rep (Error a) x -> Error a) -> Generic (Error a)
forall x. Rep (Error a) x -> Error a
forall x. Error a -> Rep (Error a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Error a) x -> Error a
forall a x. Error a -> Rep (Error a) x
$cto :: forall a x. Rep (Error a) x -> Error a
$cfrom :: forall a x. Error a -> Rep (Error a) x
Generic, Error a -> ()
(Error a -> ()) -> NFData (Error a)
forall a. NFData a => Error a -> ()
forall a. (a -> ()) -> NFData a
rnf :: Error a -> ()
$crnf :: forall a. NFData a => Error a -> ()
NFData)

mErr :: Maybe (Error ()) -> Either (Error ()) ()
mErr :: Maybe (Error ()) -> Either (Error ()) ()
mErr Maybe (Error ())
Nothing    = () -> Either (Error ()) ()
forall a b. b -> Either a b
Right ()
mErr (Just Error ()
err) = Error () -> Either (Error ()) ()
forall a b. a -> Either a b
Left Error ()
err

instance Show (Error a) where
    show :: Error a -> String
show = Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> (Error a -> Doc Any) -> Error a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error a -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty

instance Pretty (Error a) where
    pretty :: Error a -> Doc ann
pretty (PoorScope a
_ Name a
n)               = Doc ann
"name" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
squotes (Name a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Name a
n) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"not in scope"
    pretty (MismatchedLengths a
_ StackType a
st0 StackType a
st1) = Doc ann
"mismatched type lengths" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> StackType a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty StackType a
st0 Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
comma Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> StackType a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty StackType a
st1
    pretty (UnificationFailed a
_ KempeTy a
ty KempeTy a
ty')  = Doc ann
"could not unify type" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
squotes (KempeTy a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty KempeTy a
ty) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"with" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
squotes (KempeTy a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty KempeTy a
ty')
    pretty (TyVarExt a
_ Name a
n)                = Doc ann
"Error in function" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Name a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Name a
n Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
": type variables may not occur in external or exported functions."
    pretty (MonoFailed a
_)                = Doc ann
"Monomorphization step failed"
    pretty (LessGeneral a
_ StackType a
sty StackType a
sty')      = Doc ann
"Type" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> StackType a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty StackType a
sty' Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"is not as general as type" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> StackType a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty StackType a
sty
    pretty (InvalidCExport a
_ Name a
n)          = Doc ann
"C export" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Name a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Name a
n Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"has more than one return value"
    pretty (InvalidCImport a
_ Name a
n)          = Name a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Name a
n Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"imported functions can have at most one return value"
    pretty (IllKinded a
_ KempeTy a
ty)              = Doc ann
"Ill-kinded type:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
squotes (KempeTy a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty KempeTy a
ty) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
". Note that type variables have kind ⭑ in Kempe."
    pretty (BadType a
_)                   = Doc ann
"All types appearing in a signature must have kind ⭑"
    pretty (FatSumType a
_ Name a
tn)             = Doc ann
"Sum type" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Name a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Name a
tn Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"has too many constructors! Sum types are limited to 256 constructors in Kempe."
    pretty InexhaustiveMatch{}           = Doc ann
"Inexhaustive pattern match."

instance (Typeable a) => Exception (Error a)