src/Webc/Decoder.hs

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