content: --------------------------------------------------------------------------------
  -- | This module mostly meant for internal usage, and might change between minor
  -- releases.
  {-# LANGUAGE ExistentialQuantification #-}
  {-# LANGUAGE FlexibleInstances         #-}
  {-# LANGUAGE GADTs                     #-}
  {-# LANGUAGE OverloadedStrings         #-}
  {-# LANGUAGE Rank2Types                #-}
  module Text.Digestive.Form.Internal
      ( Form
      , FormTree (..)
      , SomeForm (..)
      , Ref
      , Metadata (..)
      , transform
      , monadic
      , toFormTree
      , children
      , (.:)
      , getRef
      , lookupForm
      , lookupFormMetadata
      , lookupList
      , toField
      , queryField
      , eval
      , formMapView
      , forOptional
  
        -- * Debugging
      , debugFormPaths
      ) where
  
  
  --------------------------------------------------------------------------------
  import           Control.Applicative                (Applicative (..))
  import           Control.Monad                      (liftM, liftM2, (>=>))
  import           Control.Monad.Identity             (Identity (..))
  import           Data.Monoid                        (Monoid)
  import           Data.Traversable                   (mapM, sequenceA)
  import           Prelude                            hiding (mapM)
  
  
  --------------------------------------------------------------------------------
  import           Data.Text                          (Text)
  import qualified Data.Text                          as T
  
  
  --------------------------------------------------------------------------------
  import           Text.Digestive.Form.Internal.Field
  import           Text.Digestive.Form.List
  import           Text.Digestive.Types
  
  
  --------------------------------------------------------------------------------
  -- | Base type for a form.
  --
  -- The three type parameters are:
  --
  -- * @v@: the type for textual information, displayed to the user. For example,
  --   error messages are of this type. @v@ stands for "view".
  --
  -- * @m@: the monad in which validators operate. The classical example is when
  --   validating input requires access to a database, in which case this @m@
  --   should be an instance of @MonadIO@.
  --
  -- * @a@: the type of the value returned by the form, used for its Applicative
  --   instance.
  
  type Form v m a = FormTree m v m a
  
  
  --------------------------------------------------------------------------------
  -- | Embedded tree structure for forms - the basis for deferred evaluation
  -- and the applicative interface.
  data FormTree t v m a where
      -- Setting refs
      Ref      :: Ref -> FormTree t v m a -> FormTree t v m a
  
      -- Applicative interface
      Pure     :: Field v a -> FormTree t v m a
      App      :: FormTree t v m (b -> a)
               -> FormTree t v m b
               -> FormTree t v m a
  
      -- Modifications
      Map      :: (b -> m (Result v a)) -> FormTree t v m b -> FormTree t v m a
      Monadic  :: t (FormTree t v m a) -> FormTree t v m a
  
      -- Dynamic lists
      List     :: DefaultList (FormTree t v m a)  -- Not the optimal structure
               -> FormTree t v m [Int]
               -> FormTree t v m [a]
  
      -- Add arbitrary metadata. This metadata applies to all children.
      Metadata :: [Metadata] -> FormTree t v m a -> FormTree t v m a
  
  
  --------------------------------------------------------------------------------
  instance (Monad m, Monoid v) => Functor (FormTree t v m) where
      fmap = transform . (return .) . (return .)
  
  
  --------------------------------------------------------------------------------
  instance (Monad m, Monoid v) => Applicative (FormTree t v m) where
      pure x  = Pure (Singleton x)
      x <*> y = App x y
  
  
  --------------------------------------------------------------------------------
  instance Show (FormTree Identity v m a) where
      show = unlines . showForm
  
  
  --------------------------------------------------------------------------------
  -- | Value-agnostic Form
  data SomeForm v m = forall a. SomeForm (FormTree Identity v m a)
  
  
  --------------------------------------------------------------------------------
  instance Show (SomeForm v m) where
      show (SomeForm f) = show f
  
  
  --------------------------------------------------------------------------------
  -- | Compact type for form labelling
  type Ref = Text
  
  
  --------------------------------------------------------------------------------
  data Metadata
      = Disabled
      deriving (Eq, Ord, Show)
  
  
  --------------------------------------------------------------------------------
  -- Helper for the FormTree Show instance
  showForm :: FormTree Identity v m a -> [String]
  showForm form = case form of
      (Ref r x) -> ("Ref " ++ show r) : map indent (showForm x)
      (Pure x)  -> ["Pure (" ++ show x ++ ")"]
      (App x y) -> concat
          [ ["App"]
          , map indent (showForm x)
          , map indent (showForm y)
          ]
      (Map _ x)   -> "Map _" : map indent (showForm x)
      (Monadic x) -> "Monadic" : map indent (showForm $ runIdentity x)
      (List _ is) -> concat
          [ ["List <defaults>"]  -- TODO show defaults
          , map indent (showForm is)
          ]
      (Metadata m x) -> ("Metadata " ++ show m) : map indent (showForm x)
    where
      indent = ("  " ++)
  
  
  --------------------------------------------------------------------------------
  -- | Map on the value type
  transform :: (Monad m, Monoid v)
            => (a -> m (Result v b)) -> FormTree t v m a -> FormTree t v m b
  transform f (Map g x) = Map (\y -> g y `bindResult` f) x
  transform f x         = Map f x
  
  
  --------------------------------------------------------------------------------
  -- | Hide a monadic wrapper
  monadic :: m (Form v m a) -> Form v m a
  monadic = Monadic
  
  
  --------------------------------------------------------------------------------
  -- | Normalize a Form to allow operations on the contents
  toFormTree :: Monad m => Form v m a -> m (FormTree Identity v m a)
  toFormTree (Ref r x)      = liftM (Ref r) (toFormTree x)
  toFormTree (Pure x)       = return $ Pure x
  toFormTree (App x y)      = liftM2 App (toFormTree x) (toFormTree y)
  toFormTree (Map f x)      = liftM (Map f) (toFormTree x)
  toFormTree (Monadic x)    = x >>= toFormTree >>= return . Monadic . Identity
  toFormTree (List d is)    = liftM2 List (mapM toFormTree d) (toFormTree is)
  toFormTree (Metadata m x) = liftM (Metadata m) (toFormTree x)
  
  
  --------------------------------------------------------------------------------
  -- | Returns the topmost applicative or index trees if either exists
  -- otherwise returns an empty list
  children :: FormTree Identity v m a -> [SomeForm v m]
  children (Ref _ x )     = children x
  children (Pure _)       = []
  children (App x y)      = [SomeForm x, SomeForm y]
  children (Map _ x)      = children x
  children (Monadic x)    = children $ runIdentity x
  children (List _ is)    = [SomeForm is]
  children (Metadata _ x) = children x
  
  
  --------------------------------------------------------------------------------
  pushRef :: Monad t => Ref -> FormTree t v m a -> FormTree t v m a
  pushRef = Ref
  
  
  --------------------------------------------------------------------------------
  -- | Operator to set a name for a subform.
  (.:) :: Monad m => Text -> Form v m a -> Form v m a
  (.:) = pushRef
  infixr 5 .:
  
  
  --------------------------------------------------------------------------------
  -- Return topmost label of the tree if it exists, with the rest of the form
  popRef :: FormTree Identity v m a -> (Maybe Ref, FormTree Identity v m a)
  popRef form = case form of
      (Ref r x)      -> (Just r, x)
      (Pure _)       -> (Nothing, form)
      (App _ _)      -> (Nothing, form)
      (Map f x)      -> let (r, form') = popRef x in (r, Map f form')
      (Monadic x)    -> popRef $ runIdentity x
      (List _ _)     -> (Nothing, form)
      (Metadata m x) -> let (r, form') = popRef x in (r, Metadata m form')
  
  
  --------------------------------------------------------------------------------
  -- | Return the first/topmost label of a form
  getRef :: FormTree Identity v m a -> Maybe Ref
  getRef = fst . popRef
  
  
  --------------------------------------------------------------------------------
  getMetadata :: FormTree Identity v m a -> [Metadata]
  getMetadata (Ref _ _)      = []
  getMetadata (Pure _)       = []
  getMetadata (App _ _)      = []
  getMetadata (Map _ x)      = getMetadata x
  getMetadata (Monadic x)    = getMetadata $ runIdentity x
  getMetadata (List _ _)     = []
  getMetadata (Metadata m x) = m ++ getMetadata x
  
  
  --------------------------------------------------------------------------------
  -- | Retrieve the form(s) at the given path
  lookupForm :: Path -> FormTree Identity v m a -> [SomeForm v m]
  lookupForm path = map fst . lookupFormMetadata path
  
  
  --------------------------------------------------------------------------------
  -- | A variant of 'lookupForm' which also returns all metadata associated with
  -- the form.
  lookupFormMetadata :: Path -> FormTree Identity v m a
                     -> [(SomeForm v m, [Metadata])]
  lookupFormMetadata path = go [] path . SomeForm
    where
      -- Note how we use `popRef` to strip the ref away. This is really important.
      go md path' (SomeForm form) = case path' of
          []       -> [(SomeForm form, md')]
          (r : rs) -> case popRef form of
              (Just r', stripped)
                  | r == r' && null rs -> [(SomeForm stripped, md')]
                  | r == r'            -> children form >>= go md' rs
                  | otherwise          -> []
              (Nothing, _)             -> children form >>= go md' (r : rs)
        where
          md' = getMetadata form ++ md
  
  
  --------------------------------------------------------------------------------
  -- | Always returns a List - fails if path does not directly reference a list
  lookupList :: Path -> FormTree Identity v m a -> SomeForm v m
  lookupList path form = case candidates of
      (SomeForm f : _) -> SomeForm f
      []               -> error $ "Text.Digestive.Form.Internal: " ++
          T.unpack (fromPath path) ++ ": expected List, but got another form"
    where
      candidates =
          [ x
          | SomeForm f <- lookupForm path form
          , x          <- getList f
          ]
  
      getList :: forall a v m. FormTree Identity v m a -> [SomeForm v m]
      getList (Ref _ _)      = []
      getList (Pure _)       = []
      getList (App x y)      = getList x ++ getList y
      getList (Map _ x)      = getList x
      getList (Monadic x)    = getList $ runIdentity x
      getList (List d is)    = [SomeForm (List d is)]
      getList (Metadata _ x) = getList x
  
  
  --------------------------------------------------------------------------------
  -- | Returns the topmost untransformed single field, if one exists
  toField :: FormTree Identity v m a -> Maybe (SomeField v)
  toField (Ref _ x)      = toField x
  toField (Pure x)       = Just (SomeField x)
  toField (App _ _)      = Nothing
  toField (Map _ x)      = toField x
  toField (Monadic x)    = toField (runIdentity x)
  toField (List _ _)     = Nothing
  toField (Metadata _ x) = toField x
  
  
  --------------------------------------------------------------------------------
  -- | Retrieve the field at the given path of the tree and apply the evaluation.
  -- Used in field evaluation functions in "View".
  queryField :: Path
             -> FormTree Identity v m a
             -> (forall b. Field v b -> c)
             -> c
  queryField path form f = case lookupForm path form of
      []                   -> error $ ref ++ " does not exist"
      (SomeForm form' : _) -> case toField form' of
          Just (SomeField field) -> f field
          _                      -> error $ ref ++ " is not a field"
    where
      ref = T.unpack $ fromPath path
  
  
  --------------------------------------------------------------------------------
  -- Annotate errors with the path from where they originated
  ann :: Path -> Result v a -> Result [(Path, v)] a
  ann _    (Success x) = Success x
  ann path (Error x)   = Error [(path, x)]
  
  
  --------------------------------------------------------------------------------
  -- | Evaluate a formtree with a given method and environment.
  -- Incrementally builds the path based on the set labels and
  -- evaluates recursively - applying transformations and
  -- applications with a bottom-up strategy.
  eval :: Monad m => Method -> Env m -> FormTree Identity v m a
       -> m (Result [(Path, v)] a, [(Path, FormInput)])
  eval = eval' []
  
  eval' :: Monad m => Path -> Method -> Env m -> FormTree Identity v m a
        -> m (Result [(Path, v)] a, [(Path, FormInput)])
  
  eval' path method env form = case form of
      Ref r x -> eval' (path ++ [r]) method env x
  
      Pure field -> do
          val <- env path
          let x = evalField method val field
          return $ (pure x, [(path, v) | v <- val])
  
      App x y -> do
          (x', inp1) <- eval' path method env x
          (y', inp2) <- eval' path method env y
          return (x' <*> y', inp1 ++ inp2)
  
      Map f x -> do
          (x', inp) <- eval' path method env x
          x''       <- bindResult (return x') (f >=> return . ann path)
          return (x'', inp)
  
      Monadic x -> eval' path method env $ runIdentity x
  
      List defs fis -> do
          (ris, inp1) <- eval' path method env fis
          case ris of
              Error errs -> return (Error errs, inp1)
              Success is -> do
                  res <- mapM
                      -- TODO fix head defs
                      (\i -> eval' (path ++ [T.pack $ show i])
                          method env $ defs `defaultListIndex` i) is
  
                  let (results, inps) = unzip res
                  return (sequenceA results, inp1 ++ concat inps)
  
      Metadata _ x -> eval' path method env x
  
  
  --------------------------------------------------------------------------------
  -- | Map on the error type of a FormTree -
  -- used to define the Functor instance of "View.View"
  formMapView :: Monad m
              => (v -> w) -> FormTree Identity v m a -> FormTree Identity w m a
  formMapView f (Ref r x)      = Ref r $ formMapView f x
  formMapView f (Pure x)       = Pure $ fieldMapView f x
  formMapView f (App x y)      = App (formMapView f x) (formMapView f y)
  formMapView f (Map g x)      = Map (g >=> return . resultMapError f) (formMapView f x)
  formMapView f (Monadic x)    = formMapView f $ runIdentity x
  formMapView f (List d is)    = List (fmap (formMapView f) d) (formMapView f is)
  formMapView f (Metadata m x) = Metadata m $ formMapView f x
  
  
  --------------------------------------------------------------------------------
  -- | Combinator that lifts input and output of valiation function used by 'validate'
  -- to from (a -> Result v b) to (Maybe a -> Result v (Maybe b)).
  forOptional :: (a -> Result v b) -> Maybe a -> Result v (Maybe b)
  forOptional f x  = case (x) of
      Nothing -> Success Nothing
      Just x'  -> case (f x') of
          Success x'' -> Success (Just x'')
          Error   x'' -> Error x''
  
  
  --------------------------------------------------------------------------------
  -- | Utility: bind for 'Result' inside another monad
  bindResult :: (Monad m, Monoid v)
             => m (Result v a) ->
             (a -> m (Result v b)) ->
             m (Result v b)
  bindResult mx f = do
      x <- mx
      case x of
          Error errs  -> return $ Error errs
          Success x'  -> f x'
  
  
  --------------------------------------------------------------------------------
  -- | Debugging purposes
  debugFormPaths :: (Monad m, Monoid v) => FormTree Identity v m a -> [Path]
  debugFormPaths (Pure _)       = [[]]
  debugFormPaths (App x y)      = debugFormPaths x ++ debugFormPaths y
  debugFormPaths (Map _ x)      = debugFormPaths x
  debugFormPaths (Monadic x)    = debugFormPaths $ runIdentity x
  debugFormPaths (List d is)    =
      debugFormPaths is ++
      (map ("0" :) $ debugFormPaths $ d `defaultListIndex` 0)
  debugFormPaths (Ref r x)      = map (r :) $ debugFormPaths x
  debugFormPaths (Metadata _ x) = debugFormPaths x
  