Hell examples

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

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

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!"

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

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

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

main = do
  IO.mapM_ Text.putStrLn ["Hello, ", "World!"]

  Function.fix (\(loop :: IO ()) -> do
    Text.putStrLn "Ahhhhh! More?"
    l <- Text.getLine
    loop)

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

  let (foo,bar) = (123, "foo")
  Text.putStrLn bar

  let typeSigsWork :: () = ()

  Monad.return ()

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!"])

  let config = Process.proc "false" []
  code <- Process.runProcess config
  Text.putStrLn "Done."

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

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

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)
    )

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

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!"])

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)

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?"

-- 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"

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!"

-- 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

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

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"

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 }

main = do
  args <- Environment.getArgs
  Monad.forM_ args IO.print

main = do
  (code, out, err) <- ByteString.readProcess (Process.proc "ls" ["-al"])

  -- Accessor style
  Exit.exitCode
    (Text.putStrLn "All good!")
    (\i -> IO.print i)
    code

  -- Validation style
  if Eq.eq code Exit.ExitSuccess
     then Text.putStrLn "OK, good!"
     else Text.putStrLn "Oh, sad."

data Value = Text Text | Number Int

data Rating = Good | Bad | Ugly

main = do
  let printIt = \x ->
        Text.putStrLn case x of
          Number i -> Show.show i
          Text t -> t
  printIt $ Main.Number 123
  printIt $ Main.Text "abc"
  Monad.mapM_ printIt [Main.Number 123,Main.Text "abc"]
  Text.putStrLn $ case Main.Good of
    Good -> "Good!"
    Bad -> "Bad!"
    Ugly -> "Ugly!"

-- User-defined types can reference other types now.
data Person = Person {
  name :: Text,
  address :: Main.Address,
  status :: Main.Status
  }
data Status = Retired | Working
data Address = Address {
  line1 :: Text, line2 :: Text
}
main = do
  let p :: Main.Person = Main.Person {
        name = "Chris",
        address = Main.Address { line1 = "1 North Pole", line2 = "Earth" },
        status = Main.Retired
       }
  Text.putStrLn $ Record.get @"name" p
  Text.putStrLn $
    Record.get @"line1" $
      Record.get @"address" @Main.Address p
      --                    ^ Unfortunately this is needed or else the
      --                    nested access causes an ambiguous type
      --                    variable. But it's not too bad.
  case Record.get @"status" @Main.Status p of
    Retired -> Text.putStrLn "Retired"
    Working -> Text.putStrLn "Working"

-- <https://github.com/chrisdone/hell/discussions/64>
--
-- Previously:
--
-- hell: Unification error: Couldn't match type

--   "Main.MySum"

-- against type

--   "MySum"

data MyRecord = MyRecord {sum :: Main.MySum}

data MySum = MySumL | MySumR

main = do
  let myRecord = Main.MyRecord {sum = Main.MySumR}
  Text.putStrLn "hello world"

-- Basic example of a tree data structure.
main = do
  let tree =
        Tree.Node "1" [
          Tree.Node "1.a" [],
          Tree.Node "1.b" [
            Tree.Node "1.b.x" []
          ]
        ]
  -- Do a trivial map, include the length of the tag in the nodes.
  let tree' = Tree.map (\a -> (a, Text.length a)) tree
  -- Write the tree out in a Lisp syntax.
  Tree.foldTree
    (\(a, len) children -> do
      Text.putStr "("
      Text.putStr a
      Text.putStr " "
      Text.putStr $ Show.show len
      Monad.forM_ children (\m -> do Text.putStr " "; m)
      Text.putStr ")")
    tree'