From 973e78bebec2773afe260171818807a57b67f3d2 Mon Sep 17 00:00:00 2001 From: Jordan Mackie Date: Thu, 26 May 2022 12:38:05 +0100 Subject: [PATCH] Add cst generator script (Haskell) --- .gitignore | 3 + scripts/cst-generator/Main.hs | 435 ++++++++++++++++++++++ scripts/cst-generator/cst-generator.cabal | 10 + shell-nixpkgs.nix | 9 + shell.nix | 27 +- stack.yaml | 67 ++++ stack.yaml.lock | 13 + 7 files changed, 556 insertions(+), 8 deletions(-) create mode 100644 scripts/cst-generator/Main.hs create mode 100644 scripts/cst-generator/cst-generator.cabal create mode 100644 shell-nixpkgs.nix create mode 100644 stack.yaml create mode 100644 stack.yaml.lock diff --git a/.gitignore b/.gitignore index 2a1fdb170..c42cc9a2b 100644 --- a/.gitignore +++ b/.gitignore @@ -10,3 +10,6 @@ node_modules # Local benchmarks control.bench latest.bench + +# Haskell +.stack-work diff --git a/scripts/cst-generator/Main.hs b/scripts/cst-generator/Main.hs new file mode 100644 index 000000000..8392bbe38 --- /dev/null +++ b/scripts/cst-generator/Main.hs @@ -0,0 +1,435 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Weverything -fno-warn-missing-import-lists -fno-warn-all-missed-specialisations #-} + +module Main (main) where + +import "base" Control.Monad (foldM, join, replicateM) +import "transformers" Control.Monad.Trans.State qualified as State +import "base" Data.List (intercalate) +import "base" Data.List.NonEmpty (NonEmpty (..)) +import "base" Data.List.NonEmpty qualified as NonEmpty +import "base" Data.Maybe (catMaybes) +import "base" System.IO (hPutStrLn, stderr) +import "random" System.Random (RandomGen, initStdGen, uniformR) +import "base" Text.Printf (printf) +import "base" Prelude + +lower :: RandomGen g => Random g Char +lower = choose ['a' .. 'z'] + +upper :: RandomGen g => Random g Char +upper = choose ['A' .. 'Z'] + +wordChar :: RandomGen g => Random g Char +wordChar = choose $ '_' :| ['A' .. 'Z'] <> ['a' .. 'z'] + +properName :: RandomGen g => Random g String +properName = (:) <$> upper <*> list (1, 10) wordChar + +name :: RandomGen g => Random g String +name = notKeyword ((:) <$> lower <*> list (1, 10) wordChar) + +unusedName :: RandomGen g => Random g String +unusedName = fmap ("_" <>) name + +qualified :: RandomGen g => Random g String -> Random g String +qualified rand = + chooseRandom + [ rand, + sep "." <$> sequence [properName, rand] + ] + +qualifiedName :: RandomGen g => Random g String +qualifiedName = qualified name + +qualifiedProperName :: RandomGen g => Random g String +qualifiedProperName = qualified properName + +everything :: String +everything = "(..)" + +exportList :: RandomGen g => Random g String +exportList = + chooseRandom + [ pure everything, + exposeList + ] + +exposeList :: forall g. RandomGen g => Random g String +exposeList = do + items <- list (5, 15) exposeItem + pure $ parens (commaSep items) + where + exposeItem = chooseRandom [exposeValue, exposeType] + + exposeValue :: Random g String + exposeValue = name + + exposeType :: Random g String + exposeType = do + typeName <- properName + abstract <- bool + pure if abstract then typeName else (typeName <> everything) + +importLine :: forall g. RandomGen g => Random g String +importLine = + unwords . catMaybes + <$> sequence + [ pure (Just "import"), + optional packageName, + Just <$> moduleName, + optional alias, + optional exposeList, + pure (Just ";") + ] + where + packageName :: Random g String + packageName = notKeyword do + let char :: Random g Char + char = choose $ '-' :| ['a' .. 'z'] + s <- (:) <$> lower <*> list (1, 10) char + pure (parens s) + + alias :: Random g String + alias = fmap ("as " <>) properName + +moduleName :: RandomGen g => Random g String +moduleName = sep "." <$> list (1, 10) properName + +moduleDeclaration :: forall g. RandomGen g => Random g String +moduleDeclaration = + chooseRandom + [ foreignDeclaration, + typeDeclaration, + valueDeclaration + ] + where + foreignDeclaration :: Random g String + foreignDeclaration = do + n <- name + t <- dittoType 4 + pure $ unwords ["foreign", n, ":", t, ";"] + + typeDeclaration :: Random g String + typeDeclaration = do + typeName <- properName + params <- maybe "" (parens . commaSep) <$> optional (list (1, 6) name) + constructors <- list (0, 10) do + constructorName <- properName + args <- maybe "" (parens . commaSep) <$> optional (list (1, 6) (dittoType 2)) + pure (constructorName <> args) + case constructors of + [] -> pure $ unwords ["type", typeName, params, ";"] + [constructor] -> do + includePipe <- bool + pure $ unwords ["type", typeName, params, "=", if includePipe then "|" else "", constructor, ";"] + _ -> + pure $ unwords ["type", typeName, params, "=", unlines (map ("| " <>) constructors), ";"] + + valueDeclaration :: Random g String + valueDeclaration = do + valueName <- name + typeAnn <- maybe "" (": " <>) <$> optional (dittoType 4) + value <- expr 4 + pure $ unwords [valueName, typeAnn, "=", value, ";"] + +moduleHeader :: RandomGen g => Random g String +moduleHeader = do + mn <- moduleName + exports <- exportList + pure $ unwords ["module", mn, "exports", exports, ";"] + +dittoType :: forall g. RandomGen g => Int -> Random g String +dittoType depth + | depth <= 0 = type0 + | otherwise = + chooseRandom + [ typeParens, + typeFunction, + typeCall, + typeClosedRecord, + typeOpenRecord, + type0 + ] + where + typeParens = parens <$> child + + typeCall = do + fn <- chooseRandom [typeVariable, typeConstructor] + params <- list (1, 5) child + pure $ fn <> parens (commaSep params) + + typeFunction = do + params <- list (0, 4) child + returned <- child + pure $ parens (commaSep params) <> " -> " <> returned + + typeClosedRecord = do + fields <- list (0, 5) typeRecordField + pure $ braces (commaSep fields) + typeOpenRecord = do + var <- typeVariable + fields <- list (1, 5) typeRecordField + pure $ braces (var <> "|" <> commaSep fields) + typeRecordField = (\label t -> label <> ": " <> t) <$> name <*> child + + child :: Random g String + child = dittoType (depth - 1) + + type0 = + chooseRandom + [ typeVariable, + typeConstructor + ] + + typeVariable :: Random g String + typeVariable = name + + typeConstructor :: Random g String + typeConstructor = qualifiedProperName + +expr :: forall g. RandomGen g => Int -> Random g String +expr depth + | depth <= 0 = expr0 + | otherwise = + chooseRandom + [ parens <$> child, + exprIf, + exprCall, + exprFn, + exprMatch, + exprEffect, + exprAccess, + exprArray, + exprRecord, + expr0 + ] + where + exprIf = unwords <$> sequence [pure "if", child, pure "then", child, pure "else", child] + + exprCall = do + f <- chooseRandom [exprVariable, exprConstructor, exprAccess, parens <$> exprFn] + args <- parens . commaSep <$> list (0, 20) child + pure (f <> args) + + exprFn = do + params <- + parens . commaSep <$> list (0, 10) do + binder <- name + typeAnn <- maybe "" (": " <>) <$> optional (dittoType 4) + pure (binder <> typeAnn) + typeAnn <- maybe "" ((": " <>) . parens) <$> optional (dittoType 7) + body <- child + pure ("fn" <> params <> typeAnn <> " -> " <> body) + + exprMatch = do + matched <- expr0 + arms <- list (1, 10) do + pat <- pattern 4 + e <- child + pure ("| " <> pat <> " -> " <> e) + + pure . unwords $ ["match", matched, "with"] <> arms <> ["end"] + + exprEffect = do + n <- int (1, 20) + fmap (("do " <>) . braces) (stmts n) + where + stmts :: Int -> Random g String + stmts n + | n <= 0 = chooseRandom [stmtReturn, stmtExpr] + | otherwise = stmtBind n + + stmtBind n = do + binder <- name + e <- expr0 + rest <- stmts (n - 1) -- not tail recursive but meh for now + pure $ unwords [binder, "<-", e, ";", rest] + + stmtReturn = fmap ("return " <>) expr0 + stmtExpr = expr0 + + exprAccess :: Random g String + exprAccess = intercalate "." <$> list (2, 20) name + + exprRecord :: Random g String + exprRecord = + braces . commaSep <$> list (0, 10) do + label <- name + value <- child + pure (label <> " = " <> value) + + exprArray :: Random g String + exprArray = brackets . commaSep <$> list (0, 10) child + + child :: Random g String + child = expr (depth - 1) + + expr0 = + chooseRandom + [ exprVariable, + exprConstructor, + exprString, + exprInt, + exprFloat, + exprPipe, + pure "unit", + pure "true", + pure "false" + ] + + exprPipe = sep "|>" <$> list (1, 10) expr0 + + exprVariable :: Random g String + exprVariable = qualifiedName + + exprConstructor :: Random g String + exprConstructor = qualifiedProperName + + exprInt :: Random g String + exprInt = show <$> int (0, 100000) + + exprFloat :: Random g String + exprFloat = do + i <- int (1, 100000) + j <- int (1, 100000) + pure $ printf "%.4f" (fromIntegral @_ @Double i / fromIntegral j) + + exprString :: Random g String + exprString = + dquotes <$> list (10, 50) (choose $ ['0' .. '9'] <> ['A' .. 'Z'] <> ['a' .. 'z']) + +pattern :: forall g. RandomGen g => Int -> Random g String +pattern depth + | depth <= 0 = pattern0 + | otherwise = chooseRandom [patternConstructor, pattern0] + where + patternConstructor :: Random g String + patternConstructor = do + ctorName <- qualifiedProperName + args <- parens . commaSep <$> list (1, 10) (pattern (depth - 1)) + pure (ctorName <> args) + + pattern0 :: Random g String + pattern0 = + chooseRandom + [name, unusedName, qualifiedProperName] + +_dittoModule :: RandomGen g => Random g String +_dittoModule = do + header <- moduleHeader + imports <- replicateM 20 importLine + decls <- replicateM 20 moduleDeclaration + pure $ unlines (header : imports <> decls) + +main :: IO () +main = do + g0 <- initStdGen + g1 <- runRandomAndPrint moduleHeader g0 + g2 <- foldM (\g _i -> runRandomAndPrint importLine g) g1 ([0 .. 20] :: [Int]) + _g3 <- foldM (\g i -> hPutStrLn stderr (show i) >> runRandomAndPrint moduleDeclaration g) g2 ([0 .. 100] :: [Int]) + pure () + where + runRandomAndPrint :: Random g String -> g -> IO g + runRandomAndPrint rand g = do + let (string, g') = runRandom rand g + putStrLn string + pure g' + +---------- + +dquotes :: String -> String +dquotes = surround "\"" "\"" + +parens :: String -> String +parens = surround "(" ")" + +braces :: String -> String +braces = surround "{" "}" + +brackets :: String -> String +brackets = surround "[" "]" + +surround :: String -> String -> String -> String +surround begin end s = begin <> s <> end + +commaSep :: [String] -> String +commaSep = sep ", " + +sep :: String -> [String] -> String +sep = intercalate + +type Random g a = State.State g a + +runRandom :: Random g a -> g -> (a, g) +runRandom = State.runState + +bool :: RandomGen g => Random g Bool +bool = choose [True, False] + +optional :: RandomGen g => Random g a -> Random g (Maybe a) +optional rand = chooseRandom [Just <$> rand, pure Nothing] + +chooseRandom :: RandomGen g => NonEmpty (Random g a) -> Random g a +chooseRandom = join . choose + +choose :: RandomGen g => NonEmpty a -> Random g a +choose xs = do + i <- int (0, length xs - 1) + pure (xs NonEmpty.!! i) + +list :: RandomGen g => (Int, Int) -> Random g a -> Random g [a] +list range rand = do + len <- int range + replicateM len rand + +int :: RandomGen g => (Int, Int) -> Random g Int +int (min', max') = do + g <- State.get + let (i, g') = System.Random.uniformR (min', max') g + State.put g' + pure i + +notKeyword :: RandomGen g => Random g String -> Random g String +notKeyword rand = do + s <- rand + if s `elem` keywords then notKeyword rand else pure s + +keywords :: [String] +keywords = + [ "module", + "exports", + "import", + "as", + "type", + "foreign", + "fn", + "if", + "then", + "else", + "match", + "with", + "end", + "do", + "return" + ] + +{- + +# develop +ghcid --command='stack repl cst-generator' --run + +# test +stack run cst-generator | tee debug.ditto | ditto fmt --stdin + +# debug +ditto fmt debug.ditto 2>&1 | less -S + +-} diff --git a/scripts/cst-generator/cst-generator.cabal b/scripts/cst-generator/cst-generator.cabal new file mode 100644 index 000000000..233c5781d --- /dev/null +++ b/scripts/cst-generator/cst-generator.cabal @@ -0,0 +1,10 @@ +cabal-version: >= 1.10 + +name: cst-generator +version: 1.0.0 +build-type: Simple + +executable cst-generator + main-is: Main.hs + build-depends: base, transformers, random + default-language: Haskell2010 diff --git a/shell-nixpkgs.nix b/shell-nixpkgs.nix new file mode 100644 index 000000000..a566ac4ae --- /dev/null +++ b/shell-nixpkgs.nix @@ -0,0 +1,9 @@ +# nix repl ./shell-nixpkgs.nix +let + nixpkgsRev = "c1da6fc4ce95fe59f2c0c8e7cee580a37e0bb94b"; + nixpkgs = builtins.fetchTarball { + name = "nixpkgs-${nixpkgsRev}"; + url = "https://github.com/nixos/nixpkgs/archive/${nixpkgsRev}.tar.gz"; + sha256 = "15s8cg7n6b7l8721s912733y7qybjvj73n5gsjx31707b3qn38gn"; + }; +in import nixpkgs diff --git a/shell.nix b/shell.nix index 0eef7c0d8..437a6f0df 100644 --- a/shell.nix +++ b/shell.nix @@ -1,12 +1,7 @@ let - nixpkgsRev = "c1da6fc4ce95fe59f2c0c8e7cee580a37e0bb94b"; - nixpkgs = builtins.fetchTarball { - name = "nixpkgs-${nixpkgsRev}"; - url = "https://github.com/nixos/nixpkgs/archive/${nixpkgsRev}.tar.gz"; - sha256 = "15s8cg7n6b7l8721s912733y7qybjvj73n5gsjx31707b3qn38gn"; - }; - pkgs = import nixpkgs { }; - lib = pkgs.lib; + pkgs = import ./shell-nixpkgs.nix { }; + + inherit (pkgs) lib; fenixRev = "9e3384c61656487b10226a3366a12c37393b21d9"; fenixPackages = import (builtins.fetchTarball { @@ -34,6 +29,15 @@ let doCheck = false; }; + stack = pkgs.symlinkJoin { + name = "stack-with-system-ghc"; + paths = [ pkgs.stack ]; + buildInputs = [ pkgs.makeWrapper ]; + postBuild = '' + wrapProgram $out/bin/stack --add-flags "--system-ghc" + ''; + }; + # Should match .nvmrc # Also see: https://nixos.wiki/wiki/Node.js#Example_nix_shell_for_Node.js_development # (but note building Node from source takes aaages) @@ -48,6 +52,13 @@ in pkgs.mkShell { pkgs.cargo-outdated pkgs.cargo-tarpaulin cargo-benchcmp + + # Haskell stuff + stack + pkgs.ghc + pkgs.ormolu + pkgs.ghcid + nodejs pkgs.ninja pkgs.openssl diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 000000000..c16286475 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,67 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml +resolver: + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/8.yaml + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - auto-update +# - wai +packages: + - scripts/cst-generator +# Dependency packages to be pulled from upstream that are not in the resolver. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +# extra-deps: [] + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=2.7" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 000000000..ecc702e1b --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,13 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: [] +snapshots: +- completed: + size: 618506 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/8.yaml + sha256: f1c4aca9b9b81afbb9db55571acb0690cdc01ac97a178234de281f9dc075e95e + original: + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/8.yaml