From e9a53b69ad68e531a789eff3128f7304fd411808 Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Wed, 15 Apr 2020 15:24:32 -0700 Subject: Lint fixes, also delete Biz.Language --- Alpha.hs | 2 +- Biz/Ibb/Client.hs | 1 - Biz/Ibb/Core.hs | 6 +- Biz/Ibb/Influencers.hs | 2 - Biz/Ibb/Keep.hs | 6 +- Biz/Ibb/Look.hs | 4 +- Biz/Ibb/Server.hs | 18 ++-- Biz/Language/Bs.hs | 13 --- Biz/Language/Bs/Cli.hs | 64 ------------ Biz/Language/Bs/Eval.hs | 224 ------------------------------------------ Biz/Language/Bs/Expr.hs | 139 -------------------------- Biz/Language/Bs/Parser.hs | 129 ------------------------ Biz/Language/Bs/Primitives.hs | 188 ----------------------------------- Biz/Language/Bs/Repl.hs | 36 ------- Biz/Language/Bs/Test.hs | 2 - Hero/App.hs | 38 +++---- Hero/Client.hs | 10 +- Hero/Database.hs | 2 - Hero/Look.hs | 67 ++++++------- Hero/Server.hs | 8 +- Que/Server.hs | 12 +-- Que/Website.hs | 4 +- Que/client.py | 49 ++++----- System/Random/Shuffle.hs | 13 ++- 24 files changed, 114 insertions(+), 923 deletions(-) delete mode 100644 Biz/Language/Bs.hs delete mode 100644 Biz/Language/Bs/Cli.hs delete mode 100644 Biz/Language/Bs/Eval.hs delete mode 100644 Biz/Language/Bs/Expr.hs delete mode 100644 Biz/Language/Bs/Parser.hs delete mode 100644 Biz/Language/Bs/Primitives.hs delete mode 100644 Biz/Language/Bs/Repl.hs delete mode 100644 Biz/Language/Bs/Test.hs diff --git a/Alpha.hs b/Alpha.hs index 8f823da..afcd59d 100644 --- a/Alpha.hs +++ b/Alpha.hs @@ -49,7 +49,7 @@ import Protolude as X -- | Debugging printf say :: Text -> IO () -say msg = putStrLn msg +say = putText -- | Alias for map, fmap, <$> ( (a -> b) -> f a -> f b diff --git a/Biz/Ibb/Client.hs b/Biz/Ibb/Client.hs index 89e0ffc..c3dae4b 100644 --- a/Biz/Ibb/Client.hs +++ b/Biz/Ibb/Client.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} diff --git a/Biz/Ibb/Core.hs b/Biz/Ibb/Core.hs index 2c1fbae..007d835 100644 --- a/Biz/Ibb/Core.hs +++ b/Biz/Ibb/Core.hs @@ -83,7 +83,7 @@ data Action deriving (Show, Eq) home :: Model -> View Action -home m = see m +home = see handlers :: Model -> View Action handlers = home @@ -134,7 +134,7 @@ seePerson person = [] [ a_ [ class_ "fab fa-twitter", - href_ $ "https://twitter.com/" <> (ms $ _twitter person) + href_ $ "https://twitter.com/" <> ms (_twitter person) ] [], a_ [class_ "fas fa-globe", href_ $ ms $ _website person] [] @@ -151,7 +151,7 @@ seeBook book = [] [ a_ [ class_ "text-dark", - href_ $ "https://www.amazon.com/dp/" <> (ms $ _amznref book) + href_ $ "https://www.amazon.com/dp/" <> ms (_amznref book) ] [text $ ms $ _title book] ] diff --git a/Biz/Ibb/Influencers.hs b/Biz/Ibb/Influencers.hs index cf53cc0..08ce3e8 100644 --- a/Biz/Ibb/Influencers.hs +++ b/Biz/Ibb/Influencers.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} module Biz.Ibb.Influencers where diff --git a/Biz/Ibb/Keep.hs b/Biz/Ibb/Keep.hs index d546aae..8ee1228 100644 --- a/Biz/Ibb/Keep.hs +++ b/Biz/Ibb/Keep.hs @@ -27,7 +27,7 @@ import qualified Data.Text as Text -- * Keep -- | Main database. Need to think of a better name for this. -data IbbKeep +newtype IbbKeep = IbbKeep { _people :: IxSet Person } @@ -79,9 +79,7 @@ newPerson name blurb = do } getPeople :: Int -> Acid.Query IbbKeep [Person] -getPeople n = do - keep <- ask - return $ take n $ IxSet.toList $ _people keep +getPeople n = take n $ IxSet.toList $ _people keep lookupEnv "STATIC_DIR" :: IO [Char] - port <- read <$> fromMaybe "3000" <$> lookupEnv "PORT" :: IO Int + staticDir <- fromMaybe "static" <$> lookupEnv "STATIC_DIR" :: IO String + port <- (read . fromMaybe "3000" <$> lookupEnv "PORT") :: IO Int keep <- Keep.openLocal "_keep/" say "port: 3000" - run port $ logStdout $ compress $ app staticDir $ keep + run port $ logStdout $ compress $ app staticDir keep where compress = gzip def {gzipFiles = GzipCompress} @@ -75,8 +73,7 @@ instance L.ToHtml a => L.ToHtml (HtmlPage a) where L.meta_ [L.charset_ "utf-8"] jsRef "/static/ibb.js" cssRef "/css/main.css" - L.body_ $ do - page + L.body_ page where page = L.toHtml x jsRef href = @@ -100,8 +97,7 @@ handle404 _ respond = $ responseLBS status404 [("Content-Type", "text/html")] $ renderBS $ toHtml - $ HtmlPage - $ notfound + $ HtmlPage notfound newtype CSS = CSS @@ -128,7 +124,7 @@ type Routes = cssHandlers :: Server CssRoute cssHandlers = return . Lazy.toStrict . Clay.render $ Look.main -app :: [Char] -> AcidState Keep.IbbKeep -> Application +app :: String -> AcidState Keep.IbbKeep -> Application app staticDir keep = serve (Proxy @Routes) $ static @@ -137,7 +133,7 @@ app staticDir keep = :<|> apiHandlers keep :<|> Tagged handle404 where - static = serveDirectoryWith (defaultWebAppSettings $ staticDir) + static = serveDirectoryWith (defaultWebAppSettings staticDir) type ApiRoutes = "people" :> Get '[JSON] [Person] diff --git a/Biz/Language/Bs.hs b/Biz/Language/Bs.hs deleted file mode 100644 index f2d4c9d..0000000 --- a/Biz/Language/Bs.hs +++ /dev/null @@ -1,13 +0,0 @@ --- https://github.com/write-you-a-scheme-v2/scheme --- https://github.com/justinethier/husk-scheme -module Language.Bs - ( module X, - ) -where - -import Language.Bs.Cli as X -import Language.Bs.Eval as X -import Language.Bs.Expr as X -import Language.Bs.Parser as X -import Language.Bs.Primitives as X -import Language.Bs.Repl as X diff --git a/Biz/Language/Bs/Cli.hs b/Biz/Language/Bs/Cli.hs deleted file mode 100644 index d2ac1e4..0000000 --- a/Biz/Language/Bs/Cli.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Bs.Cli - ( run, - ) -where - -import Data.String -import Data.Text.IO as TIO -import Language.Bs.Eval -- evalFile :: T.Text -> IO () -import Language.Bs.Repl -- Repl.mainLoop :: IO () -import Options.Applicative -import Protolude -import System.Directory - --- SOURCES ---http://book.realworldhaskell.org/read/io.html --- https://github.com/pcapriotti/optparse-applicative --- https://hackage.haskell.org/package/optparse-applicative - -runScript :: FilePath -> IO () -runScript fname = do - exists <- doesFileExist fname - if exists - then TIO.readFile fname >>= evalFile fname - else TIO.putStrLn "File does not exist." - -data LineOpts = UseReplLineOpts | RunScriptLineOpts String - -parseLineOpts :: Parser LineOpts -parseLineOpts = runScriptOpt <|> runReplOpt - where - runScriptOpt = - RunScriptLineOpts - <$> strOption - ( long "script" - <> short 's' - <> metavar "SCRIPT" - <> help "File containing the script you want to run" - ) - runReplOpt = - UseReplLineOpts - <$ flag' - () - ( long "repl" - <> short 'r' - <> help "Run as interavtive read/evaluate/print/loop" - ) - -schemeEntryPoint :: LineOpts -> IO () -schemeEntryPoint UseReplLineOpts = mainLoop --repl -schemeEntryPoint (RunScriptLineOpts script) = runScript script - -run :: IO () -run = execParser opts >>= schemeEntryPoint - where - opts = - info - (helper <*> parseLineOpts) - ( fullDesc - <> header "Executable binary for Write You A Scheme v2.0" - <> progDesc "contains an entry point for both running scripts and repl" - ) diff --git a/Biz/Language/Bs/Eval.hs b/Biz/Language/Bs/Eval.hs deleted file mode 100644 index 1198a3e..0000000 --- a/Biz/Language/Bs/Eval.hs +++ /dev/null @@ -1,224 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Bs.Eval - ( evalText, - evalFile, - runParseTest, - safeExec, - runASTinEnv, - basicEnv, - fileToEvalForm, - textToEvalForm, - getFileContents, - ) -where - -import Control.Exception -import Control.Monad.Reader -import qualified Data.Map as Map -import Data.String -import qualified Data.Text as T -import qualified Data.Text.IO as TIO -import Language.Bs.Expr -import Language.Bs.Parser -import Language.Bs.Primitives -import Protolude -import System.Directory - -funcEnv :: Map.Map T.Text Expr -funcEnv = - Map.fromList $ - primEnv - <> [ ("read", IFun $ IFunc $ unop readFn), - ("parse", IFun $ IFunc $ unop parseFn), - ("eval", IFun $ IFunc $ unop eval), - ("show", IFun $ IFunc $ unop (return . Tape . ppexpr)) - ] - -basicEnv :: Env -basicEnv = Env Map.empty funcEnv - -readFn :: Expr -> Eval Expr -readFn (Tape txt) = lineToEvalForm txt -readFn val = throw $ TypeMismatch "read expects string, instead got:" val - -parseFn :: Expr -> Eval Expr -parseFn (Tape txt) = either (throw . ParseError . show) return $ readExpr txt -parseFn val = throw $ TypeMismatch "parse expects string, instead got:" val - -safeExec :: IO a -> IO (Either String a) -safeExec m = do - result <- Control.Exception.try m - case result of - Left (eTop :: SomeException) -> - case fromException eTop of - Just (enclosed :: LispError) -> - return $ Left (show enclosed) - Nothing -> - return $ Left (show eTop) - Right val -> - return $ Right val - -runASTinEnv :: Env -> Eval b -> IO b -runASTinEnv code action = runReaderT (unEval action) code - -lineToEvalForm :: T.Text -> Eval Expr -lineToEvalForm input = either (throw . ParseError . show) eval $ readExpr input - -evalFile :: FilePath -> T.Text -> IO () -- program file -evalFile filePath fileExpr = (runASTinEnv basicEnv $ fileToEvalForm filePath fileExpr) >>= print - -fileToEvalForm :: FilePath -> T.Text -> Eval Expr -fileToEvalForm filePath input = either (throw . ParseError . show) evalBody $ readExprFile filePath input - -runParseTest :: T.Text -> T.Text -- for view AST -runParseTest input = either (T.pack . show) (T.pack . show) $ readExpr input - -getFileContents :: FilePath -> IO T.Text -getFileContents fname = do - exists <- doesFileExist fname - if exists then TIO.readFile fname else return "File does not exist." - -textToEvalForm :: T.Text -> Eval Expr -textToEvalForm input = either (throw . ParseError . show) evalBody $ readExpr input - -evalText :: T.Text -> IO () --REPL -evalText textExpr = do - res <- runASTinEnv basicEnv $ textToEvalForm textExpr - print res - -getVar :: Expr -> Eval Expr -getVar (Atom atom) = do - Env {..} <- ask - case Map.lookup atom (Map.union fenv env) of -- lookup, but prefer functions - Just x -> return x - Nothing -> throw $ UnboundVar atom -getVar n = throw $ TypeMismatch "failure to get variable: " n - -ensureAtom :: Expr -> Eval Expr -ensureAtom n@(Atom _) = return n -ensureAtom n@(List _) = throw $ TypeMismatch "got list" n -ensureAtom n = throw $ TypeMismatch "expected an atomic value" n - -extractVar :: Expr -> T.Text -extractVar (Atom atom) = atom -extractVar n = throw $ TypeMismatch "expected an atomic value" n - -getEven :: [t] -> [t] -getEven [] = [] -getEven (x : xs) = x : getOdd xs - -getOdd :: [t] -> [t] -getOdd [] = [] -getOdd (_ : xs) = getEven xs - -applyFunc :: Expr -> [Expr] -> [Expr] -> Eval Expr -applyFunc expr params args = bindArgsEval params args expr - -bindArgsEval :: [Expr] -> [Expr] -> Expr -> Eval Expr -bindArgsEval params args expr = do - Env {..} <- ask - let newVars = zipWith (\a b -> (extractVar a, b)) params args - let (newEnv, newFenv) = Map.partition (not . isFunc) $ Map.fromList newVars - local (const $ Env (newEnv <> env) (newFenv <> fenv)) $ eval expr - -isFunc :: Expr -> Bool -isFunc (List ((Atom "lambda") : _)) = True -isFunc _ = False - -eval :: Expr -> Eval Expr -eval (List [Atom "dumpEnv", x]) = do - Env {..} <- ask - liftIO $ print $ toList env - liftIO $ print $ toList fenv - eval x -eval (Numb i) = return $ Numb i -eval (Tape s) = return $ Tape s -eval (Bool b) = return $ Bool b -eval (List []) = return Nil -eval Nil = return Nil -eval n@(Atom _) = getVar n -eval (List [Atom "showSF", rest]) = return . Tape . T.pack $ show rest -eval (List ((:) (Atom "showSF") rest)) = return . Tape . T.pack . show $ List rest -eval (List [Atom "quote", val]) = return val -eval (List [Atom "if", pred_, then_, else_]) = do - ifRes <- eval pred_ - case ifRes of - (Bool True) -> eval then_ - (Bool False) -> eval else_ - _ -> - throw $ BadSpecialForm "if's first arg must eval into a boolean" -eval (List ((:) (Atom "if") _)) = - throw $ BadSpecialForm "(if )" -eval (List [Atom "begin", rest]) = evalBody rest -eval (List ((:) (Atom "begin") rest)) = evalBody $ List rest --- top-level define --- TODO: how to make this eval correctly? -eval (List [Atom "define", List (name : args), body]) = do - Env {..} <- ask - _ <- eval body - bindArgsEval (name : args) [body] name -eval (List [Atom "define", name, body]) = do - Env {..} <- ask - _ <- eval body - bindArgsEval [name] [body] name -eval (List [Atom "let", List pairs, expr]) = do - Env {..} <- ask - atoms <- mapM ensureAtom $ getEven pairs - vals <- mapM eval $ getOdd pairs - bindArgsEval atoms vals expr -eval (List (Atom "let" : _)) = - throw $ BadSpecialForm "let function expects list of parameters and S-Expression body\n(let )" -eval (List [Atom "lambda", List params, expr]) = do - ctx <- ask - return $ Func (IFunc $ applyFunc expr params) ctx -eval (List (Atom "lambda" : _)) = throw $ BadSpecialForm "lambda function expects list of parameters and S-Expression body\n(lambda )" --- needed to get cadr, etc to work -eval (List [Atom "cdr", List [Atom "quote", List (_ : xs)]]) = - return $ List xs -eval (List [Atom "cdr", arg@(List (x : xs))]) = - case x of - -- proxy for if the list can be evaluated - Atom _ -> do - val <- eval arg - eval $ List [Atom "cdr", val] - _ -> return $ List xs -eval (List [Atom "car", List [Atom "quote", List (x : _)]]) = - return $ x -eval (List [Atom "car", arg@(List (x : _))]) = - case x of - Atom _ -> do - val <- eval arg - eval $ List [Atom "car", val] - _ -> return $ x -eval (List ((:) x xs)) = do - Env {..} <- ask - funVar <- eval x - xVal <- mapM eval xs - case funVar of - (IFun (IFunc internalFn)) -> - internalFn xVal - (Func (IFunc definedFn) (Env benv _)) -> - local (const $ Env benv fenv) $ definedFn xVal - _ -> - throw $ NotFunction funVar - -updateEnv :: T.Text -> Expr -> Env -> Env -updateEnv var e@(IFun _) Env {..} = Env env $ Map.insert var e fenv -updateEnv var e@(Func _ _) Env {..} = Env env $ Map.insert var e fenv -updateEnv var e Env {..} = Env (Map.insert var e env) fenv - -evalBody :: Expr -> Eval Expr -evalBody (List [List ((:) (Atom "define") [Atom var, defExpr]), rest]) = do - evalVal <- eval defExpr - ctx <- ask - local (const $ updateEnv var evalVal ctx) $ eval rest -evalBody (List ((:) (List ((:) (Atom "define") [Atom var, defExpr])) rest)) = do - evalVal <- eval defExpr - ctx <- ask - local (const $ updateEnv var evalVal ctx) $ evalBody $ List rest -evalBody x = eval x diff --git a/Biz/Language/Bs/Expr.hs b/Biz/Language/Bs/Expr.hs deleted file mode 100644 index 2452622..0000000 --- a/Biz/Language/Bs/Expr.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Bs.Expr where - -import Data.String (String) -import Data.Text (Text) -import qualified Data.Text as T -import GHC.Show -import Protolude hiding (show) -import qualified Text.PrettyPrint.Leijen.Text as PP -import Text.PrettyPrint.Leijen.Text hiding ((<$>)) - -type Ctx = Map Text Expr - -data Env = Env {env :: Ctx, fenv :: Ctx} - deriving (Eq) - -newtype Eval a = Eval {unEval :: ReaderT Env IO a} - deriving (Monad, Functor, Applicative, MonadReader Env, MonadIO) - -data IFunc = IFunc {fn :: [Expr] -> Eval Expr} - deriving (Typeable) - -instance Eq IFunc where - (==) _ _ = False - -data Expr - = Atom Text - | List [Expr] - | Numb Integer - | Tape Text - | IFun IFunc -- TODO: call this Kern - | Func IFunc Env - | Bool Bool - | Nil - deriving (Typeable, Eq) - -instance Show Expr where - show = T.unpack . ppexpr - -data LispErrorType - = NumArgs Integer [Expr] - | LengthOfList Text Int - | ExpectedList Text - | ParseError String - | TypeMismatch Text Expr - | BadSpecialForm Text - | NotFunction Expr - | UnboundVar Text - | Default Expr - | ReadFileError Text - deriving (Typeable) - -data LispError = LispError Expr LispErrorType - -instance Show LispErrorType where - show = T.unpack . ppexpr - -instance Show LispError where - show = T.unpack . ppexpr - -instance Exception LispErrorType - -instance Exception LispError - -ppexpr :: Pretty a => a -> Text -ppexpr x = PP.displayTStrict (PP.renderPretty 1.0 70 (pretty x)) - ---prettyList :: [Doc] -> Doc ---prettyList = encloseSep lparen rparen PP.space - -instance Pretty Expr where - pretty v = - case v of - Atom a -> - textStrict a - List ls -> - prettyList $ fmap pretty ls - Numb n -> - integer n - Tape t -> - textStrict "\"" <> textStrict t <> textStrict "\"" - IFun _ -> - textStrict "" - Func _ _ -> - textStrict "" - Bool True -> - textStrict "#t" - Bool False -> - textStrict "#f" - Nil -> - textStrict "'()" - -instance Pretty LispErrorType where - pretty err = case err of - NumArgs i args -> - textStrict "number of arguments" - <$$> textStrict "expected" - <+> textStrict (T.pack $ show i) - <$$> textStrict "received" - <+> textStrict (T.pack $ show $ length args) - LengthOfList txt i -> - textStrict "length of list in:" - <+> textStrict txt - <$$> textStrict "length:" - <+> textStrict (T.pack $ show i) - ParseError txt -> - textStrict "cannot parse expr:" - <+> textStrict (T.pack txt) - TypeMismatch txt expr -> - textStrict "type mismatch:" - <$$> textStrict txt - <$$> pretty expr - BadSpecialForm txt -> - textStrict "bad special form:" - <$$> textStrict txt - NotFunction expr -> - textStrict "not a function" - <$$> pretty expr - UnboundVar txt -> - textStrict "unbound variable:" - <$$> textStrict txt - Default _ -> - textStrict "default error" - ReadFileError txt -> - textStrict "error reading file:" - <$$> textStrict txt - ExpectedList txt -> - textStrict "expected list:" - <$$> textStrict txt - -instance Pretty LispError where - pretty (LispError expr typ) = - textStrict "error evaluating:" - <$$> indent 4 (pretty expr) - <$$> pretty typ diff --git a/Biz/Language/Bs/Parser.hs b/Biz/Language/Bs/Parser.hs deleted file mode 100644 index 574536d..0000000 --- a/Biz/Language/Bs/Parser.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Bs.Parser - ( readExpr, - readExprFile, - ) -where - -import Control.Monad (fail) -import Control.Monad (mzero) -import Data.Char (digitToInt) -import Data.Functor.Identity (Identity) -import Data.String -import qualified Data.Text as T -import Language.Bs.Expr -import Protolude hiding ((<|>), try) -import Text.Parsec -import qualified Text.Parsec.Language as Lang -import Text.Parsec.Text -import qualified Text.Parsec.Token as Tok - -lexer :: Tok.GenTokenParser T.Text () Identity -lexer = Tok.makeTokenParser style - -style :: Tok.GenLanguageDef T.Text () Identity -style = - Lang.emptyDef - { Tok.commentStart = "#|", - Tok.commentEnd = "|#", - Tok.commentLine = ";", - Tok.opStart = mzero, - Tok.opLetter = mzero, - Tok.identStart = letter <|> oneOf "!$%&*/:<=>?^_~", - Tok.identLetter = digit <|> letter <|> oneOf "!$%&*/:<=>?^_~+-.@" - } - -parens :: Parser a -> Parser a -parens = Tok.parens lexer - -whitespace :: Parser () -whitespace = Tok.whiteSpace lexer - -lexeme :: Parser a -> Parser a -lexeme = Tok.lexeme lexer - -quoted :: Parser a -> Parser a -quoted p = try (char '\'') *> p - -identifier :: Parser T.Text -identifier = T.pack <$> (Tok.identifier lexer <|> specialIdentifier) "identifier" - where - specialIdentifier :: Parser String - specialIdentifier = - lexeme $ try $ - string "-" <|> string "+" <|> string "..." - --- | The @Radix@ type consists of a base integer (e.g. @10@) and a parser for --- digits in that base (e.g. @digit@). -type Radix = (Integer, Parser Char) - --- | Parse an integer, given a radix as output by @radix@. --- Copied from Text.Parsec.Token -numberWithRadix :: Radix -> Parser Integer -numberWithRadix (base, baseDigit) = do - digits <- many1 baseDigit - let n = foldl (\x d -> base * x + toInteger (digitToInt d)) 0 digits - seq n (return n) - -decimal :: Parser Integer -decimal = Tok.decimal lexer - --- | Parse a sign, return either @id@ or @negate@ based on the sign parsed. --- Copied from Text.Parsec.Token -sign :: Parser (Integer -> Integer) -sign = - char '-' *> return negate - <|> char '+' *> return identity - <|> return identity - -intRadix :: Radix -> Parser Integer -intRadix r = sign <*> numberWithRadix r - -textLiteral :: Parser T.Text -textLiteral = T.pack <$> Tok.stringLiteral lexer - -nil :: Parser () -nil = try ((char '\'') *> string "()") *> return () "nil" - -hashVal :: Parser Expr -hashVal = - lexeme $ - char '#' - *> ( char 't' *> return (Bool True) - <|> char 'f' *> return (Bool False) - <|> char 'b' *> (Numb <$> intRadix (2, oneOf "01")) - <|> char 'o' *> (Numb <$> intRadix (8, octDigit)) - <|> char 'd' *> (Numb <$> intRadix (10, digit)) - <|> char 'x' *> (Numb <$> intRadix (16, hexDigit)) - <|> oneOf "ei" *> fail "Unsupported: exactness" - <|> char '(' *> fail "Unsupported: vector" - <|> char '\\' *> fail "Unsupported: char" - ) - -lispVal :: Parser Expr -lispVal = - hashVal - <|> Nil <$ nil - <|> Numb <$> try (sign <*> decimal) - <|> Atom <$> identifier - <|> Tape <$> textLiteral - <|> _Quote <$> quoted lispVal - <|> List <$> parens manyExpr - -manyExpr :: Parser [Expr] -manyExpr = lispVal `sepBy` whitespace - -_Quote :: Expr -> Expr -_Quote x = List [Atom "quote", x] - -contents :: Parser a -> ParsecT T.Text () Identity a -contents p = whitespace *> lexeme p <* eof - -readExpr :: T.Text -> Either ParseError Expr -readExpr = parse (contents lispVal) "" - -readExprFile :: SourceName -> T.Text -> Either ParseError Expr -readExprFile = parse (contents (List <$> manyExpr)) diff --git a/Biz/Language/Bs/Primitives.hs b/Biz/Language/Bs/Primitives.hs deleted file mode 100644 index 4c70499..0000000 --- a/Biz/Language/Bs/Primitives.hs +++ /dev/null @@ -1,188 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | bs primitives --- --- I would like to reduce the number of primitives in the language to some --- minimal number, like SKI combinator or Nock instructions. I'm not sure what --- the minimal number is. The idea is to move primitives from here into core.scm --- over time. -module Language.Bs.Primitives where - -import Control.Exception -import Control.Monad.Except -import Data.Text as T -import Data.Text.IO as TIO -import Language.Bs.Expr -import Network.HTTP -import Protolude -import System.Directory -import System.IO - -type Prim = [(T.Text, Expr)] - -type Unary = Expr -> Eval Expr - -type Binary = Expr -> Expr -> Eval Expr - -mkF :: ([Expr] -> Eval Expr) -> Expr -mkF = IFun . IFunc - -primEnv :: Prim -primEnv = - [ ("+", mkF $ binopFold (numOp (+)) (Numb 0)), - ("*", mkF $ binopFold (numOp (*)) (Numb 1)), - ("string-append", mkF $ binopFold (strOp (<>)) (Tape "")), - ("-", mkF $ binop $ numOp (-)), - ("<", mkF $ binop $ numCmp (<)), - ("<=", mkF $ binop $ numCmp (<=)), - (">", mkF $ binop $ numCmp (>)), - (">=", mkF $ binop $ numCmp (>=)), - ("==", mkF $ binop $ numCmp (==)), - ("even?", mkF $ unop $ numBool even), - ("odd?", mkF $ unop $ numBool odd), - ("neg?", mkF $ unop $ numBool (< 0)), - ("pos?", mkF $ unop $ numBool (> 0)), - ("eq?", mkF $ binop eqCmd), - ("null?", mkF $ unop (eqCmd Nil)), - ("bl-eq?", mkF $ binop $ eqOp (==)), - ("and", mkF $ binopFold (eqOp (&&)) (Bool True)), - ("or", mkF $ binopFold (eqOp (||)) (Bool False)), - ("not", mkF $ unop $ notOp), - ("cons", mkF $ Language.Bs.Primitives.cons), - ("cdr", mkF $ Language.Bs.Primitives.cdr), - ("car", mkF $ Language.Bs.Primitives.car), - ("quote", mkF $ quote), - ("file?", mkF $ unop fileExists), - ("slurp", mkF $ unop slurp), - ("wslurp", mkF $ unop wSlurp), - ("put", mkF $ binop put_) - ] - -unop :: Unary -> [Expr] -> Eval Expr -unop op [x] = op x -unop _ args = throw $ NumArgs 1 args - -binop :: Binary -> [Expr] -> Eval Expr -binop op [x, y] = op x y -binop _ args = throw $ NumArgs 2 args - -fileExists :: Expr -> Eval Expr -fileExists (Tape txt) = Bool <$> liftIO (doesFileExist $ T.unpack txt) -fileExists val = throw $ TypeMismatch "read expects string, instead got: " val - -slurp :: Expr -> Eval Expr -slurp (Tape txt) = liftIO $ wFileSlurp txt -slurp val = throw $ TypeMismatch "read expects string, instead got: " val - -wFileSlurp :: T.Text -> IO Expr -wFileSlurp fileName = withFile (T.unpack fileName) ReadMode go - where - go = readTextFile fileName - -openURL :: T.Text -> IO Expr -openURL x = do - req <- simpleHTTP (getRequest $ T.unpack x) - body <- getResponseBody req - return $ Tape $ T.pack body - -wSlurp :: Expr -> Eval Expr -wSlurp (Tape txt) = liftIO $ openURL txt -wSlurp val = throw $ TypeMismatch "wSlurp expects a string, instead got: " val - -readTextFile :: T.Text -> Handle -> IO Expr -readTextFile fileName h = do - exists <- doesFileExist $ T.unpack fileName - if exists - then (TIO.hGetContents h) >>= (return . Tape) - else throw $ ReadFileError $ T.concat [" file does not exist: ", fileName] - -put_ :: Expr -> Expr -> Eval Expr -put_ (Tape file) (Tape msg) = liftIO $ wFilePut file msg -put_ (Tape _) val = throw $ TypeMismatch "put expects string in the second argument (try using show), instead got: " val -put_ val _ = throw $ TypeMismatch "put expects string, instead got: " val - -wFilePut :: T.Text -> T.Text -> IO Expr -wFilePut fileName msg = withFile (T.unpack fileName) WriteMode go - where - go = putTextFile fileName msg - -putTextFile :: T.Text -> T.Text -> Handle -> IO Expr -putTextFile fileName msg h = do - canWrite <- hIsWritable h - if canWrite - then (TIO.hPutStr h msg) >> (return $ Tape msg) - else throw $ ReadFileError $ T.concat [" file does not exist: ", fileName] - -binopFold :: Binary -> Expr -> [Expr] -> Eval Expr -binopFold op farg args = case args of - [] -> throw $ NumArgs 2 args - [a, b] -> op a b - _ -> foldM op farg args - -numBool :: (Integer -> Bool) -> Expr -> Eval Expr -numBool op (Numb x) = return $ Bool $ op x -numBool _ x = throw $ TypeMismatch "numeric op " x - -numOp :: (Integer -> Integer -> Integer) -> Expr -> Expr -> Eval Expr -numOp op (Numb x) (Numb y) = return $ Numb $ op x y -numOp _ Nil (Numb y) = return $ Numb y -numOp _ (Numb x) Nil = return $ Numb x -numOp _ x (Numb _) = throw $ TypeMismatch "numeric op" x -numOp _ (Numb _) y = throw $ TypeMismatch "numeric op" y -numOp _ x _ = throw $ TypeMismatch "numeric op" x - -strOp :: (T.Text -> T.Text -> T.Text) -> Expr -> Expr -> Eval Expr -strOp op (Tape x) (Tape y) = return $ Tape $ op x y -strOp _ Nil (Tape y) = return $ Tape y -strOp _ (Tape x) Nil = return $ Tape x -strOp _ x (Tape _) = throw $ TypeMismatch "string op" x -strOp _ (Tape _) y = throw $ TypeMismatch "string op" y -strOp _ x _ = throw $ TypeMismatch "string op" x - -eqOp :: (Bool -> Bool -> Bool) -> Expr -> Expr -> Eval Expr -eqOp op (Bool x) (Bool y) = return $ Bool $ op x y -eqOp _ x (Bool _) = throw $ TypeMismatch "bool op" x -eqOp _ (Bool _) y = throw $ TypeMismatch "bool op" y -eqOp _ x _ = throw $ TypeMismatch "bool op" x - -numCmp :: (Integer -> Integer -> Bool) -> Expr -> Expr -> Eval Expr -numCmp op (Numb x) (Numb y) = return . Bool $ op x y -numCmp _ x (Numb _) = throw $ TypeMismatch "numeric op" x -numCmp _ (Numb _) y = throw $ TypeMismatch "numeric op" y -numCmp _ x _ = throw $ TypeMismatch "numeric op" x - -notOp :: Expr -> Eval Expr -notOp (Bool True) = return $ Bool False -notOp (Bool False) = return $ Bool True -notOp x = throw $ TypeMismatch " not expects Bool" x - -eqCmd :: Expr -> Expr -> Eval Expr -eqCmd (Atom x) (Atom y) = return . Bool $ x == y -eqCmd (Numb x) (Numb y) = return . Bool $ x == y -eqCmd (Tape x) (Tape y) = return . Bool $ x == y -eqCmd (Bool x) (Bool y) = return . Bool $ x == y -eqCmd Nil Nil = return $ Bool True -eqCmd _ _ = return $ Bool False - -cons :: [Expr] -> Eval Expr -cons [x, (List ys)] = return $ List $ x : ys -cons [x, y] = return $ List [x, y] -cons _ = throw $ ExpectedList "cons, in second argument" - -car :: [Expr] -> Eval Expr -car [List []] = return Nil -car [List (x : _)] = return x -car [] = return Nil -car _ = throw $ ExpectedList "car" - -cdr :: [Expr] -> Eval Expr -cdr [List (_ : xs)] = return $ List xs -cdr [List []] = return Nil -cdr [] = return Nil -cdr _ = throw $ ExpectedList "cdr" - -quote :: [Expr] -> Eval Expr -quote [List xs] = return $ List $ Atom "quote" : xs -quote [expr] = return $ List $ Atom "quote" : [expr] -quote args = throw $ NumArgs 1 args diff --git a/Biz/Language/Bs/Repl.hs b/Biz/Language/Bs/Repl.hs deleted file mode 100644 index 24f1bcd..0000000 --- a/Biz/Language/Bs/Repl.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Bs.Repl - ( mainLoop, - ) -where - -import Control.Monad.Trans -import Data.String -import Data.Text as T -import Language.Bs.Eval -import Protolude -import System.Console.Haskeline - -type Repl a = InputT IO a - -mainLoop :: IO () -mainLoop = runInputT defaultSettings repl - -repl :: Repl () -repl = do - minput <- getInputLine "bs> " - case minput of - Nothing -> outputStrLn "bye." - Just input -> (liftIO $ process input) >> repl - ---Just input -> (liftIO $ processToAST input) >> repl - -process :: String -> IO () -process str = do - res <- safeExec $ evalText $ T.pack str - either putStrLn return res - -processToAST :: String -> IO () -processToAST str = print $ runParseTest $ T.pack str diff --git a/Biz/Language/Bs/Test.hs b/Biz/Language/Bs/Test.hs deleted file mode 100644 index 4a40036..0000000 --- a/Biz/Language/Bs/Test.hs +++ /dev/null @@ -1,2 +0,0 @@ --- TODO -module Language.Bs.Test where diff --git a/Hero/App.hs b/Hero/App.hs index 6afcbd2..39cfa03 100644 --- a/Hero/App.hs +++ b/Hero/App.hs @@ -165,7 +165,7 @@ instance IsMediaObject Comic where title = "color" =: "red" <> "font-size" =: "1.6rem" <> uppercase <> "line-height" - =: "100%" + =: "100%" <> Look.condensed <> bold subtitle = "color" =: "#fff" <> "font-size" =: "1.2rem" <> bold <> Look.condensed @@ -211,14 +211,14 @@ instance Elemental Button where if c `elem` lib -- in library then a_ - [class_ $ "wrs-button saved", onClick $ ToggleInLibrary c] + [class_ "wrs-button saved", onClick $ ToggleInLibrary c] [ img_ [src_ $ ms $ Assets.icon <> "save.svg"], span_ [] [text "saved"] ] else-- not in library a_ - [class_ $ "wrs-button", onClick $ ToggleInLibrary c] + [class_ "wrs-button", onClick $ ToggleInLibrary c] [ img_ [src_ $ ms $ Assets.icon <> "save.svg"], span_ [] [text "save"] ] @@ -259,13 +259,13 @@ instance Elemental Button where ] el (Read c) = a_ - [class_ $ "wrs-button", onClick $ SelectExperience c] + [class_ "wrs-button", onClick $ SelectExperience c] [ img_ [src_ $ ms $ Assets.icon <> "read.svg"], span_ [] [text "read"] ] el (Watch c) = a_ - [class_ $ "wrs-button", onClick $ StartWatching c] + [class_ "wrs-button", onClick $ StartWatching c] [ img_ [src_ $ ms $ Assets.icon <> "watch.svg"], span_ [] [text "watch"] ] @@ -284,7 +284,7 @@ data ComicReaderState deriving (Show, Eq) findComic :: ComicId -> [Comic] -> Maybe Comic -findComic id ls = List.find (\c -> comicId c == id) ls +findComic id = List.find . \c -> comicId c == id -- | Main model for the app. -- @@ -442,7 +442,7 @@ home :: Model -> View Action home = login discover :: Model -> View Action -discover model@(Model {userLibrary = lib}) = +discover model@Model {userLibrary = lib} = template "discover" [ topbar, @@ -454,7 +454,7 @@ discover model@(Model {userLibrary = lib}) = Success (comic : rest) -> [ feature comic lib, shelf "Recent Releases" (comic : rest), - maybeView (flip info lib) $ dMediaInfo model + maybeView (`info` lib) $ dMediaInfo model ], appmenu, discoverFooter @@ -462,7 +462,7 @@ discover model@(Model {userLibrary = lib}) = -- | If 'View' had a 'Monoid' instance, then '(text "")' could just be 'mempty' maybeView :: (a -> View action) -> Maybe a -> View action -maybeView f obj = maybe (text "") f obj +maybeView = maybe (text "") mediaInfo :: Maybe Comic -> Library -> View Action mediaInfo Nothing _ = text "" @@ -481,7 +481,7 @@ appmenu = aside_ [id_ "appmenu"] $ btn img], span_ [] [text label] @@ -540,7 +540,7 @@ discoverFooter = [img_ [src_ $ ms $ Assets.cdnEdge <> "/old-assets/images/icons/" <> x]] comicCover :: ComicId -> Model -> View Action -comicCover comicId_ model = comicPlayer comicId_ 1 model +comicCover comicId_ = comicPlayer comicId_ 1 data ComicReaderView = Spread | Full deriving (Show, Eq) @@ -572,7 +572,7 @@ viewOr404 comics f id pg model = Nothing -> the404 model template :: MisoString -> [View Action] -> View Action -template id rest = div_ [id_ id, class_ "app is-black"] rest +template id = div_ [id_ id, class_ "app is-black"] closeButton :: View Action closeButton = @@ -631,7 +631,7 @@ comicSpread comic page model = ms Assets.demo <> ms (comicSlug comic) <> "-" - <> (padLeft $ 1 + page) + <> padLeft (1 + page) <> ".png" frameborder_ :: MisoString -> Attribute action @@ -661,7 +661,7 @@ comicVideo _ _ _ = padLeft :: Int -> MisoString padLeft n - | n < 10 = ms $ ("0" <> Legacy.show n) + | n < 10 = ms ("0" <> Legacy.show n) | otherwise = ms $ Legacy.show n comicControls :: Comic -> Page -> Model -> View Action @@ -670,7 +670,7 @@ comicControls comic page model = [id_ "app-foot", class_ "comic-controls"] [ div_ [ class_ "comic-nav-audio", - css $ flexCenter + css flexCenter ] [ audio_ [id_ audioId, loop_ True, crossorigin_ "anonymous"] @@ -682,9 +682,9 @@ comicControls comic page model = ], div_ [class_ "comic-controls-pages", css euro] - [ el $ Arrow $ PrevPage, + [ el $ Arrow PrevPage, span_ [] [text $ leftPage <> "-" <> rightPage <> " of " <> totalpages], - el $ Arrow $ NextPage + el $ Arrow NextPage ], div_ [class_ "comic-controls-share"] @@ -767,7 +767,7 @@ chooseExperiencePage comic page model = [ img_ [src_ $ ms $ Assets.demo <> name <> ".png"], span_ [] [text $ ms name] ], - span_ [css $ thicc] [text $ ms artist], + span_ [css thicc] [text $ ms artist], span_ [] [text $ ms track] ] experiences :: [(Text, Text, Text)] @@ -821,7 +821,7 @@ column = div_ [css $ Clay.display Clay.flex <> Clay.flexDirection Clay.column] -- | Links comicLink :: ComicId -> URI -comicLink comicId_ = linkURI $ safeLink routes comicProxy $ comicId_ +comicLink comicId_ = linkURI $ safeLink routes comicProxy comicId_ comicPlayerSpreadLink :: ComicId -> Page -> URI comicPlayerSpreadLink id page = diff --git a/Hero/Client.hs b/Hero/Client.hs index 0472d48..a513dcd 100644 --- a/Hero/Client.hs +++ b/Hero/Client.hs @@ -122,7 +122,7 @@ move PrevPage model = case cpState model of pure $ ChangeURI $ comicPlayerFullLink id (pg -1) Cover _ -> noEff model _ -> noEff model -move (ToggleZoom c pg) m = m {cpState = newState} <# do pure act +move (ToggleZoom c pg) m = m {cpState = newState} <# pure act where goto lnk = ChangeURI $ lnk (comicId c) pg reading v = Reading v (comicId c) pg @@ -133,9 +133,9 @@ move (ToggleZoom c pg) m = m {cpState = newState} <# do pure act move (ToggleInLibrary c) model = model {userLibrary = newLib} <# pure NoOp where newLib - | c `elem` (userLibrary model) = + | c `elem` userLibrary model = Protolude.filter (/= c) $ userLibrary model - | otherwise = c : (userLibrary model) + | otherwise = c : userLibrary model move (HandleURI u) model = model {uri = u} <# pure NoOp move (ChangeURI u) model = model <# do pushURI u @@ -162,8 +162,8 @@ move ToggleFullscreen model = model {cpState = newState} <# do Reading Spread c n -> (Fullscreen.request, Reading Spread c n) -- otherwise, do nothing: x -> (pure, x) -move (SetMediaInfo x) model = model {dMediaInfo = x} <# do - case x of +move (SetMediaInfo x) model = model {dMediaInfo = x} + <# case x of Just Comic {comicId = id} -> pure $ ScrollIntoView $ "comic-" <> ms id Nothing -> diff --git a/Hero/Database.hs b/Hero/Database.hs index 0166c6f..5b7f75d 100644 --- a/Hero/Database.hs +++ b/Hero/Database.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} diff --git a/Hero/Look.hs b/Hero/Look.hs index 662b223..b676c13 100644 --- a/Hero/Look.hs +++ b/Hero/Look.hs @@ -27,17 +27,12 @@ main = do -- base ".fixed" ? position fixed ".clickable" ? clickable - ".row" ? do - display flex - alignItems center - justifyContent spaceBetween + ".row" ? centerJustify a <> a # hover <> a # visited ? do color white textDecoration none ".loading" ? do - display flex - justifyContent center - alignItems center + centered height $ vh 100 width $ vw 100 -- animations @@ -113,7 +108,7 @@ main = do "#app-foot" ? do alignSelf flexEnd bottom (px 0) - mobile $ remove + mobile remove "#app-foot-social" ? do display flex flexDirection column @@ -127,20 +122,17 @@ main = do textTransform Clay.uppercase textAlign center -- hide app-foot-quote when it gets crowded - query Clay.all [Media.maxDeviceWidth (px 800)] $ + query + Clay.all + [Media.maxDeviceWidth (px 800)] hide -- login "#login" ? do -- TODO: next 3 lines can be DRYed up, methinks - display flex - justifyContent center - alignItems center - alignSelf center + centered height (vh 100) "#login-inner" ? do - display flex - justifyContent center - alignItems center + centered flexDirection column zIndex 1 height (vh 100) @@ -151,8 +143,8 @@ main = do display flex alignItems center flexDirection column - "#login" ** form <> "#login" ** hr ? do - width (pct 100) + "#login" ** form <> "#login" ** hr + ? width (pct 100) "#login" ** hr ? border solid (px 1) grai "#login" ** ".button" ? do marginTop (px 10) @@ -228,7 +220,7 @@ main = do lineHeight z let m = 24 :: Double top $ px $ navbarHeight + m - left $ px $ m + left $ px m zIndex 999 -- zoom button and slider "#zoom-button" ? do @@ -259,9 +251,7 @@ main = do borderTop solid (px 1) white borderBottom solid (px 1) white flexDirection row - display flex - alignItems center - justifyContent spaceBetween + centerJustify mobile $ do margin (rem 2) 0 (rem 2) 0 padding 0 0 0 (rem 0) @@ -277,7 +267,7 @@ main = do width (vw 90) -- this line can be commented if you want to center the meta img ? width (px 150) order (-1) - Flexbox.flex 1 1 (auto) + Flexbox.flex 1 1 auto ".media-info-summary" ? do Flexbox.flex 2 1 (px 0) paddingRight (rem 3) @@ -293,7 +283,7 @@ main = do mobile $ do maxWidth (vw 100) flexDirection row - order (1) + order 1 flexBasis auto -- initial height (px 50) -- appmenu @@ -333,9 +323,8 @@ main = do button ? margin (rem 0.5) 0 (rem 0.5) 0 -- feature "#featured-comic" ? do - display flex + centered flexDirection column - justifyContent center Typo.euro height (px 411) mobile $ do @@ -347,8 +336,8 @@ main = do background $ linearGradient (straight sideTop) - [ (setA 0 nite, (pct 0)), - (nite, (pct 100)) + [ (setA 0 nite, pct 0), + (nite, pct 100) ] let h = 149 marginTop (px (- h)) @@ -360,7 +349,7 @@ main = do fontSize (rem 1.2) ".description" ? do width (px 400) - mobile $ remove + mobile remove "#featured-banner" ? do position relative minHeight (px 411) @@ -415,9 +404,8 @@ main = do padding (rem 0.5) (rem 0.5) (rem 0.5) (rem 0.5) width (vw 100) ".comic" ? do - display flex + centered flexDirection column - justifyContent center textAlign center euro maxWidth (px 110) @@ -449,9 +437,18 @@ main = do navbarHeight :: Double navbarHeight = 74 ---------------------------------------------------------------------------------- --- utilities ---------------------------------------------------------------------------------- +centered :: Css +centered = do + display flex + justifyContent center + alignItems center + alignSelf center + +centerJustify :: Css +centerJustify = do + display flex + alignItems center + justifyContent spaceBetween hide :: Css hide = visibility hidden @@ -472,7 +469,7 @@ rounded :: Css rounded = borderRadius (px 30) (px 30) (px 30) (px 30) appmenuWidth :: Size LengthUnit -appmenuWidth = (px 67) +appmenuWidth = px 67 flexCenter :: Css flexCenter = do diff --git a/Hero/Server.hs b/Hero/Server.hs index 450bd0d..bf92f88 100644 --- a/Hero/Server.hs +++ b/Hero/Server.hs @@ -1,14 +1,12 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE NoImplicitPrelude #-} -- | Hero web app @@ -78,8 +76,8 @@ main = bracket startup shutdown $ uncurry Warp.run Left e -> Exit.die e Right c -> do db <- Database.dummy - say $ "hero" - say $ "port: " ++ (show $ heroPort c) + say "hero" + say $ "port: " ++ show $ heroPort c say $ "client: " ++ heroClient c let waiapp = app db c return (heroPort c, waiapp) @@ -275,7 +273,7 @@ serverHandlers = :<|> chooseExperienceHandler jsonHandlers :: Database.ComicDB -> Server JsonApi -jsonHandlers db = Database.getComics db +jsonHandlers = Database.getComics homeHandler :: Handler (HtmlPage (View Action)) homeHandler = pure . HtmlPage . home $ initModel homeLink diff --git a/Que/Server.hs b/Que/Server.hs index b0f3fbd..9e8d893 100644 --- a/Que/Server.hs +++ b/Que/Server.hs @@ -84,7 +84,7 @@ newtype App a (STM.TVar AppState) ) -data AppState +newtype AppState = AppState { ques :: HashMap Namespace Quebase } @@ -92,7 +92,7 @@ data AppState initialAppState :: AppState initialAppState = AppState {ques = mempty} -data Config +newtype Config = Config { -- | QUE_PORT quePort :: Warp.Port @@ -139,9 +139,9 @@ routes = do q <- app <| que ns qp poll <- Scotty.param "poll" !: (pure . const False) guardNs ns ["pub", "_"] - case poll of - True -> Scotty.stream $ streamQue q - _ -> do + if poll + then Scotty.stream $ streamQue q + else do r <- liftIO <| Go.read q Scotty.html <| fromStrict <| Encoding.decodeUtf8 r -- POST que @@ -225,7 +225,7 @@ app = lift -- | Get something from the app state gets :: (AppState -> b) -> App b -gets f = ask >>= liftIO . STM.readTVarIO >>= return . f +gets f = ask >>= liftIO . STM.readTVarIO >>= return AppState) -> App () diff --git a/Que/Website.hs b/Que/Website.hs index cfb860c..7eb3ae6 100644 --- a/Que/Website.hs +++ b/Que/Website.hs @@ -53,7 +53,7 @@ getKey :: Namespace -> IO (Maybe Key) getKey ns = do home <- Directory.getHomeDirectory let file = home ".config" "que.conf" - exists <- (Directory.doesFileExist file) + exists <- Directory.doesFileExist file unless exists <| panic <| "not found: " <> Text.pack file conf <- Text.readFile file print (home ".config" "que.conf") @@ -84,7 +84,7 @@ auth "pub" = pure Nothing auth ns = Config.sectionMb ns <| Config.field "key" run :: Maybe Key -> Text -> Sources -> IO () -run key ns Sources {..} = Async.runConcurrently actions >> return () +run key ns Sources {..} = Async.runConcurrently actions |> void where actions = traverse diff --git a/Que/client.py b/Que/client.py index 3d9291d..6958576 100755 --- a/Que/client.py +++ b/Que/client.py @@ -17,16 +17,16 @@ MAX_TIMEOUT = 99999999 # basically never timeout def auth(args): - ns = args.target.split("/")[0] - if ns == "pub": + "Returns the auth key for the given ns from ~/.config/que.conf" + namespace = args.target.split("/")[0] + if namespace == "pub": return None - else: - conf_file = os.path.expanduser("~/.config/que.conf") - if not os.path.exists(conf_file): - sys.exit("you need a ~/.config/que.conf") + conf_file = os.path.expanduser("~/.config/que.conf") + if not os.path.exists(conf_file): + sys.exit("you need a ~/.config/que.conf") cfg = configparser.ConfigParser() cfg.read(conf_file) - return cfg[ns]["key"] + return cfg[namespace]["key"] def send(args): @@ -53,7 +53,9 @@ def recv(args): print(msg) if args.then: subprocess.run( - args.then.replace("\msg", msg).replace("\que", args.target), shell=True + args.then.replace(r"\msg", msg).replace(r"que", args.target), + shell=True, + check=False, ) params = urllib.parse.urlencode({"poll": args.poll}) @@ -70,8 +72,8 @@ def recv(args): _recv(_req) -def autodecode(b): - """Attempt to decode bytes `b` into common codecs, preferably utf-8. If +def autodecode(bytestring): + """Attempt to decode bytes `bs` into common codecs, preferably utf-8. If no decoding is available, just return the raw bytes. For all available codecs, see: @@ -81,13 +83,14 @@ def autodecode(b): codecs = ["utf-8", "ascii"] for codec in codecs: try: - return b.decode(codec) + return bytestring.decode(codec) except UnicodeDecodeError: pass - return b + return bytestring def get_args(): + "Command line parser" cli = argparse.ArgumentParser(description=__doc__) cli.add_argument( "--host", default="http://que.run", help="where que-server is running" @@ -101,7 +104,7 @@ def get_args(): [ "when polling, run this shell command after each response,", "presumably for side effects," - "replacing '\que' with the target and '\msg' with the body of the response", + r"replacing '\que' with the target and '\msg' with the body of the response", ] ), ) @@ -129,21 +132,21 @@ def get_args(): if __name__ == "__main__": - args = get_args() + ARGV = get_args() try: - if args.infile: - send(args) + if ARGV.infile: + send(ARGV) else: - recv(args) + recv(ARGV) except KeyboardInterrupt: sys.exit(0) - except urllib.error.HTTPError as e: - print(e) + except urllib.error.HTTPError as err: + print(err) sys.exit(1) - except http.client.RemoteDisconnected as e: + except http.client.RemoteDisconnected as err: print("disconnected... retrying in 5 seconds") time.sleep(5) - if args.infile: - send(args) + if ARGV.infile: + send(ARGV) else: - recv(args) + recv(ARGV) diff --git a/System/Random/Shuffle.hs b/System/Random/Shuffle.hs index 774e7b4..d3cd387 100644 --- a/System/Random/Shuffle.hs +++ b/System/Random/Shuffle.hs @@ -25,8 +25,7 @@ module System.Random.Shuffle where import Control.Monad - ( liftM, - liftM2, + ( liftM2, ) import Control.Monad.Random ( MonadRandom, @@ -49,13 +48,13 @@ data Tree a -- | Convert a sequence (e1...en) to a complete binary tree buildTree :: [a] -> Tree a -buildTree = (fix growLevel) . (map Leaf) +buildTree = fix growLevel . map Leaf where growLevel _ [node] = node growLevel self l = self $ inner l inner [] = [] inner [e] = [e] - inner (e1 : e2 : es) = e1 `seq` e2 `seq` (join e1 e2) : inner es + inner (e1 : e2 : es) = e1 `seq` e2 `seq` join e1 e2 : inner es join l@(Leaf _) r@(Leaf _) = Node 2 l r join l@(Node ct _ _) r@(Leaf _) = Node (ct + 1) l r join l@(Leaf _) r@(Node ct _ _) = Node (ct + 1) l r @@ -70,7 +69,7 @@ shuffle elements = shuffleTree (buildTree elements) where shuffleTree (Leaf e) [] = [e] shuffleTree tree (r : rs) = - let (b, rest) = extractTree r tree in b : (shuffleTree rest rs) + let (b, rest) = extractTree r tree in b : shuffleTree rest rs shuffleTree _ _ = error "[shuffle] called with lists of different lengths" -- Extracts the n-th element from the tree and returns -- that element, paired with a tree with the element @@ -99,7 +98,7 @@ shuffle' elements len = shuffle elements . rseq len -- independent sample from a uniform random distribution -- [0..n-i] rseq :: RandomGen gen => Int -> gen -> [Int] - rseq n = fst . unzip . rseq' (n - 1) + rseq n = map fst . rseq' (n - 1) where rseq' :: RandomGen gen => Int -> gen -> [(Int, gen)] rseq' 0 _ = [] @@ -111,7 +110,7 @@ shuffle' elements len = shuffle elements . rseq len shuffleM :: (MonadRandom m) => [a] -> m [a] shuffleM elements | null elements = return [] - | otherwise = liftM (shuffle elements) (rseqM (length elements - 1)) + | otherwise = shuffle elements <$> rseqM (length elements - 1) where rseqM :: (MonadRandom m) => Int -> m [Int] rseqM 0 = return [] -- cgit v1.2.3