webshow (empty) → 0.0.0
raw patch · 4 files changed
+288/−0 lines, 4 filesdep +basedep +directorydep +file-embed
Dependencies added: base, directory, file-embed, filepath, hscolour, http-types, lucid, optparse-applicative, optparse-simple, pretty-show, text, wai, warp
Files
- LICENSE +30/−0
- README.md +19/−0
- app/Main.hs +202/−0
- webshow.cabal +37/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,19 @@+# webshow++Run `webshow` in a directory and get pretty browsing.++Supports only Haskell Show values at the moment.++<img src="https://i.imgur.com/7MUMXEG.png">+++```+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+```
+ app/Main.hs view
@@ -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+++++++++++
+ webshow.cabal view
@@ -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