#!/usr/bin/env stack {- stack --resolver lts-12.26 script --package containers --package process --package directory --package filepath --package regex-posix --package neat-interpolation --package text --package cpphs --package haskell-src-exts --package safe --package http-client --package http-client-tls -} {- COMPILE_FLAGS -O2 -threaded -rtsopts -eventlog -} -- Rationale: https://www.ahri.net/practical-haskell-programs-from-scratch/ {-# OPTIONS_GHC -Werror -Wall -Wcompat #-} {-# OPTIONS_GHC -Wincomplete-uni-patterns -Wincomplete-record-updates #-} {-# OPTIONS_GHC -Widentities -Wredundant-constraints #-} {-# OPTIONS_GHC -Wmonomorphism-restriction -Wmissing-home-modules #-} {-# LANGUAGE OverloadedStrings, ScopedTypeVariables, QuasiQuotes, LambdaCase #-} {-# LANGUAGE BangPatterns #-} import Control.Exception import Control.Monad import Data.Bits ((.|.)) import Data.Foldable import Data.Maybe import qualified Data.Text as T import qualified Data.Text.Encoding as T import Language.Haskell.Exts hiding (parse) import Language.Preprocessor.Cpphs hiding (Ident) import NeatInterpolation import Network.HTTP.Client import Network.HTTP.Client.TLS import Safe import System.Directory import System.Environment import System.Exit import System.FilePath import System.Info import System.Process import Text.Printf import Text.Regex.Posix type Resolver = T.Text defaultResolver :: Resolver defaultResolver = "lts-13.5" defaultTemplate :: String defaultTemplate = "default" main :: IO () main = do (scriptPath, command, cmdArgs) <- getArgs >>= processArgs setCurrentDirectory $ takeDirectory scriptPath let scriptName = takeFileName scriptPath case command of "new" -> new scriptName cmdArgs "repl" -> repl scriptName "watch" -> watch scriptName "test" -> test scriptName "lint" -> lint scriptName "todo" -> todo scriptName "compile" -> compile scriptName [] "profile" -> profile scriptName cmdArgs _ -> die $ printf "Error: unknown command: %s" command type Command = String processArgs :: [String] -> IO (FilePath, Command, [String]) processArgs (scriptPath:command:cmdArgs) = pure (scriptPath, command, cmdArgs) processArgs _ = usage templateList :: T.Text templateList = T.intercalate "|" $ T.pack . fst <$> templates stackInstallCmd :: Resolver -> String -> String stackInstallCmd resolver' pkg = printf "stack install --resolver %s %s" (T.unpack resolver') pkg dependency :: Parse -> String -> IO () dependency parse' dep = dependency' parse' dep dep dependency' :: Parse -> String -> String -> IO () dependency' parse' dep pkg = do let !resolver' = resolverFromScriptFile parse' depExe <- findExecutable dep when (isNothing depExe) $ die $ printf "Error: required dependency missing, install with: %s" (stackInstallCmd resolver' pkg::String) usage :: IO a usage = die $ T.unpack [text| Usage: script_name command [cmd params] Commands: new [$templateList] repl watch test lint todo compile profile [additional RTS options] |] sh :: CreateProcess -> IO () sh cp = do exitCode <- withCreateProcess cp (\_ _ _ ph -> waitForProcess ph) when (exitCode /= ExitSuccess) $ exitWith exitCode pure () type Parse = ([ModulePragma ()], [Comment]) parse :: FilePath -> IO Parse parse scriptName = do ( Module _ _head pragmas _imports _declarations , comments ) <- readFile scriptName >>= runCpphs defaultCpphsOptions scriptName >>= pure . (parseFileContentsWithComments $ ParseMode scriptName Haskell2010 [] False False Nothing False) >>= pure . fromParseResult pure ((() <$) <$> pragmas, comments) exts :: Parse -> [String] exts (ps, _) = join $ mapMaybe f ps where f (LanguagePragma _ xs) = Just $ mapMaybe g xs f _ = Nothing g (Ident _ s) = Just s g _ = Nothing scriptCmdWithReplacement :: String -> Parse -> String scriptCmdWithReplacement replacement (_, cs) = if null scriptComments then error . printf $ "No '{- stack' comment found" else head scriptComments where scriptComments = mapMaybe f cs f (Comment _ _ s) = if s =~ ("^ ?stack "::String) then Just . unwords . fmap ( replaceWord "runghc" replacement . replaceWord "script" replacement) . words $ s else Nothing replaceWord from to word = if word == from then to else word resolverFromScriptFile :: Parse -> Resolver resolverFromScriptFile (_, cs) = if null scriptComments then error . printf $ "No '{- stack --resolver RESOLVER' comment found" else T.pack $ head scriptComments where scriptComments = mapMaybe f cs f (Comment _ _ s) = if s =~ ("^ ?stack "::String) then case words $ (if os == "mingw32" then id else drop 1) s of ("stack":"--resolver":x:_) -> Just x _ -> Nothing else Nothing extraCompileFlags :: Parse -> [String] extraCompileFlags (_, cs) = join $ mapMaybe f cs where f (Comment _ _ s) = if s =~ ("^ ?COMPILE_FLAGS"::String) then Just . drop 1 $ words s else Nothing todos :: Parse -> [String] todos (_, cs) = mapMaybe f cs where todoPattern = makeRegexOpts (defaultCompOpt .|. compIgnoreCase) defaultExecOpt ("^ *TODO\\b"::String) f (Comment _ _ s) = if match todoPattern s then Just . unwords . (["-"] <>) . drop 1 $ words s else Nothing latestResolverLookupOnline :: IO Resolver latestResolverLookupOnline = do putStrLn "Info: attempting to get latest Stack resolver..." req <- parseRequest "HEAD https://www.stackage.org/lts" manager <- newManager $ managerSetProxy (proxyEnvironment Nothing) tlsManagerSettings mRedirects <- catch (Just . hrRedirects <$> responseOpenHistory req manager) (\(_::SomeException) -> putStrLn "Warning: failed to contact stackage.org" >> pure Nothing) maybe ((putStrLn $ "Info: failed to get resolver online, using default " <> T.unpack defaultResolver) >> pure defaultResolver) (\res -> (putStrLn $ "Info: got resolver " <> T.unpack res) >> pure res) $ do redirects <- mRedirects headers <- responseHeaders . snd <$> headMay redirects location <- lookup "Location" headers if location =~ ("^/lts-[0-9]+\\.[0-9]+"::String) then Just . T.drop 1 $ T.decodeUtf8 location else Nothing new :: FilePath -> [String] -> IO () new scriptName cmdArgs = do tplName <- case cmdArgs of [] -> pure defaultTemplate [tplName] -> pure tplName _ -> die $ printf "Error: must provide a template - %s" templateList noOverwrite scriptName resolver' <- latestResolverLookupOnline let template = lookup tplName templates case template of Nothing -> die $ printf "Error: no template named '%s'" tplName Just template' -> writeFile scriptName $ template' resolver' perms <- getPermissions scriptName setPermissions scriptName $ setOwnerExecutable True perms repl :: FilePath -> IO () repl scriptName = do parse' <- parse scriptName let exts' = fmap ("-X" <>) $ exts parse' let cmd = scriptCmdWithReplacement "exec ghci" parse' sh . shell $ printf "%s %s -- %s" cmd scriptName (unwords exts') watch :: FilePath -> IO () watch scriptName = do parse' <- parse scriptName dependency parse' "ghcid" let cmd = scriptCmdWithReplacement "exec ghci" parse' sh $ proc "ghcid" ["-c", printf "%s \"%s\"" cmd scriptName] test :: FilePath -> IO () test scriptName = do parse' <- parse scriptName dependency parse' "ghcid" let cmd = scriptCmdWithReplacement "exec ghci" parse' sh $ proc "ghcid" ["-c", printf "%s \"%s\"" cmd scriptName, "-T", "tests"] todo :: FilePath -> IO () todo scriptName = do todos' <- todos <$> parse scriptName traverse_ putStrLn todos' lint :: FilePath -> IO () lint scriptName = do parse' <- parse scriptName dependency parse' "hlint" dependency' parse' "refactor" "apply-refact" sh $ proc "hlint" ["--refactor", "--refactor-options=-is", scriptName] compile :: FilePath -> [String] -> IO () compile scriptName cmdlineExtraCompileFlags = do parse' <- parse scriptName let cmd = scriptCmdWithReplacement "exec ghc" parse' let flags = unwords $ extraCompileFlags parse' <> cmdlineExtraCompileFlags noOverwrite $ exeName scriptName let fullCmd :: String = printf "%s -- %s %s" cmd flags scriptName printf "Info: compile command: %s\n" fullCmd sh . shell $ fullCmd traverse_ removePathForcibly $ (takeBaseName scriptName ++) <$> [".hi", ".dyn_hi", ".o", ".dyn_o"] hint :: String -> String -> (String -> IO String) -> IO () hint exeN descr f = do exe <- findExecutable exeN case exe of Nothing -> do pkgCmd <- f exeN printf "Hint: install %s %s: %s\n" exeN descr pkgCmd _ -> printf "Use %s %s\n" exeN descr profile :: FilePath -> [String] -> IO () profile scriptName args = do resolver' <- resolverFromScriptFile <$> parse scriptName hint "threadscope" "to visually represent sparks" systemInstallCmd hint "profiteur" "to display cost centres" (pure . stackInstallCmd resolver') hint "profiterole" "to concisely reformat a .prof file" (pure . stackInstallCmd resolver') -- TODO: https://stackoverflow.com/questions/32123475/profiling-builds-with-stack compile scriptName ["-prof", "-fprof-auto"] extraRtsArgs <- if any (\case ('-':'N':_) -> True _ -> False ) args then pure args else do putStrLn "Info: as -N was not provided, -N is being used which uses all cores" pure $ "-N":args let rtsArgs = "+RTS":"-s":extraRtsArgs printf "Info: using RTS args; %s\n" (unwords rtsArgs) sh $ proc (exeName scriptName) rtsArgs exeName :: FilePath -> String exeName scriptName = takeBaseName scriptName ++ exeExtension noOverwrite :: FilePath -> IO () noOverwrite fname = do exists <- doesFileExist fname when exists . die $ printf "Error: file %s already exists - refusing to overwrite" fname systemInstallCmd :: String -> IO String systemInstallCmd pkg = do pkgMan <- foldr f (pure Nothing) ["apt"] pure $ case pkgMan of Nothing -> printf "use your package manager to install %s" pkg Just pm -> printf "%s install %s" pm pkg where f :: String -> IO (Maybe String) -> IO (Maybe String) f curr acc = do acc' <- acc case acc' of Nothing -> const (Just curr) <$> findExecutable curr Just _ -> acc -- TODO: keep track of what resolver was used to test with, in case later -- versions do not compile, the user could fall back using --tested or something templates :: [(String, Resolver -> String)] templates = [ (defaultTemplate, \resolver' -> T.unpack [text| #!/usr/bin/env stack {- stack --resolver $resolver' script -} {- COMPILE_FLAGS -O2 -threaded -rtsopts -eventlog -} -- https://downloads.haskell.org/~ghc/8.6.3/docs/html/users_guide/using-warnings.html {-# OPTIONS_GHC -Werror -Wall -Wcompat #-} {-# OPTIONS_GHC -Wincomplete-uni-patterns -Wincomplete-record-updates #-} {-# OPTIONS_GHC -Widentities -Wredundant-constraints #-} {-# OPTIONS_GHC -Wmonomorphism-restriction -Wmissing-home-modules #-} -- The idea is to remove these when you want to tidy your code up {-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-unused-matches #-} {-# OPTIONS_GHC -fno-warn-unused-top-binds -fno-warn-unused-local-binds #-} -- and add this, also when wanting to clean up code -- {-# OPTIONS_GHC -ddump-minimal-imports #-} {-# LANGUAGE OverloadedStrings, ScopedTypeVariables, QuasiQuotes, LambdaCase #-} main :: IO () main = do putStrLn "Hello world!" |]) , ("shellscript", \resolver' -> T.unpack [text| #!/usr/bin/env stack {- stack --resolver $resolver' script --package containers --package process --package directory --package filepath --package regex-posix -} {- COMPILE_FLAGS -O2 -threaded -rtsopts -eventlog -} -- https://downloads.haskell.org/~ghc/8.6.3/docs/html/users_guide/using-warnings.html {-# OPTIONS_GHC -Werror -Wall -Wcompat #-} {-# OPTIONS_GHC -Wincomplete-uni-patterns -Wincomplete-record-updates #-} {-# OPTIONS_GHC -Widentities -Wredundant-constraints #-} {-# OPTIONS_GHC -Wmonomorphism-restriction -Wmissing-home-modules #-} -- The idea is to remove these when you want to tidy your code up {-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-unused-matches #-} {-# OPTIONS_GHC -fno-warn-unused-top-binds -fno-warn-unused-local-binds #-} -- and add this, also when wanting to clean up code -- {-# OPTIONS_GHC -ddump-minimal-imports #-} {-# LANGUAGE OverloadedStrings, ScopedTypeVariables, QuasiQuotes, LambdaCase #-} import Control.Monad import Data.Semigroup import Data.Foldable import Data.Traversable import System.Directory import System.Environment import System.Exit import System.FilePath import System.IO import System.Process import Text.Printf import Text.Regex.Posix -- NB. find most helpful functions in https://hackage.haskell.org/package/directory/docs/System-Directory.html main :: IO () main = do sh $ shell "echo foo" sh $ proc "echo" ["bar"] findExecutable "stack" >>= print args <- getArgs putStrLn "args:" traverse_ (hPutStrLn stderr) args putStrLn "stdin:" getContents >>= putStrLn exitFailure sh :: CreateProcess -> IO () sh cp = do exitCode <- withCreateProcess cp (\_ _ _ ph -> waitForProcess ph) when (exitCode /= ExitSuccess) $ exitWith exitCode pure () |]) , ("quickcheck", \resolver' -> T.unpack [text| #!/usr/bin/env stack {- stack --resolver $resolver' script --package QuickCheck -} {- COMPILE_FLAGS -O2 -threaded -rtsopts -eventlog -} -- https://downloads.haskell.org/~ghc/8.6.3/docs/html/users_guide/using-warnings.html {-# OPTIONS_GHC -Werror -Wall -Wcompat #-} {-# OPTIONS_GHC -Wincomplete-uni-patterns -Wincomplete-record-updates #-} {-# OPTIONS_GHC -Widentities -Wredundant-constraints #-} {-# OPTIONS_GHC -Wmonomorphism-restriction -Wmissing-home-modules #-} -- The idea is to remove these when you want to tidy your code up {-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-unused-matches #-} {-# OPTIONS_GHC -fno-warn-unused-top-binds -fno-warn-unused-local-binds #-} -- and add this, also when wanting to clean up code -- {-# OPTIONS_GHC -ddump-minimal-imports #-} {-# LANGUAGE ScopedTypeVariables #-} import Test.QuickCheck tests :: IO () tests = quickCheck ((==)::Int -> Int -> Bool) |]) , ("httpclient", \resolver' -> T.unpack [text| #!/usr/bin/env stack {- stack --resolver $resolver' script --package aeson --package req --package data-default -} {- COMPILE_FLAGS -O2 -threaded -rtsopts -eventlog -} -- https://downloads.haskell.org/~ghc/8.6.3/docs/html/users_guide/using-warnings.html {-# OPTIONS_GHC -Werror -Wall -Wcompat #-} {-# OPTIONS_GHC -Wincomplete-uni-patterns -Wincomplete-record-updates #-} {-# OPTIONS_GHC -Widentities -Wredundant-constraints #-} {-# OPTIONS_GHC -Wmonomorphism-restriction -Wmissing-home-modules #-} -- The idea is to remove these when you want to tidy your code up {-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-unused-matches #-} {-# OPTIONS_GHC -fno-warn-unused-top-binds -fno-warn-unused-local-binds #-} -- and add this, also when wanting to clean up code -- {-# OPTIONS_GHC -ddump-minimal-imports #-} {-# LANGUAGE OverloadedStrings, ScopedTypeVariables, QuasiQuotes, LambdaCase #-} import Control.Monad.IO.Class import Data.Default import Data.Aeson import Network.HTTP.Req main :: IO () -- You can either make your monad an instance of 'MonadHttp', or use -- 'runReq' in any IO-enabled monad without defining new instances. main = runReq def $ do let payload = object [ "foo" .= (10 :: Int) , "bar" .= (20 :: Int) ] -- One function—full power and flexibility, automatic retrying on timeouts -- and such, automatic connection sharing. r <- req POST -- method (https "httpbin.org" /: "post") -- safe by construction URL (ReqBodyJson payload) -- use built-in options or add your own jsonResponse -- specify how to interpret response mempty -- query params, headers, explicit port number, etc. liftIO $ print (responseBody r :: Value) |]) , ("httpserver", \resolver' -> T.unpack [text| #!/usr/bin/env stack {- stack --resolver $resolver' script --package bytestring --package http-types --package warp --package wai --package blaze-html -} {- COMPILE_FLAGS -O2 -threaded -rtsopts -eventlog -} -- https://downloads.haskell.org/~ghc/8.6.3/docs/html/users_guide/using-warnings.html {-# OPTIONS_GHC -Werror -Wall -Wcompat #-} {-# OPTIONS_GHC -Wincomplete-uni-patterns -Wincomplete-record-updates #-} {-# OPTIONS_GHC -Widentities -Wredundant-constraints #-} {-# OPTIONS_GHC -Wmonomorphism-restriction -Wmissing-home-modules #-} -- The idea is to remove these when you want to tidy your code up {-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-unused-matches #-} {-# OPTIONS_GHC -fno-warn-unused-top-binds -fno-warn-unused-local-binds #-} -- and add this, also when wanting to clean up code -- {-# OPTIONS_GHC -ddump-minimal-imports #-} {-# LANGUAGE OverloadedStrings, ScopedTypeVariables, QuasiQuotes, LambdaCase #-} import Network.Wai import Network.HTTP.Types import Network.Wai.Handler.Warp (run) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Lazy as BL import qualified Text.Blaze.Html5 as H import Text.Blaze.Html5 ((!)) import qualified Text.Blaze.Html5.Attributes as HA import qualified Text.Blaze.Html.Renderer.Utf8 as HR {- What about... - - routing? - * there are a number of available routing packages - * a simple applicative parser can suffice, with pattern matching on the - resultant data structure - - https? - * a more complex subject, and one that is not always needed as a - terminator is often in use - for simple cases use a server like Caddy - to configure letsencrypt and proxy to you -} app :: Application app request respond = do BC8.putStrLn $ "Responding to " <> rawReq respond $ case rawReq of "/" -> responseLBS status200 [("Content-Type", "text/html")] . HR.renderHtml . H.html $ do H.head $ H.title "Hello world!" H.body $ do H.p $ H.text "Hi!" H.p ! HA.class_ "hello" ! HA.onclick "alert('yo')" $ H.text "Click me." "/passwd" -> responseFile status200 [("Content-Type", "text/plain")] "/etc/passwd" Nothing _ -> responseLBS status404 [("Content-Type", "text/text")] (BL.fromStrict $ "Couldn't find " <> rawReq) where rawReq = rawPathInfo request main :: IO () main = do putStrLn "http://localhost:8080/" run 8080 app |]) -- , ("consoleapp", \resolver' -> T.unpack [text| -- TODO: brick -- |]) , ("make", \resolver' -> T.unpack [text| #!/usr/bin/env stack {- stack --resolver $resolver' script --package shake -} {- COMPILE_FLAGS -O2 -threaded -rtsopts -eventlog -} -- https://downloads.haskell.org/~ghc/8.6.3/docs/html/users_guide/using-warnings.html {-# OPTIONS_GHC -Werror -Wall -Wcompat #-} {-# OPTIONS_GHC -Wincomplete-uni-patterns -Wincomplete-record-updates #-} {-# OPTIONS_GHC -Widentities -Wredundant-constraints #-} {-# OPTIONS_GHC -Wmonomorphism-restriction -Wmissing-home-modules #-} -- The idea is to remove these when you want to tidy your code up {-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-unused-matches #-} {-# OPTIONS_GHC -fno-warn-unused-top-binds -fno-warn-unused-local-binds #-} -- and add this, also when wanting to clean up code -- {-# OPTIONS_GHC -ddump-minimal-imports #-} {-# LANGUAGE ScopedTypeVariables, QuasiQuotes, LambdaCase #-} import Development.Shake import Development.Shake.Command import Development.Shake.FilePath import Development.Shake.Util main :: IO () main = shakeArgs shakeOptions{shakeFiles="_build"} $ do want ["_build/run" <.> exe] phony "clean" $ do putNormal "Cleaning files in _build" removeFilesAfter "_build" ["//*"] "_build/run" <.> exe %> \out -> do cs <- getDirectoryFiles "" ["//*.c"] let os = ["_build" c -<.> "o" | c <- cs] need os cmd_ "gcc -o" [out] os "_build//*.o" %> \out -> do let c = dropDirectory1 $ out -<.> "c" let m = out -<.> "m" cmd_ "gcc -c" [c] "-o" [out] "-MMD -MF" [m] needMakefileDependencies m |]) -- , ("lambda", \resolver' -> T.unpack [text| -- TODO: amazon lambda -- |]) -- , ("benchmark", \resolver' -> T.unpack [text| -- TODO: criterion -- |]) -- , ("diagrams", \resolver' -> T.unpack [text| -- TODO: auto-reloading of diagrams would be nice -- |]) -- , ("3layer", \resolver' -> T.unpack [text| -- TODO: https://www.parsonsmatt.org/2018/03/22/three_layer_haskell_cake.html -- |]) ]