{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
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.Bifunctor (Bifunctor (..))
import Data.List.NonEmpty (NonEmpty(..))
import Data.Monoid (Monoid (mappend, mempty))
import Data.Text.Lazy (Text, unpack)
import Ditto.Result (FormId (..), FormRange (..), Result (..), unitRange, zeroId)
import qualified Data.Semigroup as SG
data Proved a
= Proved
{ 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
{ 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
getNamedFormId :: Monad m => String -> FormState m i FormId
getNamedFormId name = do
FormRange x _ <- get
pure $ case x of
FormIdCustom _ i -> FormIdCustom name i
FormId _ (i :| _) -> FormIdCustom name i
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 a = Form {unForm :: FormState m input (View error view, m (Result error (Proved 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, x ~ ()) => Applicative (Form m input error view) where
pure a =
Form $ do
i <- getFormId
pure
( View $ const $ mempty
, pure $ Ok $ Proved
{ 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 <> view2, pure $ Error $ errs1 ++ errs2)
(Error errs1, _) -> pure (view1 <> view2, pure $ Error $ errs1)
(_, Error errs2) -> pure (view1 <> view2, pure $ Error $ errs2)
(Ok (Proved (FormRange x _) f), Ok (Proved (FormRange _ y) a)) ->
pure
( view1 <> view2
, pure $ Ok $ Proved
{ pos = FormRange x y
, unProved = f a
}
)
runForm
:: (Monad m)
=> Environment m input
-> Text
-> Form m input error view a
-> m (View error view, m (Result error (Proved 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 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 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 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
{ pos = FormRange i i
, unProved = ()
}
)
)
)
(++>)
:: (Monad m, Semigroup view)
=> Form m input error view ()
-> Form m input error view a
-> Form m input error view a
f1 ++> f2 =
Form $ do
(v2, r) <- unForm f2
(v1, _) <- unForm f1
pure (v1 <> v2, r)
infixl 6 ++>
(<++)
:: (Monad m, Semigroup view)
=> Form m input error view a
-> Form m input error view ()
-> Form m input error view a
f1 <++ f2 =
Form $ do
(v1, r) <- unForm f1
(v2, _) <- unForm f2
pure (v1 <> v2, r)
infixr 5 <++
mapView
:: (Monad m, Functor m)
=> (view -> view')
-> Form m input error view a
-> Form m input error view' 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
{ pos = unitRange i
, unProved = val
}
)
)