{-# LANGUAGE OverloadedStrings #-}

module Kempe.Error.Warning ( Warning (..)
                           ) where

import           Control.Exception (Exception)
import           Data.Semigroup    ((<>))
import           Data.Typeable     (Typeable)
import           Kempe.AST
import           Kempe.Name
import           Prettyprinter     (Pretty (pretty), squotes, (<+>))

data Warning a = NameClash a (Name a)
               | DoubleDip a (Atom a a) (Atom a a)
               | SwapBinary a (Atom a a) (Atom a a)
               | DoubleSwap a
               | DipAssoc a (Atom a a)
               | Identity a (Atom a a)
               | PushDrop a (Atom a a)

instance Pretty a => Pretty (Warning a) where
    pretty :: Warning a -> Doc ann
pretty (NameClash a
l Name a
x)     = a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
l Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" '" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Name a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Name a
x Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"' is defined more than once."
    pretty (DoubleDip a
l Atom a a
a Atom a a
a')  = a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
l Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Atom a a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Atom a a
a Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Atom a a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Atom a a
a' Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"could be written as a single dip()"
    pretty (SwapBinary a
l Atom a a
a Atom a a
a') = a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
l 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 (Doc ann
"swap" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Atom a a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Atom a a
a) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"is" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Atom a a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Atom a a
a'
    pretty (DoubleSwap a
l)      = a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
l Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"double swap"
    pretty (DipAssoc a
l Atom a a
a)      = a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
l Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"dip(" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Atom a a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Atom a a
a Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
")" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Atom a a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Atom a a
a Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"is equivalent to" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Atom a a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Atom a a
a Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Atom a a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Atom a a
a Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"by associativity"
    pretty (Identity a
l Atom a a
a)      = a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
l 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 (Doc ann
"dup" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Atom a a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Atom a a
a) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"is identity"
    pretty (PushDrop a
l Atom a a
a)      = a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
l 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 (Atom a a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Atom a a
a Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"drop") Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"is identity"

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

instance (Pretty a, Typeable a) => Exception (Warning a)