diff options
| -rw-r--r-- | cabal.project | 1 | ||||
| -rw-r--r-- | fig-cli/fig-cli.cabal | 58 | ||||
| -rw-r--r-- | fig-cli/main/Main.hs | 8 | ||||
| -rw-r--r-- | fig-cli/src/Fig/CLI.hs | 27 | ||||
| -rw-r--r-- | fig-utils/src/Fig/Utils/SExpr.hs | 37 | ||||
| -rw-r--r-- | flake.nix | 2 | ||||
| -rw-r--r-- | hie.yaml | 4 |
7 files changed, 128 insertions, 9 deletions
diff --git a/cabal.project b/cabal.project index 154c8f8..a353721 100644 --- a/cabal.project +++ b/cabal.project @@ -6,4 +6,5 @@ packages: fig-monitor-irc/ fig-bridge-irc-discord/ fig-web/ + fig-cli/ optimization: 2 diff --git a/fig-cli/fig-cli.cabal b/fig-cli/fig-cli.cabal new file mode 100644 index 0000000..625d311 --- /dev/null +++ b/fig-cli/fig-cli.cabal @@ -0,0 +1,58 @@ +cabal-version: 3.4 +name: fig-cli +version: 0.1.0.0 + +common defaults + ghc-options: -Wall + default-language: GHC2021 + default-extensions: NoImplicitPrelude PackageImports LambdaCase MultiWayIf OverloadedStrings OverloadedLists OverloadedRecordDot DuplicateRecordFields RecordWildCards NoFieldSelectors BlockArguments ViewPatterns TypeFamilies DataKinds GADTs + +common deps + build-depends: + base + , aeson + , base64 + , binary + , bytestring + , containers + , data-default-class + , directory + , errors + , filepath + , hedis + , http-types + , http-client + , http-client-tls + , lens + , megaparsec + , mtl + , network + , optparse-applicative + , process + , random + , req + , safe-exceptions + , text + , time + , tomland + , transformers + , unordered-containers + , uuid + , vector + , fig-utils + , fig-bus + +library + import: defaults + import: deps + hs-source-dirs: src + exposed-modules: + Fig.CLI + +executable fig-cli + import: defaults + import: deps + build-depends: fig-cli, optparse-applicative + hs-source-dirs: + main + main-is: Main.hs diff --git a/fig-cli/main/Main.hs b/fig-cli/main/Main.hs new file mode 100644 index 0000000..139b9b7 --- /dev/null +++ b/fig-cli/main/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import Fig.Prelude + +import qualified Fig.CLI as CLI + +main :: IO () +main = CLI.main diff --git a/fig-cli/src/Fig/CLI.hs b/fig-cli/src/Fig/CLI.hs new file mode 100644 index 0000000..36df60d --- /dev/null +++ b/fig-cli/src/Fig/CLI.hs @@ -0,0 +1,27 @@ +{-# Language ApplicativeDo #-} + +module Fig.CLI where + +import Fig.Prelude + +import Options.Applicative + +import Fig.Utils.SExpr + +newtype Opts = Opts + { sexpr :: Text + } + +parseOpts :: Parser Opts +parseOpts = do + sexpr <- strArgument (metavar "SEXPR" <> help "S-expression to parse") + pure Opts{..} + +main :: IO () +main = do + opts <- execParser $ info (parseOpts <**> helper) + ( fullDesc + <> Options.Applicative.header "fig-cli - assorted tools" + ) + let sexp = parseSExpr opts.sexpr + log $ tshow (sexp, pretty <$> sexp) diff --git a/fig-utils/src/Fig/Utils/SExpr.hs b/fig-utils/src/Fig/Utils/SExpr.hs index 53a50a5..8156312 100644 --- a/fig-utils/src/Fig/Utils/SExpr.hs +++ b/fig-utils/src/Fig/Utils/SExpr.hs @@ -13,14 +13,13 @@ import qualified Language.Haskell.TH.Syntax as Q import Fig.Prelude -import Control.Monad (fail) +import Control.Monad (fail, mzero) import Data.Data (Data, cast) import Data.Char (isSpace) import Text.Megaparsec import Text.Megaparsec.Char -import Text.Megaparsec.Char.Lexer data SExprWith :: Type -> Type where SExprExt :: forall a. a -> SExprWith a @@ -35,10 +34,20 @@ deriving instance Ord a => Ord (SExprWith a) deriving instance Data a => Data (SExprWith a) deriving instance Functor SExprWith +escapeStr :: Char -> [Char] +escapeStr c + | elem @[] c ['\\', '"'] || isSpace c = ['\\', c] + | otherwise = [c] + +escapeSym :: Char -> [Char] +escapeSym c + | elem @[] c ['\\', '"', '.', '(', ')'] || isSpace c = ['\\', c] + | otherwise = [c] + instance Pretty a => Pretty (SExprWith a) where pretty (SExprExt x) = pretty x - pretty (SExprSymbol s) = s - pretty (SExprString s) = tshow s + pretty (SExprSymbol s) = pack . mconcat $ escapeSym <$> unpack s + pretty (SExprString s) = mconcat ["\"", pack . mconcat $ escapeStr <$> unpack s, "\""] pretty (SExprInteger i) = tshow i pretty (SExprFloat f) = tshow f pretty (SExprList xs) = "(" <> unwords (pretty <$> xs) <> ")" @@ -50,17 +59,27 @@ type Parser = Parsec Void Text sexprWith :: forall a. Parser a -> Parser (SExprWith a) sexprWith ext = spaces *> ( SExprExt <$> ext - <|> SExprString . pack <$> (char '"' *> manyTill charLiteral (char '"')) - <|> SExprInteger <$> decimal - <|> SExprFloat <$> float - <|> SExprSymbol . pack <$> some symchar + <|> SExprString . pack <$> (char '"' *> manyTill ((char '\\' *> anySingle) <|> strchar) (char '"')) + <|> parseNumber + <|> SExprSymbol . pack <$> some ((char '\\' *> anySingle) <|> symchar) <|> SExprList <$> (char '(' *> spaces *> many (spaces *> sexprWith ext <* spaces) <* char ')') ) where spaces = many spaceChar symchar = satisfy $ \c -> not (isSpace c || c `elem` special) + strchar = satisfy (/='"') special :: [Char] - special = "()" + special = "\".()" + classifyNumber :: [Char] -> Parser (SExprWith a) + classifyNumber str = do + let + res = if '.' `elem` str then SExprFloat <$> readMaybe str else SExprInteger <$> readMaybe str + maybe mzero pure res + parseNumber :: Parser (SExprWith a) + parseNumber = do + leading <- many digitChar + trailing <- optional $ char '.' *> many digitChar + classifyNumber $ leading <> maybe "" (\x -> if null x then "" else "." <> x) trailing parseSExprWith :: Parser a -> Text -> Maybe (SExprWith a) parseSExprWith ext inp = case runParser (sexprWith ext) "" inp of @@ -45,6 +45,7 @@ fig-monitor-irc = self.callCabal2nix "fig-monitor-irc" ./fig-monitor-irc {}; fig-bridge-irc-discord = self.callCabal2nix "fig-bridge-irc-discord" ./fig-bridge-irc-discord {}; fig-web = self.callCabal2nix "fig-web" ./fig-web {}; + fig-cli = self.callCabal2nix "fig-cli" ./fig-cli {}; }; haskellPackages = pkgs.haskell.packages.ghc94.override { overrides = haskellOverrides; @@ -407,6 +408,7 @@ fig-monitor-irc fig-bridge-irc-discord fig-web + fig-cli ]; withHoogle = true; buildInputs = [ @@ -26,3 +26,7 @@ cradle: config: { cradle: { cabal: { component: "fig-web:lib:fig-web" } } } - path: "./fig-web/main/" config: { cradle: { cabal: { component: "fig-web:exe:fig-web" } } } + - path: "./fig-cli/src/" + config: { cradle: { cabal: { component: "fig-cli:lib:fig-cli" } } } + - path: "./fig-cli/main/" + config: { cradle: { cabal: { component: "fig-cli:exe:fig-cli" } } } |