Qualification.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Language.LOL.Typing.Type.Qualification where

import Data.Eq (Eq)
import qualified Data.Foldable as Foldable
import Data.Function (($), (.))
import Data.Functor (Functor(..), (<$>))
import qualified Data.List as List
import Data.Monoid (Monoid(..), (<>))
import Text.Show (Show(..))
import Data.Text.Buildable (Buildable(..))

import Language.LOL.Typing.Type.Monotype
import Language.LOL.Typing.Type.Substitution
import Language.LOL.Typing.Type.Quantification

-- * Type 'Qualification'

-- | A 'Qualification' introduces constraints on 'Monotype_Var's.
--
-- Example: the qualified 'Polytype': @forall a. Eq a => [a] -> [a]@
--          restricts @a@ to the members of the 'Class' @Eq@.
--
-- Example: @forall a b. (a ~ b) => a -> b@
-- could be an alternative formulation for the 'Polytype'
-- of the /identity function/.
data Qualification qs a
 =   Qualification
 {   qualifiers :: qs
 ,   qualified  :: a
 } deriving (Eq, Show)

-- | Qualify the 'subvars' of given 'a' (except those in given @context@)
-- with given @[qualifier]@.
qualify_but ::
 ( Substitutable qualifier
 , Substitutable a
 ) => [Monovar] -> [qualifier] -> a
 -> Qualification [qualifier] a
qualify_but vars_mono quals qualified =
	Qualification
	 { qualifiers = List.filter is_quantified quals
	 , qualified
	 }
	where
		vars_poly = subvars qualified List.\\ vars_mono
		is_quantified = Foldable.any (`List.elem` vars_poly) . subvars

instance Functor (Qualification qt) where
	fmap f q = q{qualified = f (qualified q)}
instance Buildable q => Buildable
 ( Quantification_Build_Options
 , Qualification [q] Monotype
 ) where
	build (_opts, q) = build q

instance
 ( Substitutable q
 , Substitutable a
 ) => Substitutable (Qualification q a) where
	subvars q = subvars (qualifiers q) `List.union` subvars (qualified q)
	sub `substitute` q = Qualification
	 { qualifiers = sub `substitute` qualifiers q
	 , qualified  = sub `substitute` qualified  q
	 }
instance (Has_Monotypes q, Has_Monotypes a) => Has_Monotypes (Qualification q a) where
	monotypes = monotypes . qualifiers
	monotypes_map f q = Qualification
	 { qualifiers = monotypes_map f $ qualifiers q
	 , qualified  = monotypes_map f $ qualified  q
	 }
instance (Buildable q, Buildable a)
 => Buildable (Qualification [q] a) where
	build Qualification{qualifiers, qualified} =
		(case qualifiers of
		 []  -> ""
		 [q] -> build q <> " => "
		 _   -> "(" <> mconcat (List.intersperse ", " $ build <$> qualifiers) <> ") => "
		) <>
		build qualified