module Text.Reform.Core where
import Control.Applicative (Applicative(pure, (<*>)))
import Control.Applicative.Indexed (IndexedApplicative(ipure, (<<*>>)), IndexedFunctor (imap))
import Control.Arrow (first, second)
import Control.Monad.Reader (MonadReader(ask), ReaderT, runReaderT)
import Control.Monad.State (MonadState(get,put), StateT, evalStateT)
import Control.Monad.Trans (lift)
import Data.Monoid (Monoid(mempty, mappend))
import Data.Text.Lazy (Text, unpack)
import Text.Reform.Result (FormId(..), FormRange(..), Result(..), unitRange, zeroId)
data Proved proofs a =
Proved { proofs :: proofs
, pos :: FormRange
, unProved :: a
}
instance Functor (Proved ()) where
fmap f (Proved () pos a) = Proved () pos (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 -> return 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 (Monoid input, Monad m) => Monoid (Environment m input) where
mempty = NoEnvironment
NoEnvironment `mappend` x = x
x `mappend` NoEnvironment = x
(Environment env1) `mappend` (Environment env2) =
Environment $ \id' ->
do r1 <- (env1 id')
r2 <- (env2 id')
case (r1, r2) of
(Missing, Missing) -> return Missing
(Default, Missing) -> return Default
(Missing, Default) -> return Default
(Found x, Found y) -> return $ Found (x `mappend` y)
(Found x, _ ) -> return $ Found x
(_ , Found y) -> return $ Found y
getFormId :: Monad m => FormState m i FormId
getFormId = do
FormRange x _ <- get
return 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 (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) => IndexedFunctor (Form m input view error) where
imap f g (Form frm) =
Form $ do (view, mval) <- frm
val <- lift $ lift $ mval
case val of
(Ok (Proved p pos a)) -> return (view, return $ Ok (Proved (f p) pos (g a)))
(Error errs) -> return (view, return $ Error errs)
instance (Monoid view, Monad m) => IndexedApplicative (Form m input error view) where
ipure p a = Form $ do i <- getFormId
return (mempty, return $ Ok (Proved p (unitRange i) a))
(Form frmF) <<*>> (Form frmA) =
Form $ do ((view1, mfok), (view2, maok)) <- bracketState $
do res1 <- frmF
incFormId
res2 <- frmA
return (res1, res2)
fok <- lift $ lift $ mfok
aok <- lift $ lift $ maok
case (fok, aok) of
(Error errs1, Error errs2) -> return (view1 `mappend` view2, return $ Error $ errs1 ++ errs2)
(Error errs1, _) -> return (view1 `mappend` view2, return $ Error $ errs1)
(_ , Error errs2) -> return (view1 `mappend` view2, return $ Error $ errs2)
(Ok (Proved p (FormRange x _) f), Ok (Proved q (FormRange _ y) a)) ->
return (view1 `mappend` view2, return $ 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
return 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
return (View $ const $ mempty, return $ 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
return (res1, res2)
fok <- lift $ lift $ mfok
aok <- lift $ lift $ maok
case (fok, aok) of
(Error errs1, Error errs2) -> return (view1 `mappend` view2, return $ Error $ errs1 ++ errs2)
(Error errs1, _) -> return (view1 `mappend` view2, return $ Error $ errs1)
(_ , Error errs2) -> return (view1 `mappend` view2, return $ Error $ errs2)
(Ok (Proved p (FormRange x _) f), Ok (Proved q (FormRange _ y) a)) ->
return (view1 `mappend` view2, return $ 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
return $ 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
return (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
return $ 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
return ( View (const view')
, return (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
return (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
return (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 =
return ( View $ const $ view
, return $ Ok (Proved { proofs = ()
, pos = unitRange i
, unProved = val
})
)