Got basic cmd-args parsing

app/Main.hs

@@ -8,9 +8,6 @@ Maintainer : [email protected]
 Stability : experimental
 Portability : non-portable (MPTC with FD, FFI to Linux-only c-code)
 
-The entry-point to KMonad that simply imports the relevant modules and strings
-them together. For the actual implementation details see "KMonad.Api.App"
-
 -}
 module Main
  ( -- * The entry-point to KMonad
@@ -19,7 +16,8 @@ module Main
 where
 
 import KPrelude
-import KMonad.Runner (kmonad)
+import KMonad.Args.Cmd
+import KMonad.App
 
 main :: IO ()
-main = kmonad
+main = getCmd >>= print

kmonad.cabal

@@ -18,12 +18,22 @@ library
  KPrelude
  Data.LayerStack
  Data.MultiMap
+ KMonad.Action
+ KMonad.App
+ KMonad.App.Dispatch
+ KMonad.App.Hooks
+ KMonad.App.PressHandler
+ KMonad.App.Sluice
+ KMonad.Args.Cmd
+ KMonad.Button
  KMonad.Keyboard
+ KMonad.Keyboard.Keycode
  KMonad.Keyboard.ComposeSeq
  KMonad.Keyboard.IO
  KMonad.Keyboard.IO.Linux.DeviceSource
  KMonad.Keyboard.IO.Linux.Types
  KMonad.Keyboard.IO.Linux.UinputSink
+ KMonad.Util
  -- KLisp
  -- KLisp.Joiner
  -- KLisp.Parser
@@ -61,7 +71,6 @@ library
  hs-source-dirs:
  src
  default-extensions:
- AutoDeriveTypeable
  BangPatterns
  BinaryLiterals
  ConstraintKinds
@@ -84,7 +93,6 @@ library
  InstanceSigs
  KindSignatures
  LambdaCase
- MonadFailDesugaring
  MultiParamTypeClasses
  MultiWayIf
  NamedFieldPuns
@@ -136,49 +144,49 @@ executable kmonad
  other-modules:
  -- Paths_kmonad
  default-extensions:
- AutoDeriveTypeable
- BangPatterns
- BinaryLiterals
- ConstraintKinds
- DataKinds
- DefaultSignatures
- DeriveDataTypeable
- DeriveFoldable
- DeriveFunctor
- DeriveGeneric
- DeriveTraversable
- DerivingStrategies
- DoAndIfThenElse
- EmptyDataDecls
- ExistentialQuantification
- FlexibleContexts
- FlexibleInstances
- FunctionalDependencies
- GADTs
- GeneralizedNewtypeDeriving
- InstanceSigs
- KindSignatures
- LambdaCase
- MonadFailDesugaring
- MultiParamTypeClasses
- MultiWayIf
- NamedFieldPuns
+ -- AutoDeriveTypeable
+ -- BangPatterns
+ -- BinaryLiterals
+ -- ConstraintKinds
+ -- DataKinds
+ -- DefaultSignatures
+ -- DeriveDataTypeable
+ -- DeriveFoldable
+ -- DeriveFunctor
+ -- DeriveGeneric
+ -- DeriveTraversable
+ -- DerivingStrategies
+ -- DoAndIfThenElse
+ -- EmptyDataDecls
+ -- ExistentialQuantification
+ -- FlexibleContexts
+ -- FlexibleInstances
+ -- FunctionalDependencies
+ -- GADTs
+ -- GeneralizedNewtypeDeriving
+ -- InstanceSigs
+ -- KindSignatures
+ -- LambdaCase
+ -- MonadFailDesugaring
+ -- MultiParamTypeClasses
+ -- MultiWayIf
+ -- NamedFieldPuns
  NoImplicitPrelude
- OverloadedStrings
- PartialTypeSignatures
- PatternGuards
- PolyKinds
- RankNTypes
- RecordWildCards
- ScopedTypeVariables
- StandaloneDeriving
- TemplateHaskell
- TupleSections
- TypeApplications
- TypeOperators
- TypeFamilies
- TypeSynonymInstances
- ViewPatterns
+ -- OverloadedStrings
+ -- PartialTypeSignatures
+ -- PatternGuards
+ -- PolyKinds
+ -- RankNTypes
+ -- RecordWildCards
+ -- ScopedTypeVariables
+ -- StandaloneDeriving
+ -- TemplateHaskell
+ -- TupleSections
+ -- TypeApplications
+ -- TypeOperators
+ -- TypeFamilies
+ -- TypeSynonymInstances
+ -- ViewPatterns
  hs-source-dirs:
  app
  ghc-options:

src/KLisp.hs

@@ -17,14 +17,14 @@ where
 
 import KPrelude
 
-import KMonad.Daemon
+import KMonad.App
 
 import KLisp.Parser
 import KLisp.Joiner
 import KLisp.Types
 
 -- | Parse a configuration file into a 'DaemonCfg' record
-loadConfig :: HasLogFunc e => FilePath -> RIO e DaemonCfg
+loadConfig :: HasLogFunc e => FilePath -> RIO e AppCfg
 loadConfig pth = do
  lf <- view logFuncL
  tks <- loadTokens pth -- This can throw a parse-error

src/KMonad.hs

@@ -1,12 +1,3 @@
 module KMonad
- ( module X
- )
+ ()
 where
-
-import KMonad.Action as X
-import KMonad.Button as X
-import KMonad.Daemon as X
-import KMonad.Event as X
-import KMonad.Keyboard as X
-import KMonad.Runner as X
-import KMonad.Util as X

src/KMonad/App.hs

@@ -167,22 +167,22 @@ instance HasLogFunc KEnv where logFuncL = kAppEnv.logFuncL
 -- | Hook up all the components to the different 'MonadK' functionalities
 instance MonadK (RIO KEnv) where
  -- Emitting with the keysink
- emit e  = view keySink >>= flip emitKey e
+ emit e = view keySink >>= flip emitKey e
 
  -- Pausing is a simple IO action
- pause  = threadDelay . (*1000) . fromIntegral
+ pause = threadDelay . (*1000) . fromIntegral
 
  -- Holding and rerunning through the sluice and dispatch
- hold b  = do
+ hold b = do
  sl <- view sluice
  di <- view dispatch
  if b then Sl.block sl else Sl.unblock sl >>= Dp.rerun di
 
  -- Binding is found in the stored 'BEnv'
- myBinding  = view (bEnv.binding)
+ myBinding = view (bEnv.binding)
 
  -- Hooking is performed with the hooks component
- hookNext t f = view hooks >>= \hs -> Hs.hookNext hs t f
+ hookNext t f = view hooks >>= \hs -> Hs.hookNext  hs  t f
  hookWithin ms t f = view hooks >>= \hs -> Hs.hookWithin hs ms t f
 
  -- Layer-ops are sent to the 'PressHandler'

src/KMonad/Args.hs

@@ -0,0 +1,38 @@
+{-|
+Module : KMonad.Args
+Description : How to parse arguments and config files into an AppCfg
+Copyright : (c) David Janssen, 2019
+License : MIT
+
+Maintainer : [email protected]
+Stability : experimental
+Portability : non-portable (MPTC with FD, FFI to Linux-only c-code)
+
+-}
+module KMonad.Args
+ (loadConfig)
+where
+
+import KPrelude
+import KMonad.App
+
+
+-- | Parse a configuration file into a 'DaemonCfg' record
+loadConfig :: HasLogFunc e => FilePath -> RIO e AppCfg
+loadConfig pth = do
+ undefined
+ -- lf <- view logFuncL
+ -- tks <- loadTokens pth -- This can throw a parse-error
+ -- cfg <- joinConfigIO tks -- This can throw a JoinError
+
+ -- -- Try loading the sink and src
+ -- snk <- liftIO . _snk cfg $ lf
+ -- src <- liftIO . _src cfg $ lf
+
+ -- -- Assemble the DaemonCfg record
+ -- pure $ AppCfg
+ -- { _keySinkDev = snk
+ -- , _keySourceDev = src
+ -- , _keymapCfg = _km cfg
+ -- , _firstLayer = _fstL cfg
+ -- }

src/KMonad/Args/Cmd.hs

@@ -0,0 +1,82 @@
+{-|
+Module : KMonad.Args.Cmd
+Description : Parse command-line options into a 'Cmd' for KMonad to execute
+Copyright : (c) David Janssen, 2019
+License : MIT
+
+Maintainer : [email protected]
+Stability : experimental
+Portability : non-portable (MPTC with FD, FFI to Linux-only c-code)
+
+-}
+module KMonad.Args.Cmd
+ ( Cmd(..)
+ , HasCmd(..)
+ , getCmd
+ )
+where
+
+import KPrelude
+
+import Options.Applicative
+
+
+
+--------------------------------------------------------------------------------
+-- $cmd
+--
+-- The different things KMonad can be instructed to do.
+
+-- | Record of the different KMonad settings
+data Cmd = Cmd
+ { _cfgFile :: FilePath -- ^ Which file to read the config from
+ , _dryRun :: Bool -- ^ Flag to indicate we are only test-parsing
+ , _logLvl :: LogLevel -- ^ Level of logging to use
+ }
+ deriving Show
+makeClassy ''Cmd
+
+-- | Parse 'RunCfg' from the evocation of this program
+getCmd :: IO Cmd
+getCmd = customExecParser (prefs showHelpOnEmpty) $ info (cmdP <**> helper)
+ ( fullDesc
+ <> progDesc "Start KMonad"
+ <> header "kmonad - an onion of buttons."
+ )
+
+
+--------------------------------------------------------------------------------
+-- $prs
+--
+-- The different command-line parsers
+
+-- | Parse the full command
+cmdP :: Parser Cmd
+cmdP = Cmd <$> fileP <*> dryrunP <*> levelP
+
+-- | Parse a filename that points us at the config-file
+fileP :: Parser FilePath
+fileP = strArgument
+ ( metavar "FILE"
+ <> help "The configuration file")
+
+-- | Parse a flag that allows us to switch to parse-only mode
+dryrunP :: Parser Bool
+dryrunP = switch
+ ( long "dry-run"
+ <> short 'd'
+ <> help "If used, do not start KMonad, only try parsing the config file"
+ )
+
+-- | Parse the log-level as either a level option or a verbose flag
+levelP :: Parser LogLevel
+levelP = option f
+ ( long "log-level"
+ <> short 'l'
+ <> metavar "Log level"
+ <> value LevelWarn
+ <> help "How much info to print out (debug, info, warn, error)" )
+ where
+ f = maybeReader $ flip lookup [ ("debug", LevelDebug), ("warn", LevelWarn)
+ , ("info", LevelInfo), ("error", LevelError) ]
+

src/KMonad/Keyboard/IO/Linux/Types.hs

@@ -58,7 +58,7 @@ newtype LinuxKeyEvent = LinuxKeyEvent (CInt, CInt, CInt, CInt, CInt)
 
 instance Display LinuxKeyEvent where
  textDisplay (LinuxKeyEvent (s, ns, typ, c, val)) = mconcat
- [ textDisplay $ mkTime s ns , ": "
+ [ tshow s, ".", tshow ns, ": "
  , "type: ", tshow typ, ", "
  , "code: ", tshow c, ", "
  , "val: ", tshow val

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-14.7
+resolver: lts-15.12
 packages:
 - .
 extra-deps: