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