src/Symantic/Parser/Source.hs

   1 {-# LANGUAGE ConstraintKinds #-}
   2 {-# LANGUAGE TypeFamilies #-}
   3 {-# LANGUAGE UndecidableInstances #-}
   4 -- {-# LANGUAGE PolyKinds #-}
   5 {-# OPTIONS_GHC -Wno-orphans #-}
   6
   7 module Symantic.Parser.Source where
   8
   9 import Control.Monad (Monad (..))
  10 import Control.Monad.Classes qualified as MC
  11 import Control.Monad.Trans.Writer.CPS qualified as MT
  12 import Data.Bool (Bool (..))
  13 import Data.Eq (Eq)
  14 import Data.Function ((.))
  15 import Data.Functor.Classes (Show1 (..), liftShowList2, liftShowsPrec2, showsPrec1, showsUnaryWith)
  16 import Data.Kind (Type)
  17 import Data.Monoid (Monoid (..))
  18 import Data.Ord (Ord)
  19 import Data.Tuple (fst)
  20 import Data.Typeable (Typeable)
  21 import Text.Show (Show (..))
  22
  23 -- * Class 'Source'
  24 class Monoid src => Source src
  25 instance Source ()
  26
  27 -- ** Class 'SourceInj'
  28 class Source src => SourceInj a src where
  29   sourceInj :: a -> src
  30 instance SourceInj a () where
  31   sourceInj _ = ()
  32
  33 -- ** Type family 'SourceOf'
  34 type family SourceOf a
  35
  36 -- ** Type 'Sourceable'
  37 class Source (SourceOf a) => Sourceable a where
  38   sourceOf :: a -> SourceOf a
  39   setSource :: a -> SourceOf a -> a
  40 infixl 5 `setSource`
  41
  42 withSource :: SourceInj src (SourceOf a) => Sourceable a => a -> src -> a
  43 withSource a src = a `setSource` sourceInj src
  44
  45 -- ** Type 'Source_Input'
  46 type family Source_Input (src :: Type) :: Type
  47 type instance Source_Input () = ()
  48
  49 -- ** Type 'Span'
  50 data Span src = Span
  51   { spanBegin :: !src
  52   , spanEnd :: !src
  53   }
  54   deriving (Eq, Ord, Show, Typeable)
  55
  56 type Sourced src a = MT.Writer src a
  57 unSourced :: Monoid src => Sourced src a -> a
  58 unSourced = fst . MT.runWriter
  59
  60 instance (Show w, Monoid w, Show1 m, Show a) => Show (MT.WriterT w m a) where
  61   showsPrec = showsPrec1
  62
  63 instance (Show w, Monoid w, Show1 m) => Show1 (MT.WriterT w m) where
  64   liftShowsPrec sp sl d m =
  65     showsUnaryWith (liftShowsPrec sp' sl') "WriterT" d (MT.runWriterT m)
  66     where
  67       sp' = liftShowsPrec2 sp sl showsPrec showList
  68       sl' = liftShowList2 sp sl showsPrec showList
  69
  70 appendSource :: MC.MonadWriter src m => m a -> src -> m a
  71 appendSource m src = do
  72   a <- m
  73   MC.tell src
  74   return a
  75
  76 -- class MC.MonadWriter w m => Provenanceable w (m::Type -> Type)
  77 -- instance MC.MonadWriter w m => Provenanceable w m
  78 -- type Provenanceable w m = MC.MonadWriter w m
  79
  80 type instance MC.CanDo (MT.WriterT w m) eff = WriterCanDo w eff
  81 type family WriterCanDo w eff where
  82   WriterCanDo w (MC.EffWriter w) = 'True
  83   WriterCanDo w eff = 'False
  84
  85 class Provenanceable prov sem where
  86   provenance :: prov -> sem prov