{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Ditto.Core where
import Control.Applicative (Applicative ((<*>), pure))
import Control.Monad.Reader (MonadReader (ask), ReaderT, runReaderT)
import Control.Monad.State (MonadState (get, put), StateT, evalStateT)
import Control.Monad.Trans (lift)
import Data.Biapplicative (Biapplicative ((<<*>>), bipure))
import Data.Bifunctor (Bifunctor (..))
import Data.Monoid (Monoid (mappend, mempty))
import qualified Data.Semigroup as SG
import Data.Text.Lazy (Text, unpack)
import Ditto.Result (FormId (..), FormRange (..), Result (..), unitRange, zeroId)
data Proved proofs a
= Proved
{ proofs :: proofs
, pos :: FormRange
, unProved :: a
}
deriving Show
instance Functor (Proved ()) where
fmap f (Proved () posi a) = Proved () posi (f a)
unitProved :: FormId -> Proved () ()
unitProved formId =
Proved
{ proofs = ()
, pos = unitRange formId
, unProved = ()
}
type FormState m input = ReaderT (Environment m input) (StateT FormRange m)
data Value a
= Default
| Missing
| Found a
getFormInput :: Monad m => FormState m input (Value input)
getFormInput = getFormId >>= getFormInput'
getFormInput' :: Monad m => FormId -> FormState m input (Value input)
getFormInput' id' = do
env <- ask
case env of
NoEnvironment -> pure Default
Environment f ->
lift $ lift $ f id'
getFormRange :: Monad m => FormState m i FormRange
getFormRange = get
data Environment m input
= Environment (FormId -> m (Value input))
| NoEnvironment
instance (SG.Semigroup input, Monad m) => SG.Semigroup (Environment m input) where
NoEnvironment <> x = x
x <> NoEnvironment = x
(Environment env1) <> (Environment env2) =
Environment $ \id' ->
do
r1 <- (env1 id')
r2 <- (env2 id')
case (r1, r2) of
(Missing, Missing) -> pure Missing
(Default, Missing) -> pure Default
(Missing, Default) -> pure Default
(Default, Default) -> pure Default
(Found x, Found y) -> pure $ Found (x SG.<> y)
(Found x, _) -> pure $ Found x
(_, Found y) -> pure $ Found y
instance (SG.Semigroup input, Monad m) => Monoid (Environment m input) where
mempty = NoEnvironment
mappend = (SG.<>)
getFormId :: Monad m => FormState m i FormId
getFormId = do
FormRange x _ <- get
pure x
incFormId :: Monad m => FormState m i ()
incFormId = do
FormRange _ endF1 <- get
put $ unitRange endF1
newtype View error v
= View
{ unView :: [(FormRange, error)] -> v
}
deriving (SG.Semigroup, Monoid)
instance Functor (View e) where
fmap f (View g) = View $ f . g
newtype Form m input error view proof a = Form {unForm :: FormState m input (View error view, m (Result error (Proved proof a)))}
instance (Monad m) => Bifunctor (Form m input view error) where
bimap f g (Form frm) =
Form $ do
(view1, mval) <- frm
val <- lift $ lift $ mval
case val of
(Ok (Proved p posi a)) -> pure (view1, pure $ Ok (Proved (f p) posi (g a)))
(Error errs) -> pure (view1, pure $ Error errs)
instance (Monoid view, Monad m) => Biapplicative (Form m input error view) where
bipure p a =
Form $ do
i <- getFormId
pure (mempty, pure $ Ok (Proved p (unitRange i) a))
(Form frmF) <<*>> (Form frmA) =
Form $ do
((view1, mfok), (view2, maok)) <-
bracketState $ do
res1 <- frmF
incFormId
res2 <- frmA
pure (res1, res2)
fok <- lift $ lift $ mfok
aok <- lift $ lift $ maok
case (fok, aok) of
(Error errs1, Error errs2) -> pure (view1 `mappend` view2, pure $ Error $ errs1 ++ errs2)
(Error errs1, _) -> pure (view1 `mappend` view2, pure $ Error $ errs1)
(_, Error errs2) -> pure (view1 `mappend` view2, pure $ Error $ errs2)
(Ok (Proved p (FormRange x _) f), Ok (Proved q (FormRange _ y) a)) ->
pure
( view1 `mappend` view2
, pure $ Ok $ Proved
{ proofs = p q
, pos = FormRange x y
, unProved = f a
}
)
bracketState :: Monad m => FormState m input a -> FormState m input a
bracketState k = do
FormRange startF1 _ <- get
res <- k
FormRange _ endF2 <- get
put $ FormRange startF1 endF2
pure res
instance (Functor m) => Functor (Form m input error view ()) where
fmap f form =
Form $ fmap (second (fmap (fmap (fmap f)))) (unForm form)
instance (Functor m, Monoid view, Monad m) => Applicative (Form m input error view ()) where
pure a =
Form $ do
i <- getFormId
pure
( View $ const $ mempty
, pure $ Ok $ Proved
{ proofs = ()
, pos = FormRange i i
, unProved = a
}
)
(Form frmF) <*> (Form frmA) =
Form $ do
((view1, mfok), (view2, maok)) <-
bracketState $ do
res1 <- frmF
incFormId
res2 <- frmA
pure (res1, res2)
fok <- lift $ lift $ mfok
aok <- lift $ lift $ maok
case (fok, aok) of
(Error errs1, Error errs2) -> pure (view1 `mappend` view2, pure $ Error $ errs1 ++ errs2)
(Error errs1, _) -> pure (view1 `mappend` view2, pure $ Error $ errs1)
(_, Error errs2) -> pure (view1 `mappend` view2, pure $ Error $ errs2)
(Ok (Proved _ (FormRange x _) f), Ok (Proved _ (FormRange _ y) a)) ->
pure
( view1 `mappend` view2
, pure $ Ok $ Proved
{ proofs = ()
, pos = FormRange x y
, unProved = f a
}
)
runForm
:: (Monad m)
=> Environment m input
-> Text
-> Form m input error view proof a
-> m (View error view, m (Result error (Proved proof a)))
runForm env prefix' form =
evalStateT (runReaderT (unForm form) env) (unitRange (zeroId $ unpack prefix'))
runForm'
:: (Monad m)
=> Environment m input
-> Text
-> Form m input error view proof a
-> m (view, Maybe a)
runForm' env prefix form =
do
(view', mresult) <- runForm env prefix form
result <- mresult
pure $ case result of
Error e -> (unView view' e, Nothing)
Ok x -> (unView view' [], Just (unProved x))
viewForm
:: (Monad m)
=> Text
-> Form m input error view proof a
-> m view
viewForm prefix form =
do
(v, _) <- runForm NoEnvironment prefix form
pure (unView v [])
eitherForm
:: (Monad m)
=> Environment m input
-> Text
-> Form m input error view proof a
-> m (Either view a)
eitherForm env id' form = do
(view', mresult) <- runForm env id' form
result <- mresult
pure $ case result of
Error e -> Left $ unView view' e
Ok x -> Right (unProved x)
view
:: (Monad m)
=> view
-> Form m input error view () ()
view view' =
Form $ do
i <- getFormId
pure
( View (const view')
, pure
( Ok
( Proved
{ proofs = ()
, pos = FormRange i i
, unProved = ()
}
)
)
)
(++>)
:: (Monad m, Monoid view)
=> Form m input error view () ()
-> Form m input error view proof a
-> Form m input error view proof a
f1 ++> f2 =
Form $ do
(v2, r) <- unForm f2
(v1, _) <- unForm f1
pure (v1 `mappend` v2, r)
infixl 6 ++>
(<++)
:: (Monad m, Monoid view)
=> Form m input error view proof a
-> Form m input error view () ()
-> Form m input error view proof a
f1 <++ f2 =
Form $ do
(v1, r) <- unForm f1
(v2, _) <- unForm f2
pure (v1 `mappend` v2, r)
infixr 5 <++
mapView
:: (Monad m, Functor m)
=> (view -> view')
-> Form m input error view proof a
-> Form m input error view' proof a
mapView f = Form . fmap (first $ fmap f) . unForm
mkOk
:: (Monad m)
=> FormId
-> view
-> a
-> FormState m input (View error view, m (Result error (Proved () a)))
mkOk i view' val =
pure
( View $ const $ view'
, pure $
Ok
( Proved
{ proofs = ()
, pos = unitRange i
, unProved = val
}
)
)