{-# LANGUAGE OverloadedStrings #-}

module Kempe.Check.TopLevel ( topLevelCheck
                            , Warning
                            ) where

import           Control.Applicative ((<|>))
import           Control.Exception   (Exception)
import           Data.Foldable       (toList)
import           Data.Foldable.Ext
import           Data.List           (group, sort)
import           Data.Maybe          (mapMaybe)
import           Data.Semigroup      ((<>))
import           Data.Typeable       (Typeable)
import           Kempe.AST
import           Kempe.Name
import           Prettyprinter       (Pretty (pretty))

data Warning a = NameClash a (Name 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."

topLevelCheck :: Declarations a c a -> Maybe (Warning a)
topLevelCheck :: Declarations a c a -> Maybe (Warning a)
topLevelCheck Declarations a c a
ds =
        [Name a] -> Maybe (Warning a)
forall a. [Name a] -> Maybe (Warning a)
checkNames (Declarations a c a -> [Name a]
forall a c. Declarations a c a -> [Name a]
collectNames Declarations a c a
ds)
    Maybe (Warning a) -> Maybe (Warning a) -> Maybe (Warning a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Name a] -> Maybe (Warning a)
forall a. [Name a] -> Maybe (Warning a)
checkNames (Declarations a c a -> [Name a]
forall a c b. Declarations a c b -> [Name b]
collectCons Declarations a c a
ds)

-- | Just checks function names and type names. Doesn't check constructors.
collectNames :: Declarations a c a -> [Name a]
collectNames :: Declarations a c a -> [Name a]
collectNames = (KempeDecl a c a -> Maybe (Name a))
-> Declarations a c a -> [Name a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe KempeDecl a c a -> Maybe (Name a)
forall b c. KempeDecl b c b -> Maybe (Name b)
collectDeclNames where
    collectDeclNames :: KempeDecl b c b -> Maybe (Name b)
collectDeclNames (FunDecl b
_ Name b
n [KempeTy b]
_ [KempeTy b]
_ [Atom c b]
_)   = Name b -> Maybe (Name b)
forall a. a -> Maybe a
Just Name b
n
    collectDeclNames (ExtFnDecl b
_ Name b
n [KempeTy b]
_ [KempeTy b]
_ ByteString
_) = Name b -> Maybe (Name b)
forall a. a -> Maybe a
Just Name b
n
    collectDeclNames Export{}              = Maybe (Name b)
forall a. Maybe a
Nothing
    collectDeclNames (TyDecl b
_ Name b
tn [Name b]
_ [(Name b, [KempeTy b])]
_)     = Name b -> Maybe (Name b)
forall a. a -> Maybe a
Just Name b
tn

collectCons :: Declarations a c b-> [Name b]
collectCons :: Declarations a c b -> [Name b]
collectCons = (KempeDecl a c b -> [Name b]) -> Declarations a c b -> [Name b]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap KempeDecl a c b -> [Name b]
forall a c b. KempeDecl a c b -> [TyName b]
collectDeclNames where
    collectDeclNames :: KempeDecl a c b -> [TyName b]
collectDeclNames (TyDecl a
_ TyName a
_ [TyName a]
_ [(TyName b, [KempeTy a])]
ls) = [TyName b] -> [TyName b]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ((TyName b, [KempeTy a]) -> TyName b
forall a b. (a, b) -> a
fst ((TyName b, [KempeTy a]) -> TyName b)
-> [(TyName b, [KempeTy a])] -> [TyName b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TyName b, [KempeTy a])]
ls)
    collectDeclNames KempeDecl a c b
_                 = []

checkNames :: [Name a] -> Maybe (Warning a)
checkNames :: [Name a] -> Maybe (Warning a)
checkNames [Name a]
ns = ([Name a] -> Maybe (Warning a)) -> [[Name a]] -> Maybe (Warning a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Alternative f) =>
(a -> f b) -> t a -> f b
foldMapAlternative [Name a] -> Maybe (Warning a)
forall a. [Name a] -> Maybe (Warning a)
announce ([Name a] -> [[Name a]]
forall a. Eq a => [a] -> [[a]]
group ([Name a] -> [[Name a]]) -> [Name a] -> [[Name a]]
forall a b. (a -> b) -> a -> b
$ [Name a] -> [Name a]
forall a. Ord a => [a] -> [a]
sort [Name a]
ns) -- maybe could be better idk
    where announce :: [Name a] -> Maybe (Warning a)
announce (Name a
_:Name a
y:[Name a]
_) = Warning a -> Maybe (Warning a)
forall a. a -> Maybe a
Just (Warning a -> Maybe (Warning a)) -> Warning a -> Maybe (Warning a)
forall a b. (a -> b) -> a -> b
$ a -> Name a -> Warning a
forall a. a -> Name a -> Warning a
NameClash (Name a -> a
forall a. Name a -> a
loc Name a
y) Name a
y
          announce [Name a]
_       = Maybe (Warning a)
forall a. Maybe a
Nothing

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)