{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Language.Symantic.Grammar.Meta where

import Data.Function (const)
import Data.Proxy (Proxy(..))
import Data.Typeable (Typeable)

-- * Type 'Gram_Reader'
class Gram_Reader st g where
	g_ask_before :: g (st -> a) -> g a
	g_ask_after  :: g (st -> a) -> g a

-- * Type 'Gram_State'
class Gram_State st g where
	g_state_before :: g (st -> (st, a)) -> g a
	g_state_after  :: g (st -> (st, a)) -> g a
	g_get_before   :: g (st -> a) -> g a
	g_get_after    :: g (st -> a) -> g a
	g_put          :: g (st, a) -> g a
	default g_get_before :: Functor g => g (st -> a) -> g a
	default g_get_after  :: Functor g => g (st -> a) -> g a
	default g_put        :: Functor g => g (st, a) -> g a
	g_get_before g = g_state_before ((\f st -> (st, f st)) <$> g)
	g_get_after  g = g_state_after ((\f st -> (st, f st)) <$> g)
	g_put        g = g_state_after ((\(st, a) -> const (st, a)) <$> g)

-- * Class 'Gram_Error'
-- | Symantics for handling errors at the semantic level (not the syntaxic one).
class Gram_Error err g where
	g_catch :: g (Either err a) -> g a

-- * Class 'Inj_Error'
class Inj_Error a b where
	inj_Error :: a -> b
instance Inj_Error err e => Inj_Error err (Either e a) where
	inj_Error = Left . inj_Error

lift_Error ::
 forall e0 err e1 a.
 Inj_Error e0 e1 =>
 Inj_Error e1 err =>
 Proxy e1 -> Either e0 a -> Either err a
lift_Error _e1 (Right a) = Right a
lift_Error _e1 (Left e)  = Left $ inj_Error @e1 @err $ inj_Error @e0 @e1 e

-- * Class 'Source'
class Source src where
	noSource :: src
instance Source () where
	noSource = ()

-- ** Class 'Inj_Source'
class Source src => Inj_Source a src where
	inj_Source :: a -> src
instance Inj_Source a () where
	inj_Source _ = ()

-- ** Type family 'SourceOf'
type family SourceOf a

-- ** Type 'Sourced'
class Source (SourceOf a) => Sourced a where
	sourceOf  :: a -> SourceOf a
	setSource :: a -> SourceOf a -> a
infixl 5 `setSource`

source :: Inj_Source src (SourceOf a) => Sourced a => a -> src -> a
source a src = a `setSource` inj_Source src

-- ** Type 'Source_Input'
type family Source_Input (src :: *) :: *
type instance Source_Input () = ()

-- ** Type 'Span'
data Span src
 =   Span
 {   spanBegin :: !src
 ,   spanEnd   :: !src
 } deriving (Eq, Ord, Show, Typeable)

-- ** Class 'Gram_Source'
class
 ( Gram_Reader (Source_Input src) g
 , Inj_Source (Span (Source_Input src)) src
 ) => Gram_Source src g where
	g_source :: Functor g => g (src -> a) -> g a
	g_source g =
		g_ask_after $ g_ask_before $
		 (\f (beg::Source_Input src) (end::Source_Input src) ->
			f (inj_Source $ Span beg end::src))
		 <$> g
instance
 ( Gram_Reader (Source_Input src) g
 , Inj_Source (Span (Source_Input src)) src
 ) => Gram_Source src g

-- ** Type 'At'
-- | Attach a 'Source' to something.
data At src a
 =   At
 {   at   :: !src
 ,   unAt :: !a
 } deriving (Eq, Functor, Ord, Show, Typeable)