{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
-- {-# LANGUAGE PolyKinds #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Symantic.Parser.Source where

import Control.Applicative (Applicative (..))
import Control.Monad (Monad (..))
import Control.Monad.Classes qualified as MC
import Control.Monad.Trans.Writer.CPS qualified as MT
import Data.Bool (Bool (..))
import Data.Eq (Eq)
import Data.Function ((.))
import Data.Functor (Functor)
import Data.Functor.Classes (Show1 (..), liftShowList2, liftShowsPrec2, showsPrec1, showsUnaryWith)
import Data.Kind (Type)
import Data.Monoid (Monoid (..))
import Data.Ord (Ord)
import Data.Semigroup (Semigroup (..))
import Data.Tuple (fst)
import Data.Typeable (Typeable)
import Text.Show (Show (..))

-- * Class 'Source'
class Monoid src => Source src
instance Source ()

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

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

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

withSource :: SourceInj src (SourceOf a) => Sourceable a => a -> src -> a
withSource a src = a `setSource` sourceInj src

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

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

type Sourced src a = MT.Writer src a
unSourced :: Monoid src => Sourced src a -> a
unSourced = fst . MT.runWriter

instance (Show w, Monoid w, Show1 m, Show a) => Show (MT.WriterT w m a) where
  showsPrec = showsPrec1

instance (Show w, Monoid w, Show1 m) => Show1 (MT.WriterT w m) where
  liftShowsPrec sp sl d m =
    showsUnaryWith (liftShowsPrec sp' sl') "WriterT" d (MT.runWriterT m)
    where
      sp' = liftShowsPrec2 sp sl showsPrec showList
      sl' = liftShowList2 sp sl showsPrec showList

appendSource :: MC.MonadWriter src m => m a -> src -> m a
appendSource m src = do
  a <- m
  MC.tell src
  return a

-- class MC.MonadWriter w m => Provenanceable w (m::Type -> Type)
-- instance MC.MonadWriter w m => Provenanceable w m
-- type Provenanceable w m = MC.MonadWriter w m

type instance MC.CanDo (MT.WriterT w m) eff = WriterCanDo w eff
type family WriterCanDo w eff where
  WriterCanDo w (MC.EffWriter w) = 'True
  WriterCanDo w eff = 'False

class Provenanceable prov sem where
  provenance :: prov -> sem prov