{-#LANGUAGE Arrows, TypeSynonymInstances, FlexibleInstances,
  FlexibleContexts #-}

module Web.Horse.Forms.Types where

import Control.Arrow.Transformer.Automaton.Monad
import Control.Arrow.Transformer.LabeledArrow
import Text.Hamlet
import Debug.Trace
import Data.List
import Control.Arrow
import Control.Arrow.Transformer.All
import Control.Arrow.Operations

type FormOut = Html ()
newtype FormIn = FormIn [(String,String)] deriving (Show)

type HoH i o = LabeledArrow (ReaderArrow FormIn (Automaton (Kleisli IO))) i o

type WithError ex i o = LabeledArrow (ErrorArrow ex (ReaderArrow FormIn (Automaton (Kleisli IO)))) i o

noInput :: FormIn
noInput = FormIn [] 

filterPrefix :: String -> FormIn -> FormIn
filterPrefix s (FormIn xss) = FormIn $ filter ((== s) . fst) xss

class HasFormOut o where
    getFormOut :: o -> FormOut
    setFormOut :: FormOut -> o -> o

instance HasFormOut FormOut where
    getFormOut = id
    setFormOut = const

instance HasFormOut (FormOut, i) where
    getFormOut (fo,_) = fo
    setFormOut fo (_,o) = (fo,o)

instance HasFormOut (FormOut, o1, o2) where
    getFormOut (fo,_,_) = fo
    setFormOut fo (_,o1,o2) = (fo,o1,o2)


getSingle :: FormIn -> Maybe String
getSingle (FormIn [(_,x)]) = Just x
getSingle _ = Nothing

withInput :: (ArrowReader FormIn a', ArrowAddLabel a a')
             => a' (e,String,Maybe String) b -> a e b
withInput f = runLabel $ proc (e,lab) -> do
              fi <- readState -< ()
              f -< (e,show lab,getSingle $ filterPrefix (show lab) fi)

catchAuto
  :: (ArrowAddAutomaton a a', 
      ArrowApply a',
      ArrowChoice a', 
      ArrowChoice a) =>
     (LabeledArrow (ErrorArrow (LabeledArrow a i o) a)) i o 
         -> LabeledArrow a i o
catchAuto f = liftAutomaton $
              (LabeledArrow $
               unLA (elimAutomaton f) 
                >>> second (arr catchAuto)) `elimError` 
              (LabeledArrow $ proc (i,f') -> 
                   app -< (unLA (elimAutomaton f'), i))

runHamlet :: (Arrow a) => a (x -> y) y
runHamlet = arr ($ undefined)