diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 667fe64..80f64b0 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -18,7 +18,7 @@ jobs: build: runs-on: ubuntu-latest container: - image: "docker://ghcr.io/chrisdone/hell-build@sha256:14776ba15fd7fce9ffff014ceb970a0e3ec2a1d12b601fcb47d7ff7010b7d7eb" + image: "docker://ghcr.io/chrisdone/hell-build@sha256:acfb500e0d1e2dd99a5c5b4a04ddad7021572032595c2a6a3dee866c32c27712" env: # For the ~/.stack root. diff --git a/docs/examples/index.html b/docs/examples/index.html new file mode 100644 index 0000000..950d0e1 --- /dev/null +++ b/docs/examples/index.html @@ -0,0 +1,386 @@ +

Hell examples

Back to homepage

01-hello-world.hell

#!/usr/bin/env hell
+main = Text.putStrLn "Hello, World!"
+

02-interaction.hell

main = do
+  Text.putStrLn "Please enter your name and hit ENTER:"
+  name <- Text.getLine
+  Text.putStrLn "Thanks, your name is: "
+  Text.putStrLn name
+

03-press-any-key.hell

main = do
+  IO.hSetBuffering IO.stdin IO.NoBuffering
+  IO.hSetBuffering IO.stdout IO.NoBuffering
+
+  Text.putStr "Please press any key ... "
+  chunk <- ByteString.hGet IO.stdin 1
+
+  IO.hSetBuffering IO.stdout IO.LineBuffering
+  Text.putStrLn "OK!"
+

04-writing-files.hell

main = do
+  let fp = "foo.txt"
+  Text.writeFile fp "Hello, "
+  Text.appendFile fp "World!"
+  text <- Text.readFile fp
+  Text.putStrLn text
+

05-lists.hell

main = do
+  let is = List.iterate' (Int.plus 1) 0
+  let xs = ["Hello, ", "World!"]
+  Text.putStrLn "OK!"
+  Monad.forM_ (List.zip is xs) \(i,x) -> do
+    IO.print i
+    Text.putStrLn x
+  IO.print $ List.foldl' Int.plus 0 $ List.take 10 is
+

06-polymorphism.hell

main = do
+  let x = "Hello!"
+  Text.putStrLn (Function.id x)
+  let lengths = List.map Text.length ["foo", "mu"]
+  IO.mapM_ (\i -> Text.putStrLn (Int.show i)) lengths
+

07-loops.hell

main = do
+  IO.mapM_ Text.putStrLn ["Hello, ", "World!"]
+
+  Function.fix (\(loop :: IO ()) -> do
+    Text.putStrLn "Ahhhhh! More?"
+    l <- Text.getLine
+    loop)
+

08-tuples.hell

main = do
+  let demo = \(x, y) -> y
+  let foobar = (123, "foo")
+  Text.putStrLn (demo foobar)
+
+  let (foo,bar) = (123, "foo")
+  Text.putStrLn bar
+

09-processes.hell

main = do
+  Text.putStrLn "OK"
+  (code, out, err) <- ByteString.readProcess (Process.proc "ls" ["-al"])
+  ByteString.hPutStr IO.stdout out
+  ByteString.hPutStr IO.stdout err
+
+  (out, err) <- Text.readProcess_ (Process.proc "df" ["-h", "/"])
+  Text.hPutStr IO.stdout out
+  Text.hPutStr IO.stdout err
+
+  code <- Process.runProcess (Process.proc "false" [])
+
+  Process.runProcess_ (Process.proc "echo" ["Hello, World!"])
+
+  -- Explicit type signature, but you don't need this. Just for demo'ing.
+  let config = Process.proc "false" []
+  code <- Process.runProcess config
+  Text.putStrLn "Done."
+

10-current-directory.hell

main = do
+  dir <- Directory.getCurrentDirectory
+  Text.putStrLn dir
+  Directory.setCurrentDirectory dir
+

11-env-vars.hell

main = do
+  env <- Environment.getEnvironment
+  (out, err) <-
+    Text.readProcess_ (
+      Process.setEnv (List.cons ("HELL_DEMO", "wibble") env)
+        (Process.proc "env" [])
+    )
+  Text.hPutStr IO.stdout out
+

12-fib.hell

main = do
+  Text.putStrLn (Int.show (Main.fib 30))
+
+fib =
+  Function.fix
+    (\fib i ->
+      Bool.bool
+        (Bool.bool
+           (Int.plus (fib (Int.subtract 1 i))
+                     (fib (Int.subtract 2 i)))
+           1
+           (Int.eq i 1))
+        0
+        (Int.eq i 0)
+    )
+

13-concurrency.hell

main = do
+
+  -- Run two things concurrently and return both results
+  (left, right) <-
+    Async.concurrently
+       (Main.curl "https://worldtimeapi.org/api/timezone/Europe/London")
+       (Main.curl "https://worldtimeapi.org/api/timezone/Europe/Rome")
+  Text.putStrLn left
+  Text.putStrLn right
+
+  -- Run two things concurrently and return the one that completes first
+  result <-
+    Async.race
+       (Main.curl "https://worldtimeapi.org/api/timezone/Europe/London")
+       (Main.curl "https://worldtimeapi.org/api/timezone/Europe/Rome")
+  Either.either Text.putStrLn Text.putStrLn result
+
+curl = \url -> do
+  (out, err) <- Text.readProcess_ (Process.proc "curl" [url])
+  IO.pure out
+

14-text.hell

main = do
+  Text.putStrLn (Text.concat ["Hello, ", "World!"])
+  Text.putStrLn (Text.take 3 "Hello, World!")
+  Text.putStrLn (Text.drop 3 "Hello, World!")
+  Text.putStrLn (Text.strip "  Hello, World!   ")
+  Text.putStrLn (Text.intercalate ", " ["Hello","World!"])
+

15-type-classes.hell

main = do
+  Text.putStrLn (Show.show 123)
+  Text.putStrLn (Show.show Bool.True)
+
+  env <- Environment.getEnvironment
+  Maybe.maybe
+    (Text.putStrLn "Seems the environment variable is not there.")
+    (\path -> Text.putStrLn (Text.concat ["HOME is ", path]))
+    (List.lookup "HOME" env)
+

16-if.hell

main = do
+  if List.and [Eq.eq (Int.plus 1 1) 2,
+               Ord.lt (Int.plus 1 1) 3,
+               Eq.eq (Text.concat ["Hello, World!"]) "Hello, World!"]
+     then Text.putStrLn "OK, List.and works."
+     else Text.putStrLn "Uh, oh?"
+
+  if List.or [Eq.eq 1 2,
+              Eq.eq "x" "x"]
+     then Text.putStrLn "OK, List.or works."
+     else Text.putStrLn "Uh, oh?"
+
+  if Bool.not (Eq.eq 1 2)
+     then Text.putStrLn "OK, Bool.not works."
+     else Text.putStrLn "Uh, oh?"
+

17-reuse.hell

-- Technically you're not supposed to be able to do code re-use in
+-- Hell, but presently the desugarer inlines everything into `main`
+-- prior to type-checking, and ignores declarations that aren't
+-- reachable by main.
+
+main = do
+  Main.foo 1
+  Main.foo "blah"
+foo = \x -> Text.putStrLn (Show.show x)
+bar = Int.plus 4 "hi"
+

18-monads.hell

main = do
+  env <- Environment.getEnvironment
+
+  -- Maybe monad works!
+  Maybe.maybe (Text.putStrLn "Oops!") Text.putStrLn
+     (do path <- List.lookup "PATH" env
+         home <- List.lookup "HOME" env
+         Monad.return (Text.concat [path, " and ", home]))
+
+  -- Either monad works!
+  Either.either Text.putStrLn Text.putStrLn
+    (do x <- Main.parse "foo"
+        y <- Main.parse "foo"
+        Monad.return (Text.concat [x,y]))
+
+parse = \s ->
+  if Eq.eq s "foo"
+     then Either.Right "foooo :-)"
+     else Either.Left "oh noes!"
+

19-blog-generator.hell

-- This is a copy of the script that generates my blog.
+
+-- Dependencies:
+--
+-- hell-2024-02-07
+-- pandoc-3.1.11.1
+
+-- Main entry point just generates the complete blog every time.
+--
+--
+main = Main.generate
+
+-- The posts are listed under ./posts in this format:
+--
+-- dijkstra-haskell-java.markdown
+-- reasoning-violently.md
+-- god-mode.markdown
+-- emacs-mail.markdown
+--
+-- .md or .markdown files, the extension doesn't matter.
+--
+generate = do
+  posts <- Main.generatePosts
+  Main.generateArchive posts
+  Main.generateRSS posts
+
+-- Write out posts/$post/index.html per $post.
+--
+generatePosts = do
+  posts <- Directory.listDirectory "posts"
+  Text.putStrLn $ Text.concat ["Generating ", Show.show (List.length posts), " posts ..."]
+  Async.pooledForConcurrently posts \post -> do
+    contents <- Text.readFile $ Text.concat ["posts/", post]
+    Maybe.maybe
+      (Error.error "Couldn't parse the article!")
+      (\(date, title) -> do
+        rendered <- Main.render post
+        Monad.return (post, date, title, rendered))
+      $ Main.parse contents
+
+-- Generate the /posts/ page.
+--
+generateArchive = \posts -> do
+  Text.putStrLn "Generating archive ..."
+  let rows =
+        Text.concat
+          $ List.map
+            (\(post, date, title, content) ->
+              Text.concat [
+                 "<tr><td><a href='",
+                 Main.filename post,
+                 "'>",
+                 Main.strip title,
+                 "</td><td>",
+                 date,
+                 "</td></tr>"
+               ])
+            $ List.reverse
+            $ List.sortOn (\(post, date, title, content) -> date)
+            $ posts
+  let table = Text.concat [
+        "---\n",
+        "title: Archive\n",
+        "---\n",
+        "<table id='archive' style='line-height:2em'>",
+        rows,
+        "</table>"
+        ]
+  (out, err) <-
+    Text.readProcess_
+      $ Text.setStdin table
+      $ Process.proc "pandoc" ["--standalone","--template","templates/posts.html"]
+  Text.writeFile "webroot/posts/index.html" out
+
+-- Contents of an article looks like this:
+--
+-- ---
+-- date: 2011-04-10
+-- title: ‘amb’ operator and the list monad
+-- description: ‘amb’ operator and the list monad
+-- author: Chris Done
+-- tags: haskell, designs
+-- ---
+--
+-- We're only interested in the date and the title. The rest is
+-- redundant.
+--
+parse = \article -> do
+  sansPrefix <- Text.stripPrefix "---" article
+  let (preamble, _content) = Text.breakOn "---" sansPrefix
+  let lines = Text.splitOn "\n" preamble
+  let pairs = List.map (\line -> do let (key, value) = Text.breakOn ":" line
+                                    (key, Text.strip (Text.drop 1 value)))
+                       lines
+  date <- List.lookup "date" pairs
+  title <- List.lookup "title" pairs
+  Monad.return (date, title)
+
+-- A post consists of a date, title and markdown.
+--
+-- Rendering them is easy, just run pandoc and apply an HTML template.
+render = \post -> do
+  let targetDir =
+        Text.concat ["webroot/posts/", Main.filename post]
+  let targetFile = Text.concat [targetDir, "/index.html"]
+  (out, err) <- Text.readProcess_ (Process.proc "pandoc" ["--standalone","--template","templates/post.html",Text.concat ["posts/", post]])
+  Directory.createDirectoryIfMissing Bool.True targetDir
+  Text.writeFile targetFile out
+  Monad.return out
+
+-- Filename stripped of .md/.markdown.
+filename = \post -> Text.replace ".md" "" (Text.replace ".markdown" "" post)
+
+-- Strip out quotes from "foo".
+strip = \title ->
+  Maybe.maybe title Function.id do
+    title' <- Text.stripPrefix "\"" title
+    Text.stripSuffix "\"" title'
+
+-- Generate the /rss.xml page.
+--
+generateRSS = \posts0 -> do
+  let posts1 = List.reverse $ List.sortOn (\(post, date, title, content) -> date) posts0
+  posts <- Monad.forM posts1 \(post, date, title, content) -> do
+    date' <- Text.readProcessStdout_ $ Text.setStdin date $ Process.proc "date" ["-R", "-f", "/dev/stdin"]
+    Monad.return (post, date', title, content)
+  Text.putStrLn "Generating rss.xml ..."
+  let items =
+        Text.unlines
+          $ List.map
+            (\(post, date, title, content) ->
+              Text.concat [
+                 "<item>",
+                 "<title><![CDATA[", Main.strip title, "]]></title>",
+                 "<link>https://chrisdone.com/posts/", Main.filename post, "</link>",
+                 "<guid>https://chrisdone.com/posts/", Main.filename post, "</guid>",
+                 "<description><![CDATA[", content, "]]></description>",
+                 "<pubDate>", date, "</pubDate>",
+                 "<dc:creator>Chris Done</dc:creator>",
+                 "</item>"
+               ])
+            posts
+  let xml = Text.unlines [
+        "<?xml version=\"1.0\" encoding=\"utf-8\"?>",
+        "<rss version=\"2.0\" xmlns:atom=\"http://www.w3.org/2005/Atom\" xmlns:dc=\"http://purl.org/dc/elements/1.1/\">",
+        "<channel>",
+        "<title>Chris Done's Blog</title>",
+        "<link>https://chrisdone.com</link>",
+        "<description><![CDATA[Blog all about programming, especially in Haskell since 2008!]]></description>",
+        "<atom:link href=\"https://chrisdone.com/rss.xml\" rel=\"self\" type=\"application/rss+xml\" />",
+        "<lastBuildDate>Wed, 22 Dec 2021 00:00:00 UT</lastBuildDate>",
+        items,
+        "</channel>",
+        "</rss>"
+        ]
+  Text.writeFile "webroot/rss.xml" xml
+

20-dollar.hell

main = Text.putStrLn . Text.reverse $ "Foo!"
+

21-json.hell

main = do
+  ByteString.writeFile "demo.json" $
+    Json.encode $
+      Json.Object $ Map.fromList [
+        ("name", Json.String "Chris"),
+        ("age", Json.Number 99.123)
+       ]
+  bytes <- ByteString.readFile "demo.json"
+  ByteString.hPutStr IO.stdout bytes
+  Text.putStrLn $
+    Maybe.maybe "Bad parse."
+      (Json.value
+        "null"
+        (\str -> Text.concat ["bool", Show.show str])
+        (\str -> Text.concat ["str", Show.show str])
+        (\dub -> Text.concat ["dub", Show.show dub])
+        (\arr -> "Array!")
+        (\obj -> "Object."))
+       $ Json.decode bytes
+  Directory.removeFile "demo.json"
+

22-records.hell

data Person = Person { age :: Int, name :: Text }
+
+main = do
+  Text.putStrLn $ Record.get @"name" Main.person
+  Text.putStrLn $ Record.get @"name" $ Record.set @"name" "Mary" Main.person
+  Text.putStrLn $ Record.get @"name" $ Record.modify @"name" Text.reverse Main.person
+
+person =
+ Main.Person { name = "Chris", age = 23 }
+

23-args.hell

main = do
+  args <- Environment.getArgs
+  Monad.forM_ args IO.print
+ \ No newline at end of file diff --git a/docs/index.html b/docs/index.html index 61f9015..3ca392a 100644 --- a/docs/index.html +++ b/docs/index.html @@ -99,7 +99,7 @@

Hell: Shell scripting Haskell dialect

- +

Hell is a shell scripting language that is a tiny dialect of Haskell that I wrote for my diff --git a/scripts/gen-docs.hell b/scripts/gen-docs.hell index 408c7ca..818a65d 100644 --- a/scripts/gen-docs.hell +++ b/scripts/gen-docs.hell @@ -4,4 +4,24 @@ main = do _out <- ByteString.readProcess_ (Text.setStdin script (Process.proc "stack" ["ghci","--no-load"])) + examples <- Directory.listDirectory "examples/" + let render = \fp -> do + Text.putStrLn $ Text.concat ["Rendering ", fp] + text <- Text.readFile fp + Text.readProcessStdout_ $ Text.setStdin (Text.unlines ["```haskell",text,"```"]) (Process.proc "pandoc" ["--from","markdown","--to","html"]) + frags <- Monad.forM (List.sort examples) \example -> do + out <- render $ Text.concat ["examples/", example] + Monad.return (example, out) + Text.writeFile "docs/examples/index.html" $ Text.concat [ + "", + "", + "", + "", + "", + "", + "

Hell examples

", + "

Back to homepage

", + Text.concat $ List.map (\(fp, frag) -> Text.concat ["

", fp, "

", frag]) frags, + "" + ] Text.putStrLn "Generated docs."