src/Webc/Decoder.hs

   1 module Webc.Decoder where
   2
   3 import Control.Applicative (Applicative (..))
   4 import Control.Monad (Monad (..))
   5 import Control.Monad.Trans.Class qualified as MT
   6 import Control.Monad.Trans.Except qualified as MT
   7 import Control.Monad.Trans.State qualified as MT
   8 import Data.Bool
   9 import Data.Either (Either (..))
  10 import Data.Eq (Eq (..))
  11 import Data.Foldable (null)
  12 import Data.Function (($))
  13 import Data.Functor ((<$>))
  14 import Data.Ord (Ord)
  15 import Network.URI.Slug
  16 import Symantic.Classes (Iso (..), IsoFunctor ((<%>)), ProductFunctor (..), SumFunctor ((<+>)))
  17 import Text.Show (Show)
  18
  19 import Webc.Classes
  20
  21 -- * The 'Decoder' interpreter
  22
  23 -- | A very very basic parser.
  24 newtype Decoder a = Decoder
  25   { unDecoder ::
  26       MT.StateT
  27         [Slug]
  28         (MT.Except DecoderError)
  29         a
  30   }
  31
  32 decode :: Decoder a -> [Slug] -> Either DecoderError a
  33 decode (Decoder dec) slugs = case MT.runExcept (MT.runStateT dec slugs) of
  34   Left err -> Left err
  35   Right (a, st)
  36     | null st -> Right a
  37     | otherwise -> Left $ DecoderErrorLeftover st
  38
  39 data DecoderError
  40   = DecoderErrorMismatch {expectedSlug :: Slug, gotSlug :: Slug}
  41   | DecoderErrorMissing
  42   | DecoderErrorLeftover [Slug]
  43   deriving (Eq, Ord, Show)
  44
  45 instance IsoFunctor Decoder where
  46   Iso{..} <%> Decoder x = Decoder (a2b <$> x)
  47 instance ProductFunctor Decoder where
  48   Decoder x <.> Decoder y = Decoder $ (,) <$> x <*> y
  49   Decoder x <. Decoder y = Decoder $ x <* y
  50   Decoder x .> Decoder y = Decoder $ x *> y
  51 instance SumFunctor Decoder where
  52   Decoder x <+> Decoder y = Decoder $
  53     MT.StateT $ \st -> do
  54       case MT.runExcept $ MT.runStateT x st of
  55         Right (a, ss) -> return (Left a, ss)
  56         Left _err ->
  57           -- TODO: better error merging
  58           case MT.runExcept $ MT.runStateT y st of
  59             Right (b, ss) -> return (Right b, ss)
  60             Left err -> MT.throwE err
  61 instance Slugable Decoder where
  62   literalSlug expectedSlug = Decoder $ do
  63     slugs <- MT.get
  64     case slugs of
  65       [] -> MT.lift $ MT.throwE DecoderErrorMissing
  66       gotSlug : nextSlugs
  67         | expectedSlug /= gotSlug ->
  68           MT.lift $ MT.throwE $ DecoderErrorMismatch{..}
  69         | otherwise -> MT.put nextSlugs
  70   captureSlug _name = Decoder $ do
  71     slugs <- MT.get
  72     case slugs of
  73       [] -> MT.lift $ MT.throwE DecoderErrorMissing
  74       gotSlug : nextSlugs -> do
  75         MT.put nextSlugs
  76         return gotSlug