Symantic/CLI/Test.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE NoMonomorphismRestriction #-}
   4 {-# LANGUAGE TypeApplications #-}
   5 {-# LANGUAGE UndecidableInstances #-}
   6 module Symantic.CLI.Test where
   7
   8 -- import Data.Monoid (Monoid(..))
   9 -- import Data.Ord (Ord(..))
  10 -- import Text.Show (Show(..))
  11 import Control.Applicative (Applicative(..), Alternative(..))
  12 import Control.Monad (Monad(..))
  13 import Data.Bool
  14 import Data.Ord (Ord(..))
  15 import Data.Either (Either(..))
  16 import Data.Function (($), (.))
  17 import Data.Functor ((<$>))
  18 import Data.List.NonEmpty (NonEmpty(..))
  19 import Data.Maybe (Maybe(..))
  20 import Data.Semigroup (Semigroup(..))
  21 import Data.String (String)
  22 import Data.Void (Void)
  23 import Text.Show (Show(..))
  24 import Type.Reflection (Typeable)
  25 import System.IO (IO, print, stderr, putStrLn)
  26 import System.Environment (getArgs)
  27 import Data.Int (Int)
  28 import qualified Data.Set as Set
  29 import qualified Data.Text.Lazy.IO as TL
  30 import qualified Symantic.Document.Term as Doc
  31 import qualified Symantic.Document.Term.IO as DocIO
  32 import qualified System.IO as IO
  33
  34 import Symantic.CLI
  35
  36 data Opts = Opts
  37  { opts_git_dir   :: String
  38  , opts_work_tree :: String
  39  , opts_int       :: Int
  40  } deriving (Show)
  41
  42 api =
  43         -- rule "main" $
  44         (rule "OPTIONS" $
  45                 Opts <$> longOpt "git-dir" "GIT_DIR" (var "path")
  46                      <*> longOpt "work-tree" "X" (var "path")
  47                      <*> longOpt "int" 0 (var "name"))
  48         <?>
  49         rule "INFOS" (
  50                 api_clone
  51                 <!> api_push
  52                 <!> api_fetch
  53                 <!> api_help
  54                 <!> api_version
  55         )
  56
  57 help_ d = help (d::DocIO.TermIO)
  58
  59 api_help =
  60         help_ "print some help" $
  61         tagged (Tag 'h' "help") nothing
  62         <.> response @DocIO.TermIO
  63
  64 api_version =
  65         help_ "print the version" $
  66         tagged (TagLong "version") nothing
  67         <.> response @String
  68
  69 api_clone =
  70         help_ "cloned" $
  71         command "clone" $
  72                 (Clone <$> longOpt "branch" "master" (var "name"))
  73                 <?> response @(Opts,Clone)
  74
  75 api_push =
  76         command "push" $
  77                 (Push <$> longOpt "set-upstream" False (just True)
  78                       <*> longOpt "all" False (just True))
  79                 <?> endOpts
  80                 <.> many1 (var @String "refspec")
  81                 <.> response @(Opts,Push,[String])
  82
  83 api_fetch =
  84         command "fetch" $
  85                 response @Opts
  86
  87 data Clone = Clone String
  88  deriving (Show)
  89 data Push = Push Bool Bool
  90  deriving (Show)
  91
  92 doc0 = DocIO.runTermIO IO.stderr $ plainDoc api
  93 help0 = DocIO.runTermIO IO.stderr $ helpDoc api
  94 route_git gitOpts =
  95         route_clone :!:
  96         route_push  :!:
  97         route_fetch :!:
  98         route_help  :!:
  99         route_version
 100         where
 101         route_help    = return $ helpDoc api
 102         route_version = return "1.0"
 103         route_clone (cloneOpts::Clone) =
 104                 return (gitOpts,cloneOpts)
 105         route_push pushOpts refs =
 106                 return (gitOpts,pushOpts,refs)
 107         route_fetch =
 108                 return (gitOpts)
 109
 110 instance Typeable (a,b) => IOType (a,b)
 111 instance Typeable (a,b,c) => IOType (a,b,c)
 112 instance IOType Opts
 113 instance (Show (a,b), Typeable (a,b)) => Outputable (a,b)
 114 instance (Show (a,b,c), Typeable (a,b,c)) => Outputable (a,b,c)
 115 instance Outputable Opts
 116
 117 parser0 = parser api route_git
 118 main :: IO ()
 119 main = do
 120         args <- getArgs
 121         putStrLn $ "args: " <> show args
 122         parser0 $ parseArgs args