diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Chris Done (c) 2019 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Chris Done nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,19 @@ +# webshow + +Run `webshow` in a directory and get pretty browsing. + +Supports only Haskell Show values at the moment. + + + + +``` +Usage: webshow [--version] [--help] [-p|--port ARG] [-d|--directory ARG] + Show printed output from languages + +Available options: + --version Show version + --help Show this help text + -p,--port ARG Port number to listen on + -d,--directory ARG Directory to look at +``` diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +import Control.Monad +import Data.FileEmbed +import Data.Maybe +import Data.String +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Language.Haskell.HsColour.CSS +import Lucid +import Network.HTTP.Types +import Network.Wai +import Network.Wai.Handler.Warp (run) +import Options.Applicative +import Options.Applicative.Simple +import System.Directory +import System.FilePath +import Text.Show.Pretty (Value(..), Name(..), exportHtml, defaultHtmlOpts, valToHtml, parseValue) + +data Opts = + Opts + { optsPort :: Int + , optsDir :: FilePath + } deriving (Show) + +app :: FilePath -> Application +app dir req respond = do + case pathInfo req of + [fp] -> do + contents <- readFile (dir <> "/" <> (T.unpack fp)) + case lookup (takeExtension (T.unpack fp)) supported of + Nothing -> + reply + (html_ (body_ (do p_ (small_ "(Unknown file type. Display as plain text.)") + pre_ (toHtml contents)))) + Just generate -> reply (html_ (do head_ (style_ stylesheet) + body_ (generate contents))) + _ -> do + files <- + fmap + (filter (isJust . flip lookup supported . takeExtension) . + filter (not . all (== '.'))) + (getDirectoryContents dir) + reply (html_ (body_ (ul_ (mapM_ (\file -> li_ (a_ [href_ (fromString ("/" ++ file))] (toHtml file))) files)))) + where + reply html = + respond + (responseLBS status200 [("Content-Type", "text/html")] (renderBS html)) + +stylesheet :: T.Text +stylesheet = T.decodeUtf8 $(embedFile "webshow.css") + +supported :: [(String, String -> Html ())] +supported = + [ ( ".hs" + , \contents -> + case parseValue contents of + Just val -> + valueToHtml val + Nothing -> do + p_ + (small_ + "(Invalid Haskell Show value. Displaying as Haskell source.)") + pre_ (toHtmlRaw (hscolour False 0 contents))) + ] + +main :: IO () +main = do + (opts, ()) <- + simpleOptions + "1.0" + "Webshow" + "Show printed output from languages" + (Opts <$> + option auto (long "port" <> short 'p' <> help "Port number to listen on" <> value 3333) <*> + strOption (long "directory" <> short 'd' <> help "Directory to look at" <> value ".")) + empty + putStrLn ("Listening on http://localhost:" ++ show @Int (optsPort opts)) + run (optsPort opts) (app (optsDir opts)) + +valueToHtml :: Value -> Html () +valueToHtml = + \case + String string -> inline "string" (toHtml string) + Char char -> inline "char" (toHtml char) + Float float -> inline "float" (toHtml float) + Integer integer -> inline "integer" (toHtml integer) + Ratio n d -> + inline + "ratio" + (do valueToHtml n + "/" + valueToHtml d) + Neg n -> + inline + "neg" + (do "-" + valueToHtml n) + List xs -> + togglable "list" + (do inline "brace" "[" + unless + (null xs) + (block + "contents " + (mapM_ + (\(i, e) -> do + when (i > 0) ", " + valueToHtml e) + (zip [0 :: Int ..] xs))) + inline "brace" "]") + Con name xs -> + togglable "con" + (do when (not (null xs)) (inline "brace" "(") + inline "con-name" (toHtml name) + block + "contents" + (mapM_ (\e -> block "con-slot" (valueToHtml e)) xs) + when (not (null xs)) (inline "brace" ")")) + Tuple xs -> + block + "tuple" + (do when (not (null xs)) (inline "brace" "(") + block + "contents" + (table_ + (mapM_ + (\(i, e) -> + tr_ + (do td_ + [class_ "field-comma-td"] + (if i > 0 + then ", " + else "") + td_ [class_ "field-value-td"] (valueToHtml e))) + (zip [0 :: Int ..] xs))) + when (not (null xs)) (inline "brace" ")")) + InfixCons {} -> block "infix-con" "TODO: infix" + Rec name xs -> + togglable "rec" + (do when (not (null xs)) (inline "brace" "(") + inline "con-name" (toHtml name) + inline "brace" " {" + block + "contents" + (table_ + (mapM_ + (\(i, (n, e)) -> + tr_ + (do td_ + [class_ "field-comma-td"] + (if i > 0 + then ", " + else "") + td_ + [class_ "field-name-td"] + (inline "field-name" (toHtml n)) + td_ + [class_ "field-equals-td"] + (inline "equals" "=") + td_ [class_ "field-value-td"] (valueToHtml e))) + (zip [0 :: Int ..] xs))) + inline "brace" "}" + when (not (null xs)) (inline "brace" ")")) + where + inline name inner = span_ [class_ name] inner + block name inner = div_ [class_ name] inner + togglable cls inner = + div_ + [class_ ("toggle " <> cls)] + (do input_ [type_ "checkbox", class_ "check"] + div_ [class_ "inner"] inner) + +isSimple :: Value -> Bool +isSimple = + \case + String {} -> True + Char {} -> True + Float {} -> True + Integer {} -> True + Ratio {} -> True + Neg {} -> True + List [] -> True + Con _ [] -> True + Tuple [] -> True + Rec _ [] -> True + _ -> False + + + + + + + + + + + diff --git a/webshow.cabal b/webshow.cabal new file mode 100644 --- /dev/null +++ b/webshow.cabal @@ -0,0 +1,37 @@ +name: webshow +version: 0.0.0 +synopsis: Show programming language printed values in a web UI +description: Show programming language printed values in a web UI. Supports Haskell Show values only at the moment. +homepage: https://github.com/chrisdone/webshow#readme +license: BSD3 +license-file: LICENSE +author: Author name here +maintainer: example@example.com +copyright: 2019 Author name here +category: Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +executable webshow + hs-source-dirs: app + main-is: Main.hs + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: base >=4.7 && <5 + , warp + , wai + , http-types + , pretty-show + , directory + , optparse-simple + , optparse-applicative + , lucid + , hscolour + , filepath + , text + , file-embed + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/chrisdone/webshow