Common.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Language.LOL.Typing.Solver.Common where

import Control.Monad (Monad(..))
import Data.Bool
import Data.Eq (Eq(..))
import Data.Functor (Functor(..))
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Text.Buildable (Buildable(..))
import Text.Show (Show(..))

-- * Class 'Information'

-- | An associated type constructor
-- to attach informations to a 'Constraint'
-- about why it exists.
--
-- NOTE: an 'Information' should be enough to construct
-- an error message if the 'Constraint' it is associated with
-- leads to an inconsistency.
class (Monad m, Buildable (Info m)) => Information m where
	type Info m

-- ** Class 'Infoable'
class Infoable a info where
	info_insert :: a -> info -> info

-- | A data type constructor to gather informations
-- from the 'Monad' stack of a solver.
-- data family Info (m :: * -> *)

-- ** Type 'Infoed'

-- | A data type to associate some @info@ to a value.
data Infoed info a
 =   Infoed
 {   information :: info
 ,   infoed :: a
 } deriving (Eq, Functor, Show)
instance (Buildable info, Buildable a) => Buildable (Infoed info a) where
	build Infoed { information, infoed } =
		build infoed <> " {- " <> build information <> " -}"

-- * Type 'Error'

-- | A data type constructor to gather errors
-- from the 'Monad' stack of a solver.
data family Error (m :: * -> *)

-- * Type 'Solver_Logable'

class Solver_Logable a m where
	log :: a -> m ()

-- * Class 'State'

class State st where
	state_name    :: st -> Text
	state_options :: st -> [Text]
	state_collect :: st -> [(Text, Text)]
	state_show    :: st -> Text
	
	-- state_show       = Text.pack . show
	state_options _  = []
	state_collect st = [(state_name st, state_show st)]

-- * Type 'Option'

data Option a
 =   Option
 {   option_current :: a
 ,   option_default :: a
 ,   option_description :: Text
 }

instance (Show a, Eq a) => Show (Option a) where
	show a =
		Text.unpack (option_description a)
		 <> ": "
		 <> show (option_current a)
		 <> show_default
		where
		show_default | option_current a == option_default a = " (default)"
		             | otherwise = ""
instance (Buildable a, Eq a) => Buildable (Option a) where
	build a =
		build (option_description a)
		 <> ": "
		 <> build (option_current a)
		 <> build_default
		where
		build_default | option_current a == option_default a = " (default)"
		              | otherwise = ""
instance Functor Option where
	fmap f a =
		a{ option_default = f (option_default a)
		 , option_current = f (option_current a) }

option :: a -> Text -> Option a
option a s =
	Option
	 { option_default     = a
	 , option_current     = a
	 , option_description = s
	 }