0 | module DepGraph.Cli
  1 |
  2 | import Data.List1
  3 | import Data.String
  4 | import System
  5 |
  6 | %default total
  7 |
  8 | public export
  9 | record ModOpts where
 10 |   constructor MkModOpts
 11 |   withExternal : Bool
 12 |
 13 | public export
 14 | record PkgOpts where
 15 |   constructor MkPkgOpts
 16 |   localOnly : Bool
 17 |
 18 | ||| CLOpt - possible command line options
 19 | public export
 20 | data CLOpt
 21 |   =
 22 |   ||| Module import graph
 23 |   Module ModOpts |
 24 |   ||| Package dependency graph
 25 |   Package PkgOpts |
 26 |   ||| The input Idris file
 27 |   InputFile String |
 28 |   ||| Display help text
 29 |   Help |
 30 |   ||| Display app version
 31 |   Version
 32 |
 33 | data OptType
 34 |   = Required String
 35 |   | Optional String
 36 |   | Flag String
 37 |
 38 | public export
 39 | data SubCmd =
 40 |   ||| Module import graph
 41 |   SubCmdMod ModOpts |
 42 |   ||| Package dependency graph
 43 |   SubCmdPkg PkgOpts
 44 |
 45 | Show OptType where
 46 |   show (Required a) = "<" ++ a ++ ">"
 47 |   show (Optional a) = "[" ++ a ++ "]"
 48 |   show (Flag a) = "[--" ++ a ++ "]"
 49 |
 50 | ActType : List OptType -> Type
 51 | ActType [] = List CLOpt
 52 | ActType (Required a :: as) = String -> ActType as
 53 | ActType (Optional a :: as) = Maybe String -> ActType as
 54 | ActType (Flag a :: as) = Bool -> ActType as
 55 |
 56 | record OptDesc where
 57 |   constructor MkOpt
 58 |   flags : List String
 59 |   argdescs : List OptType
 60 |   action : ActType argdescs
 61 |   help : Maybe String
 62 |
 63 | optSeparator : OptDesc
 64 | optSeparator = MkOpt [] [] [] Nothing
 65 |
 66 | showDefault : Show a => a -> String
 67 | showDefault x = "(default " ++ show x ++ ")"
 68 |
 69 | options : List OptDesc
 70 | options =
 71 |   [ MkOpt ["package", "pkg", "p"] [Flag "local-only"]
 72 |       (\localOnly => [Package $ MkPkgOpts {localOnly}])
 73 |       (Just "(default) Generate a package dependency graph")
 74 |   , MkOpt ["module", "mod", "m"] [Flag "with-external"]
 75 |       (\withExternal => [Module $ MkModOpts {withExternal}])
 76 |       (Just "Generate a module import graph")
 77 |   , MkOpt ["--help", "-h", "-?"] [] [Help]
 78 |       (Just "Display help text")
 79 |   , MkOpt ["--version", "-v"] [] [Version]
 80 |       (Just "Display version string")
 81 |   ]
 82 |
 83 | optShow : OptDesc -> (String, Maybe String)
 84 | optShow (MkOpt [] _ _ _) = ("", Just "")
 85 | optShow (MkOpt flags argdescs action help) =
 86 |   (showSep ", " flags ++ " " ++ showSep " " (map show argdescs), help)
 87 |   where
 88 |     showSep : String -> List String -> String
 89 |     showSep sep [] = ""
 90 |     showSep sep [x] = x
 91 |     showSep sep (x :: xs) = x ++ sep ++ showSep sep xs
 92 |
 93 | firstColumnWidth : Nat
 94 | firstColumnWidth = foldr max 0 $ map (length . fst . optShow) options
 95 |
 96 | makeTextFromOptionsOrEnvs : List (String, Maybe String) -> String
 97 | makeTextFromOptionsOrEnvs rows = concatMap (optUsage firstColumnWidth) rows
 98 |   where
 99 |     optUsage : Nat -> (String, Maybe String) -> String
100 |     optUsage maxOpt (optshow, help) =
101 |       maybe
102 |         ""  -- Don't show anything if there's no help string (that means
103 |             -- it's an internal option)
104 |         (\h =>
105 |           "  " ++ optshow ++
106 |           pack (List.replicate (minus (maxOpt + 2) (length optshow)) ' ') ++
107 |           h ++ "\n")
108 |         help
109 |
110 | optsUsage : String
111 | optsUsage = makeTextFromOptionsOrEnvs $ map optShow options
112 |
113 | -- TODO get version from .ipkg
114 | export
115 | versionMsg : String
116 | versionMsg = "Dep-graph version 0.1.0"
117 |
118 | export
119 | usage : String
120 | usage = """
121 |   \{ versionMsg }
122 |   Usage: dep-graph [options] [ipkg file...]
123 |
124 |   Available options:
125 |   \{ optsUsage }
126 |   """
127 |
128 | processArgs : String -> (args : List OptType) -> List String -> ActType args ->
129 |               Either String (List CLOpt, List String)
130 | processArgs flag [] xs f = Right (f, xs)
131 | -- Missing required arguments
132 | processArgs flag (opt@(Required _) :: as) [] f =
133 |   Left $ "Missing required argument " ++ show opt ++ " for flag " ++ flag
134 | processArgs flag (Optional a :: as) [] f =
135 |   processArgs flag as [] (f Nothing)
136 | processArgs flag (Flag a :: as) [] f =
137 |   processArgs flag as [] (f False)
138 | -- Happy cases
139 | processArgs flag (Required a :: as) (x :: xs) f =
140 |   processArgs flag as xs (f x)
141 | processArgs flag (Optional a :: as) (x :: xs) f =
142 |   if isPrefixOf "-" x
143 |     then processArgs flag as (x :: xs) (f Nothing)
144 |     else processArgs flag as xs (f $ Just x)
145 | processArgs flag (Flag a :: as) (x :: xs) f =
146 |   if x == "--" ++ a
147 |     then processArgs flag as xs (f True)
148 |     else processArgs flag as (x :: xs) (f False)
149 |
150 | matchFlag : (d : OptDesc) -> List String ->
151 |             Either String (Maybe (List CLOpt, List String))
152 | matchFlag d [] = Right Nothing -- Nothing left to match
153 | matchFlag d (x :: xs) =
154 |   if x `elem` flags d
155 |     then do
156 |       args <- processArgs x (argdescs d) xs (action d)
157 |       Right (Just args)
158 |     else Right Nothing
159 |
160 | findMatch : List OptDesc -> List String ->
161 |             Either String (List CLOpt, List String)
162 | findMatch [] [] = Right ([], [])
163 | findMatch [] (f :: args) =
164 |   case unpack f of
165 |     '-' :: '-' :: _ => Left "Unknown flag \{f}"
166 |     _ => Right ([InputFile f], args)
167 | findMatch (d :: ds) args =
168 |   case !(matchFlag d args) of
169 |     Nothing => findMatch ds args
170 |     Just res => Right res
171 |
172 | parseOpts : List OptDesc -> List String -> Either String (List CLOpt)
173 | parseOpts opts [] = Right []
174 | parseOpts opts args = do
175 |   (cl, rest) <- findMatch opts args
176 |   cls <- assert_total (parseOpts opts rest) -- 'rest' smaller than 'args'
177 |   pure (cl ++ cls)
178 |
179 | export
180 | getCmdOpts : IO (Either String (List CLOpt))
181 | getCmdOpts = do
182 |   (_ :: opts) <- getArgs
183 |     | _ => pure (Left "Invalid command line")
184 |   pure $ parseOpts options opts
185 |
186 | export
187 | findInputs : List CLOpt -> List String
188 | findInputs [] = []
189 | findInputs (InputFile f :: fs) = f :: findInputs fs
190 | findInputs (_ :: fs) = findInputs fs
191 |
192 | export
193 | quitOpts : List CLOpt -> IO Bool
194 | quitOpts [] = pure True
195 | quitOpts (Version :: _) = do
196 |   putStrLn versionMsg
197 |   pure False
198 | quitOpts (Help :: _) = do
199 |   putStrLn usage
200 |   pure False
201 | quitOpts (_ :: opts) = quitOpts opts
202 |
203 | export
204 | subCmd : List CLOpt -> SubCmd
205 | subCmd [] = SubCmdPkg $ MkPkgOpts {localOnly = False} -- default
206 | subCmd (Module opts :: _) = SubCmdMod opts
207 | subCmd (Package opts :: _) = SubCmdPkg opts
208 | subCmd (f :: fs) = subCmd fs
209 |