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 Network.URI.Slug
  15 import Symantic.Classes (Iso (..), IsoFunctor ((<%>)), ProductFunctor (..), SumFunctor ((<+>)))
  16
  17 import Webc.Classes
  18
  19 -- * The 'Decoder' interpreter
  20
  21 -- | A very very basic parser.
  22 newtype Decoder a = Decoder
  23   { unDecoder ::
  24       MT.StateT
  25         [Slug]
  26         (MT.Except DecoderError)
  27         a
  28   }
  29
  30 decode :: Decoder a -> [Slug] -> Either DecoderError a
  31 decode (Decoder dec) slugs = case MT.runExcept (MT.runStateT dec slugs) of
  32   Left err -> Left err
  33   Right (a, st)
  34     | null st -> Right a
  35     | otherwise -> Left $ DecoderErrorLeftover st
  36
  37 data DecoderError
  38   = DecoderErrorMismatch {expectedSlug :: Slug, gotSlug :: Slug}
  39   | DecoderErrorMissing
  40   | DecoderErrorLeftover [Slug]
  41
  42 instance IsoFunctor Decoder where
  43   Iso{..} <%> Decoder x = Decoder (a2b <$> x)
  44 instance ProductFunctor Decoder where
  45   Decoder x <.> Decoder y = Decoder $ (,) <$> x <*> y
  46   Decoder x <. Decoder y = Decoder $ x <* y
  47   Decoder x .> Decoder y = Decoder $ x *> y
  48 instance SumFunctor Decoder where
  49   Decoder x <+> Decoder y = Decoder $
  50     MT.StateT $ \st -> do
  51       case MT.runExcept $ MT.runStateT x st of
  52         Right (a, ss) -> return (Left a, ss)
  53         Left _err ->
  54           -- TODO: better error merging
  55           case MT.runExcept $ MT.runStateT y st of
  56             Right (b, ss) -> return (Right b, ss)
  57             Left err -> MT.throwE err
  58 instance Slugable Decoder where
  59   slug expectedSlug = Decoder $ do
  60     slugs <- MT.get
  61     case slugs of
  62       [] -> MT.lift $ MT.throwE DecoderErrorMissing
  63       gotSlug : nextSlugs
  64         | expectedSlug /= gotSlug ->
  65           MT.lift $ MT.throwE $ DecoderErrorMismatch{..}
  66         | otherwise -> MT.put nextSlugs