]> Git — Sourcephile - webc.git/blob - src/Webc/Decoder.hs
37eeccae67dc06c9aef28f525c7ce02733ae5c34
[webc.git] / 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