{-# LANGUAGE NoMonomorphismRestriction,
             FlexibleInstances,  
             ScopedTypeVariables,
             RankNTypes,
             FlexibleContexts,
             CPP,
             TemplateHaskell  #-}

module Options.UU.Interleaved where
import Data.Functor.Identity
import Control.Applicative.Interleaved
import Control.Monad.State.Class
import Control.Monad.Trans.State.Lazy
import Text.ParserCombinators.UU -- hiding (pSymbol)
import Text.ParserCombinators.UU.BasicInstances 
import Text.ParserCombinators.UU.Utils hiding (lexeme, pSymbol)
import Data.Lenses
import Data.Lenses.Template

-- For a description of how to use these combinators see the accompanying Demo module. 
-- Further information can be found in a Technical report at http://www.cs.uu.nl/research/techreps/UU-CS-2013-005.html

{-| An example of how to use this module
@
{-# LANGUAGE TemplateHaskell, FlexibleContexts, NoMonomorphismRestriction, TypeSynonymInstances, FlexibleInstances #-}
module Main where
import Data.Lenses.Template
import Text.ParserCombinators.UU
import Text.ParserCombinators.UU.BasicInstances
import Text.ParserCombinators.UU.Utils
import Text.ParserCombinators.UU.Interleaved
import Options.UU.Interleaved
import Data.Monoid
import System.Environment
@
-}
{-
-- We assume that we store our options in a data type for which we generate lenses

data Prefers  =  Agda | Haskell deriving Show
data Address  =  Address  {  city_ :: String
                          ,  street_ :: String} 
                 deriving Show
data Name     =  Name  {  name_:: String 
                       ,  prefers_:: Prefers
                       ,  ints_ :: [Int]
                       ,  address_ :: Address} 
                 deriving Show

$(deriveLenses ''Name)
$(deriveLenses ''Address)

instance ShowParserType Prefers where
   showType p = " <Agda | Haskell> "

-- The next thing to do is to specify a default record containing the default values:
defaults = Name  "Atze" Haskell [] 
                 (Address  "Utrecht" 
                           "Princetonplein")

-- Next we define the parser for the options, by specifying for each filed what may be specified:

oName =
                 name     `option`   ("name",       pString,      "Name")
            <>   ints     `options`  ("ints",       pNaturalRaw,  "A couple of numbers") 
            <>   prefers  `choose`   [("agda",      Agda,         "In case you prefer Agda")
                                     ,("haskell",   Haskell,      "In case you prefer Haskell")
                                     ] 
            <>   address  `field`
                           (   city     `option`  ("city",   pString, "Home city")  
                           <>  street   `option`  ("street" ,pString, "Home Street" )
                           )
-- | The function `main` may serve as a template for your own option handling. You can also use this module to see what  the effectis  of the various ways of passing options
-- >>> ./OptionsDemo -i1 --ints 2 --street=Zandlust -a -nDoaitse -i3 --ints=4 --city=Tynaarlo
--     Name {name_ = "Doaitse", prefers_ = Agda, ints_ = [1,2,3,4], address_ = Address {city_ = "Tynaarlo", street_ = "Zandlust"}}
--
-- >>> ./OptionsDemo -i1 --ints 2 --street=Zandlust -nDoaitse -i3 --ints=4 --city=Tynaarlo
--     --name           [Char]         optional  Name
--     --ints           Int            recurring A couple of numbers
--     Choose at least one from(
--     --agda                          required  In case you prefer Agda
--     --haskell                       required  In case you prefer Haskell
--     )
--     --city           [Char]         optional  Home city
--     --street         [Char]         optional  Home Street
--     --
--     --  Correcting steps:
--     --    Inserted  "-a" at position 70 expecting one of ["--agda", "--agda=", "--haskell", "--haskell=", "--ints=", "--ints", "-i", "-h", "-a"]
--     --    Inserted  "\EOT" at position 70 expecting "\EOT"

main  ::IO ()
main = do args  <- getArgs
          case run  defaults oName  (concat (map  (++ "\EOT") args)) of
            Left a        -> case a of
                                   Succes v -> print v
                                   Help   t -> putStrLn t
            Right errors  -> putStrLn errors

-- | The function `demo` can be used from within ghci:
{-
-- >>> demo ["-i2", "--street=Zandlust", "--ints=5", "-nAtze", "--city=Houten"]
--
-}
demo :: [[Char]] -> IO ()
demo args =  case run  defaults oName  (concat (map  (++ "\EOT") args)) of
                  Left a        -> case a of
                                   Succes v -> print v
                                   Help   t -> putStrLn t
                  Right errors  -> putStr errors

@
-}
-- instance  IsParser (Gram (P (Str Char String Int)))


instance Splittable (P (Str Char String Int)) where
   getPure    = getZeroP
   getNonPure = getOneP

{-
pSymbol :: String -> p (Str Char String Int) String
pSymbol [] = pure []
pSymbol (s:ss) = (:) <$> pSym s <*> pSymbol ss
-}

type OptionParser a = P (Str Char String Int) a

type Option a = Gram (P (Str Char String Int)) a

type BaseEntry s d = forall m r b. MonadState s m =>
     (m () -> StateT r Identity b)
     -> d
     -> (Gram (P (Str Char String Int)) (r -> r), [Char])

type Entry s a = ShowParserType a => BaseEntry s  ([Char], P (Str Char String Int) a, String)

type EntryVal  s a = ShowParserType a => BaseEntry s  ([Char], a, String)

type EntryVals s a = ShowParserType a => BaseEntry s  [([Char], a, String)]

class ShowParserType a where
   showType :: OptionParser a -> String

instance ShowParserType a => ShowParserType [a] where
   showType (p :: OptionParser [a]) = let q :: OptionParser a = undefined
                                      in "[" ++ showType q ++ "]"

instance ShowParserType Int where
   showType p = "Int"

instance ShowParserType Char where
   showType p = "Char"

--instance ShowParserType String where
--   showType p = "String"

instance ShowParserType Bool where
   showType p = "Bool"

data OptionResult a = Succes  a
                    | Help    String


lexeme p = p <* pToken "\EOT"

pString = pMunch (/='\EOT')
pBool   = True <$ pToken "True" <|> False <$ pToken "False"

oG   p  a = mkG ((a `alter`) <$> p) 


required_ :: (MonadState a m) 
     =>  (m () -> StateT r Identity b)
     -> ( [Char]
        , OptionParser (a -> a)
        , String
        , String
        , String
        )
     -> (Gram  (P (Str Char String Int))  (r -> r), [Char])

required_ a   (string, p, tp, kind, info) 
            = let tp' = case getNonPure p of
                        Nothing  -> ""
                        Just _   -> tp
                  align n t = take n (t++repeat ' ')
              in (       oG ( pToken ("-"   ++ [head string])             *> lexeme p) a
                    <|>  oG ( pToken ("--"  ++ string) <* pToken "\EOT"   *> case getNonPure p of
                                                                               Nothing -> p
                                                                               Just p' -> lexeme p) a
                    <|>  oG ( pToken ("--"  ++ string ++ "=")             *> lexeme p) a
                 , "--"++ align 15 string ++ align 15 tp' ++ align 10 kind ++ info ++"\n"
                 )

-- | a `required` entry specied an entry which has to be provided; in the record containing the default values one may put `undefined`
required  :: Entry a a

required a   (string, p, info)  = required_ a (string, const <$> p, showType p, "required", info)

-- | an `option` entry specied an entry which may  be provided; if absent the default value is taken

option :: Entry a a
option   a   (string, p, i)      =  let (r, t) = required_  a (string, const <$> p, showType p, "optional", i) 
                                    in  (r <|> pure id, t)

-- | An `options` entry specifies an element which may occur more than once. The final value contains the list of all the values encountered.
options :: Entry [a] a
options  a   (string, p, i)      =  let (pars, text) =   required_ a  ( string
                                                                     , (:) <$> p
                                                                     , showType p
                                                                     , "recurring"
                                                                     , i)
                                    in  (let pm = (.) <$> pars <*> pm <|> pure id in pm,  text)

-- | An `optionl` entry specifies an element which may occur more than once. The last one encountered is taken
-- optionsl :: Entry a a
optionsl  a (string, p, i)  =  let (pars, t) = options a (string, p, i ++"last  one is taken")  in ( (const. last .($[]))  <$> pars, t)


-- | An `optionf` entry specifies an element which may occur more than once. The first one encountered is taken
-- optionsf :: Entry a a
optionsf  a (string, p, i)  =  let (pars, t) = options a (string, p, i ++"first  one is taken") in ( (head .)  <$> pars, t)

-- | A `flag` entry sets   a field to a specific value when encountered
flag :: EntryVal a a
flag     a   (string, v,i)       =  option    a (string, pure v, i)

-- | A `flags` entry introduces a list of possible parameters, each with a value to which the field should be set
flags :: EntryVals a a
flags    a   table               =  foldr (<>) (pure id, "") (map (flag a) table)

-- | A `set` entry introduces a required entry, which sets a spcific value; it is used in `choose` and probably not very useful by itself.
set :: EntryVal a a
set     a   (string, v,i)      =  required_    a (string, pure (const v), "", "required", i)

-- | A `choose` entry introduces a list of choices for the specific entry; precisely one should be given
choose :: EntryVals a a
choose  a   table              =  let (ps, ts) =  unzip (map (set a) table)
                                  in (foldr (<|>) empty ps, "Choose at least one from(\n" ++ concat ts ++ ")\n")

-- | A `change` entry is an optional `choose` entry
change :: EntryVals a a 
change  a   table              =  let (ps, ts) =  unzip (map (set a) table)
                                  in (foldr (<|>) (pure id) ps, "You may choose one from(\n" ++ concat ts ++ ")\n")

  

-- | A `field` entry introduces a collection of options which are used to set fields in a sub-record of the main record 
field
  :: (Functor f, Control.Monad.State.Class.MonadState a m) =>
     (m ()
      -> Control.Monad.Trans.State.Lazy.StateT
           r Data.Functor.Identity.Identity b)
     -> (f (a -> a), t) -> (f (r -> r), t)
field s opts = let (p, t) = opts in ((s `alter`) <$> p, t)

-- | The function `run` equips the given option specification with an option to ask for @--help@. It concatenates the files coming from the command line and terminates them with an EOT. 
--   Make sure your command line arguments do not contain an EOT. It parses the command line arguments and updates the `default` record passed to it
run ::
     a                                                      -- ^ the record containing the default values
     -> (Gram (P (Str Char String Int)) (a -> a), String)   -- ^ the specification of the various options
     -> String                                              -- ^ The string containing the given options, separated by EOT
     -> Either (OptionResult a) [Char]                      -- ^ The result is either an updated record (`Succes`) with options or a request for `Help`. In case of erroneous input an error message is returned.

run defaults (p, t) inp = do  let r@(a, errors) =  parse ((,) <$> (   Succes <$> (mkP p <*> pure defaults)
                                                                  <|> Help t <$ pToken "--help\EOT"
                                                                  ) 
                                                              <*> pEnd
                                                         ) (createStr 0 inp)
                              if null errors then  Left a
                                             else  Right (t ++ concat (map (++"\n") ("\n--  Correcting steps:":  map show errors)))