src/Webc/Decoder.hs

   1 {-# LANGUAGE GeneralisedNewtypeDeriving #-}
   2 {-# LANGUAGE UndecidableInstances #-}
   3
   4 module Webc.Decoder where
   5
   6 import Control.Applicative (Applicative (..))
   7 import Control.Monad (Monad (..))
   8 import Control.Monad.Trans.Class qualified as MT
   9 import Control.Monad.Trans.Except qualified as MT
  10 import Control.Monad.Trans.Reader qualified as MT
  11 import Control.Monad.Trans.State qualified as MT
  12 import Data.Bifunctor (first)
  13 import Data.Bool
  14 import Data.ByteString.Lazy qualified as BSL
  15 import Data.Either (Either (..))
  16 import Data.Eq (Eq (..))
  17 import Data.Foldable (null)
  18 import Data.Function (($), (.))
  19 import Data.Functor (Functor, (<$>))
  20 import Data.List qualified as List
  21 import Data.Maybe (Maybe (..))
  22 import Data.Ord (Ord)
  23 import Data.Semigroup (Semigroup (..))
  24 import Data.Set (Set)
  25 import Data.Set qualified as Set
  26 import Data.Text qualified as Text
  27 import Network.URI.Slug
  28 import Symantic.Classes (Iso (..), IsoFunctor ((<%>)), Optionable (..), ProductFunctor (..), SumFunctor ((<+>)))
  29 import System.IO (IO)
  30 import Text.Show (Show)
  31
  32 -- import Prelude (undefined)
  33
  34 import Webc.Classes
  35
  36 -- * The 'Decoder' interpreter
  37
  38 -- | A very very basic parser.
  39 newtype Decoder err a = Decoder
  40   { unDecoder ::
  41       MT.ReaderT [Slug] (MT.StateT [Slug] (MT.ExceptT (DecoderError err) IO)) a
  42   }
  43   deriving (Functor, Applicative, Monad)
  44
  45 decode :: Decoder err a -> [Slug] -> IO (Either (DecoderError err) a)
  46 decode (Decoder dec) slugs =
  47   MT.runExceptT (MT.runStateT (MT.runReaderT dec []) slugs) >>= \case
  48     Left err -> return $ Left err
  49     Right (a, st)
  50       | null st -> return $ Right a
  51       | otherwise -> return $ Left $ DecoderErrorLeftover st
  52
  53 data DecoderError err
  54   = DecoderErrorMismatch
  55       { expectedSlugs :: Set Slug
  56       , gotSlug :: Slug
  57       }
  58   | DecoderErrorMissing
  59   | DecoderErrorLeftover [Slug]
  60   | DecoderErrorParser err
  61   deriving (Eq, Ord, Show)
  62
  63 instance IsoFunctor (Decoder err) where
  64   (<%>) Iso{..} = (a2b <$>)
  65 instance ProductFunctor (Decoder err) where
  66   (<.>) = liftA2 (,)
  67   (<.) = (<*)
  68   (.>) = (*>)
  69 instance SumFunctor (Decoder err) where
  70   Decoder x <+> Decoder y = Decoder $
  71     MT.ReaderT $ \env -> MT.StateT $ \st -> do
  72       MT.lift (MT.runExceptT (MT.runStateT (MT.runReaderT x env) st)) >>= \case
  73         Right (a, st') -> return (Left a, st')
  74         Left _err ->
  75           -- TODO: better error merging
  76           MT.lift (MT.runExceptT (MT.runStateT (MT.runReaderT y env) st)) >>= \case
  77             Right (b, st') -> return (Right b, st')
  78             Left err -> MT.throwE err
  79 instance Endable (Decoder err) where
  80   end = Decoder do
  81     MT.lift MT.get >>= \case
  82       [] -> return ()
  83       lo -> MT.lift $ MT.lift $ MT.throwE $ DecoderErrorLeftover lo
  84 instance Repeatable (Decoder err) where
  85   many0 (Decoder x) = Decoder (MT.ReaderT (MT.StateT . go))
  86     where
  87       go env st = do
  88         MT.lift (MT.runExceptT (MT.runStateT (MT.runReaderT x env) st)) >>= \case
  89           Left _err -> return ([], st) -- always backtrack
  90           Right (a, st') -> first (a :) <$> go env st'
  91   many1 x = (:) <$> x <*> many0 x
  92 instance Optionable (Decoder err) where
  93   optional (Decoder x) = Decoder $
  94     MT.ReaderT $ \env -> MT.StateT $ \st -> do
  95       MT.lift (MT.runExceptT (MT.runStateT (MT.runReaderT x env) st)) >>= \case
  96         Left{} -> return (Nothing, st)
  97         Right (a, st') -> return (Just a, st')
  98 instance Slugable (Decoder err) where
  99   literalSlug expectedSlug = Decoder $ do
 100     slugs <- MT.lift MT.get
 101     case slugs of
 102       [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorMissing
 103       gotSlug : nextSlugs
 104         | expectedSlug /= gotSlug ->
 105           MT.lift $ MT.lift $ MT.throwE DecoderErrorMismatch{expectedSlugs = Set.singleton expectedSlug, ..}
 106         | otherwise ->
 107           MT.local (<> [gotSlug]) $
 108             MT.lift $ MT.put nextSlugs
 109   chooseSlug expectedSlugs = Decoder $ do
 110     slugs <- MT.lift MT.get
 111     case slugs of
 112       [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorMissing
 113       gotSlug : nextSlugs
 114         | gotSlug `Set.notMember` expectedSlugs ->
 115           MT.lift $ MT.lift $ MT.throwE DecoderErrorMismatch{expectedSlugs, ..}
 116         | otherwise -> do
 117           MT.local (<> [gotSlug]) $
 118             MT.lift $ MT.put nextSlugs
 119           return gotSlug
 120
 121 -- chooseSlugs = undefined
 122 -- chooseSlugs expectedSlugs = Decoder $ do
 123 --   slugs <- MT.lift MT.get
 124 --   case slugs of
 125 --     [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorMissing
 126 --     gotSlug : nextSlugs
 127 --       | gotSlug `Set.member` expectedSlugs ->
 128 --         MT.lift $ MT.lift $ MT.throwE $ DecoderErrorMismatch{expectedSlugs, ..}
 129 --       | otherwise -> do
 130 --         MT.local (<> [gotSlug]) $
 131 --           MT.lift $ MT.put nextSlugs
 132 --         return gotSlug
 133 instance Capturable (Decoder err) where
 134   captureSlug _name = Decoder $ do
 135     slugs <- MT.lift MT.get
 136     case slugs of
 137       [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorMissing
 138       gotSlug : nextSlugs ->
 139         MT.local (<> [gotSlug]) do
 140           MT.lift $ MT.put nextSlugs
 141           return gotSlug
 142
 143 --chooseSlug expectedSlugs = Decoder $ do
 144 --  slugs <- MT.lift MT.get
 145 --  case slugs of
 146 --    [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorMissing
 147 --    gotSlug : nextSlugs
 148 --      | gotSlug `Set.member` expectedSlugs ->
 149 --        MT.lift $ MT.lift $ MT.throwE $ DecoderErrorMismatch{..}
 150 --      | otherwise -> do
 151 --        MT.local (<> [gotSlug]) $
 152 --          MT.lift $ MT.put nextSlugs
 153 --        return gotSlug
 154 {-
 155 instance Selectable (Decoder err) where
 156   select ra a2bs = do
 157     a <- ra
 158     case Map.lookup a a2bs of
 159       Nothing ->
 160         Decoder $ MT.lift $ MT.lift $ MT.throwE
 161           DecoderErrorMissing -- FIXME
 162     where
 163     go a [] = Decoder $
 164       MT.lift $ MT.lift $ MT.throwE
 165         DecoderErrorMissing -- FIXME
 166     go a ((ca, x):xs) = Decoder $
 167       MT.ReaderT $ \env -> MT.StateT $ \st -> do
 168         MT.lift (MT.runExceptT (MT.runStateT (MT.runReaderT (unDecoder x) env) st)) >>= \case
 169           Right r -> return r
 170           Left _err ->
 171             MT.runStateT (MT.runReaderT (unDecoder (choose ra xs)) env) st
 172 -}
 173 instance Fileable (Decoder err) where
 174   type FileableConstraint (Decoder err) = Parsable err
 175   static = Decoder do
 176     return ()
 177   dynamic = Decoder do
 178     path <- MT.ask
 179     content <-
 180       MT.lift $
 181         MT.lift $
 182           MT.lift $
 183             BSL.readFile $
 184               List.intercalate "/" $
 185                 Text.unpack . encodeSlug <$> path
 186     case parse content of
 187       Right a -> return a
 188       Left err -> MT.lift $ MT.lift $ MT.throwE $ DecoderErrorParser err
 189
 190 -- * Class 'Parsable'
 191 class Parsable err a where
 192   parse :: BSL.ByteString -> Either err a