<commit_before>{-# LANGUAGE OverloadedStrings, TypeFamilies, ScopedTypeVariables #-}
module HTTP.Form.Deform
  ( DeformT
  , runDeform
  , deformSync'
  , (.:>)
  , withSubDeforms
  , deformOptional
  , deformNonEmpty
  , Deform(..)
  , deformError
  , deformError'
  , deformMaybe'
  , deformGuard
  , deformCheck
  , deformParse
  , deformRead
  , deformRequired
  , textInteger
  ) where

import Control.Applicative (Alternative(..), liftA2)
import Control.Arrow (first, second, (***), left)
import Control.Monad (MonadPlus(..), liftM, mapAndUnzipM, guard)
import Control.Monad.Reader (MonadReader(..), asks)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Control (MonadTransControl(..))
import Control.Monad.Writer.Class (MonadWriter(..))
import qualified Data.Aeson as JSON
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.UTF8 as BSU
import Data.Functor (($>))
import qualified Data.HashMap.Strict as HM
import Data.Int (Int64, Int32, Int16)
import Data.Monoid ((<>))
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Read as TR
import Data.Time (fromGregorian)
import Data.Time.Format (parseTimeM, defaultTimeLocale)
import qualified Data.Vector as V
import qualified Database.PostgreSQL.Typed.Range as Range (Range(Empty))
import qualified Network.URI as URI
import Network.Wai.Parse (FileInfo)
import Text.Read (readEither)

import Model.URL
import Model.Time
import Model.Offset
import Model.Segment
import HTTP.Form
import HTTP.Form.Errors

newtype DeformT f m a = DeformT { runDeformT :: Form f -> m (FormErrors, Maybe a) }

instance MonadTrans (DeformT f) where
  lift m = DeformT $ \_ ->
    liftM ((,) mempty . Just) m

instance MonadTransControl (DeformT f) where
  type StT (DeformT f) a = (FormErrors, Maybe a)
  liftWith f = DeformT $ \d ->
    liftM ((,) mempty . Just) $ f $ \t -> runDeformT t d
  restoreT m = DeformT $ \_ -> m

instance MonadIO m => MonadIO (DeformT f m) where
  liftIO = lift . liftIO

instance Functor m => Functor (DeformT f m) where
  fmap f (DeformT m) = DeformT $ \d ->
    second (fmap f) `fmap` m d

instance Applicative m => Applicative (DeformT f m) where
  pure a = DeformT $ \_ -> pure (mempty, Just a)
  DeformT f <*> DeformT v = DeformT $ \d ->
    liftA2 k (f d) (v d) where
    k (ef, mf) (ev, mv) = (ef <> ev, mf <*> mv)

instance Monad m => Monad (DeformT f m) where
  return = lift . return
  DeformT x >>= f = DeformT $ \d -> do
    (ex, mx) <- x d
    case mx of
      Nothing -> return (ex, Nothing)
      Just vx -> first (ex <>) `liftM` runDeformT (f $! vx) d
  fail = deformError' . T.pack

instance Monad m => MonadPlus (DeformT f m) where
  mzero = DeformT $ \_ -> return (mempty, Nothing)
  DeformT a `mplus` DeformT b = DeformT $ \d -> do
    ar <- a d
    case ar of
      (er, Just _) | nullFormErrors er -> return ar
      _ -> b d

instance (Applicative m, Monad m) => Alternative (DeformT f m) where
  empty = mzero
  (<|>) = mplus

instance Monad m => MonadReader (Form f) (DeformT f m) where
  ask = DeformT $ \d -> return (mempty, Just d)
  reader f = DeformT $ \d -> return (mempty, Just (f d))
  local f (DeformT a) = DeformT $ a . f

instance Monad m => MonadWriter FormErrors (DeformT f m) where
  writer (a, e) = DeformT $ \_ -> return (e, Just a)
  listen (DeformT a) = DeformT $ \d -> do
    (e, r) <- a d
    return (e, fmap (flip (,) e) r)
  pass (DeformT a) = DeformT $ \q -> do
    (e, mrf) <- a q
    case mrf of
      Just (r, f) -> return (f e, Just r)
      Nothing -> return (e, Nothing)
<commit_msg>Dead code commented out for now<commit_after>{-# LANGUAGE OverloadedStrings, TypeFamilies, ScopedTypeVariables #-}
module HTTP.Form.Deform
  ( DeformT
  , runDeform
  , deformSync'
  , (.:>)
  , withSubDeforms
  , deformOptional
  , deformNonEmpty
  , Deform(..)
  , deformError
  , deformError'
  , deformMaybe'
  , deformGuard
  , deformCheck
  , deformParse
  , deformRead
  , deformRequired
  , textInteger
  ) where

import Control.Applicative (Alternative(..), liftA2)
import Control.Arrow (first, second, (***), left)
import Control.Monad (MonadPlus(..), liftM, mapAndUnzipM, guard)
import Control.Monad.Reader (MonadReader(..), asks)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Class (MonadTrans(..))
-- import Control.Monad.Trans.Control (MonadTransControl(..))
-- import Control.Monad.Writer.Class (MonadWriter(..))
import qualified Data.Aeson as JSON
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.UTF8 as BSU
import Data.Functor (($>))
import qualified Data.HashMap.Strict as HM
import Data.Int (Int64, Int32, Int16)
import Data.Monoid ((<>))
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Read as TR
import Data.Time (fromGregorian)
import Data.Time.Format (parseTimeM, defaultTimeLocale)
import qualified Data.Vector as V
import qualified Database.PostgreSQL.Typed.Range as Range (Range(Empty))
import qualified Network.URI as URI
import Network.Wai.Parse (FileInfo)
import Text.Read (readEither)

import Model.URL
import Model.Time
import Model.Offset
import Model.Segment
import HTTP.Form
import HTTP.Form.Errors

newtype DeformT f m a = DeformT { runDeformT :: Form f -> m (FormErrors, Maybe a) }

instance MonadTrans (DeformT f) where
  lift m = DeformT $ \_ ->
    liftM ((,) mempty . Just) m
{-
instance MonadTransControl (DeformT f) where
  type StT (DeformT f) a = (FormErrors, Maybe a)
  liftWith f = DeformT $ \d ->
    liftM ((,) mempty . Just) $ f $ \t -> runDeformT t d
  restoreT m = DeformT $ \_ -> m
-}
instance MonadIO m => MonadIO (DeformT f m) where
  liftIO = lift . liftIO

instance Functor m => Functor (DeformT f m) where
  fmap f (DeformT m) = DeformT $ \d ->
    second (fmap f) `fmap` m d

instance Applicative m => Applicative (DeformT f m) where
  pure a = DeformT $ \_ -> pure (mempty, Just a)
  DeformT f <*> DeformT v = DeformT $ \d ->
    liftA2 k (f d) (v d) where
    k (ef, mf) (ev, mv) = (ef <> ev, mf <*> mv)

instance Monad m => Monad (DeformT f m) where
  return = lift . return
  DeformT x >>= f = DeformT $ \d -> do
    (ex, mx) <- x d
    case mx of
      Nothing -> return (ex, Nothing)
      Just vx -> first (ex <>) `liftM` runDeformT (f $! vx) d
  fail = deformError' . T.pack

instance Monad m => MonadPlus (DeformT f m) where
  mzero = DeformT $ \_ -> return (mempty, Nothing)
  DeformT a `mplus` DeformT b = DeformT $ \d -> do
    ar <- a d
    case ar of
      (er, Just _) | nullFormErrors er -> return ar
      _ -> b d

instance (Applicative m, Monad m) => Alternative (DeformT f m) where
  empty = mzero
  (<|>) = mplus

instance Monad m => MonadReader (Form f) (DeformT f m) where
  ask = DeformT $ \d -> return (mempty, Just d)
  reader f = DeformT $ \d -> return (mempty, Just (f d))
  local f (DeformT a) = DeformT $ a . f

{-instance Monad m => MonadWriter FormErrors (DeformT f m) where
  writer (a, e) = DeformT $ \_ -> return (e, Just a)
  listen (DeformT a) = DeformT $ \d -> do
    (e, r) <- a d
    return (e, fmap (flip (,) e) r)
  pass (DeformT a) = DeformT $ \q -> do
    (e, mrf) <- a q
    case mrf of
      Just (r, f) -> return (f e, Just r)
      Nothing -> return (e, Nothing) -}

{'fraction_non_alphanumeric': 0.1269069798838936, 'fraction_numerical': 0.0027001485081679494, 'mean_word_length': 3.221082621082621, 'pattern_counts': {'":': 0, '<': 23, '<?xml version=': 0, '>': 83, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1515980', 'n_tokens_mistral': 2704, 'n_tokens_neox': 2635, 'n_words': 897}