UU-options ported to lens from lenses

Interleaved.hs

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

module Options.UU.Interleaved where
import Control.Lens hiding (set)
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)


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

-- 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 b d = forall a.
     ALens' a b
     -> d
     -> (Gram (P (Str Char String Int)) (a -> a), [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 #%~) <$> p) 


required_ :: ALens' a b
      -> ([Char]
         , OptionParser (b -> b)
         , String
         , String
         , String)
      -> (Gram (P (Str Char String Int)) (a -> a), [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"   *> 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 recrod 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 enetry 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)

-- tl :: ALens' a [a] -> ALens' a a
tl x = x . mapped

-- | 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 ( (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 filed 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; at least 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 `choose` entry is an optional `change` 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 => ALens' a b -> (f (b -> b),t) -> (f (a -> a), t)
field s opts = let (p, t) = opts in ((s #%~) <$> 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)))