commit aa357b90884e0fd84f4da46e7eff8f5b6cbc76d7 Author: Stefan Risberg Date: Thu Mar 16 21:57:07 2023 +0100 Initial commit diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..0017d98 --- /dev/null +++ b/.gitignore @@ -0,0 +1,29 @@ +.DS_Store +.idea +*.log +tmp/ + +dist +dist-* +cabal-dev +*.o +*.hi +*.hie +*.chi +*.chs.h +*.dyn_o +*.dyn_hi +.hpc +.hsenv +.cabal-sandbox/ +cabal.sandbox.config +*.prof +*.aux +*.hp +*.eventlog +.stack-work/ +cabal.project.local +cabal.project.local~ +.HTF/ +.ghc.environment.* +*.cabal diff --git a/README.md b/README.md new file mode 100644 index 0000000..48e407f --- /dev/null +++ b/README.md @@ -0,0 +1 @@ +# ris-utils diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 0000000..755202b --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,9 @@ +indentation: 2 +comma-style: leading +import-export-style: diff-friendly +indent-wheres: false +record-brace-space: false +respectful: true +haddock-style: multi-line +newlines-between-decls: 1 +fixities: [] diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..4a32374 --- /dev/null +++ b/package.yaml @@ -0,0 +1,73 @@ +name: ris-util +version: 0.0.1 +homepage: "https://git.fiskhamn.se/steffenomak/ris-util#readme" +license: BSD3 +author: "Stefan Risberg" +maintainer: "steffenomak@gmail.com" +copyright: "2023 Stefan Risberg" + +extra-source-files: +- README.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README at + +dependencies: +- base >= 4.7 && < 5 +- text == 1.2.* +- effectful-core >= 2.2.2.0 && < 3 +- effectful >= 2.2.2.0 && < 3 +- effectful-th == 1.* +- chronos >= 1.1.5 && < 2 +- torsor == 0.1 +- unliftio == 0.2.* +- co-log-core == 0.3.* + +ghc-options: +- -Wall +- -Wcompat +- -Widentities +- -Wincomplete-record-updates +- -Wincomplete-uni-patterns +- -Wmissing-export-lists +- -Wmissing-home-modules +- -Wpartial-fields +- -Wredundant-constraints + +library: + source-dirs: src + +default-extensions: + - BangPatterns + - BlockArguments + - ConstraintKinds + - DataKinds + - DeriveAnyClass + - DeriveGeneric + - DuplicateRecordFields + - FlexibleContexts + - FlexibleInstances + - GADTs + - LambdaCase + - MultiParamTypeClasses + - OverloadedLabels + - OverloadedStrings + - PolyKinds + - QuasiQuotes + - RankNTypes + - ScopedTypeVariables + - TemplateHaskell + - TupleSections + - TypeApplications + - TypeFamilies + - TypeOperators + - UndecidableInstances + - StandaloneDeriving + - ImportQualifiedPost + - LambdaCase diff --git a/src/Effects/Log.hs b/src/Effects/Log.hs new file mode 100644 index 0000000..91ac9ff --- /dev/null +++ b/src/Effects/Log.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Effects.Log ( + Severity (..), + runLogEff, + stderrLogger, + fmtMessage, + addTime, + Log, + log, + pattern I, + pattern D, + pattern W, + pattern E, + LogData (..), +) where + +import Colog.Core +import Data.Text (Text, justifyLeft) +import Data.Text qualified as T +import Data.Text.IO qualified as T +import Data.Text.Lazy qualified as LT +import Data.Text.Lazy.Builder qualified as T +import Effectful +import Effectful.Concurrent.QSem +import Effectful.Dispatch.Dynamic +import Effectful.Reader.Static +import Effectful.TH +import Effects.Time +import UnliftIO.Exception (bracket_) +import UnliftIO.IO (stderr) +import Prelude hiding (log) + +import Terminal + +class Monoid a => LogData a where + toLog :: a -> T.Builder + +instance LogData T.Builder where + toLog = id + +instance LogData Text where + toLog = T.fromText + +instance LogData String where + toLog = T.fromString + +data Log :: Effect where + Log :: Severity -> T.Builder -> Log m () + +makeEffect ''Log + +runLogEff :: + (Time :> es, Concurrent :> es, IOE :> es) => + LogAction IO T.Builder -> + Eff (Log : es) a -> + Eff es a +runLogEff logger e = do + lock <- newQSem 1 + + reinterpret + (runReader lock) + ( \_ -> \case + Log sev msg -> do + l <- ask + bracket_ (waitQSem l) (signalQSem l) $ do + t <- currentTimeB + liftIO $ cmap (addTime t . fmtMessage) logger <& msg `WithSeverity` sev + ) + e + +stderrLogger :: + (MonadIO m) => + LogAction m T.Builder +stderrLogger = LogAction (liftIO . T.hPutStrLn stderr . LT.toStrict . T.toLazyText) + +fmtMessage :: WithSeverity T.Builder -> T.Builder +fmtMessage (WithSeverity txt sev) = "[" <> T.fromText (justifyLeft 7 ' ' (colorSev sev)) <> "] - " <> txt + where + colorSev :: Severity -> Text + colorSev W = colorNormal Red . tshow $ W + colorSev a = tshow a + +addTime :: + T.Builder -> + T.Builder -> + T.Builder +addTime t msg = (" [" :: T.Builder) <> t <> ("] " :: T.Builder) <> toLog msg + +--- Helpers +tshow :: Show a => a -> Text +tshow = T.pack . show diff --git a/src/Effects/Time.hs b/src/Effects/Time.hs new file mode 100644 index 0000000..2e196c6 --- /dev/null +++ b/src/Effects/Time.hs @@ -0,0 +1,36 @@ +module Effects.Time ( + currentTime, + currentTimeB, + currentTimeT, + runTimeEff, + Time, +) +where + +import Chronos hiding (Time) +import Chronos qualified as C +import Data.Text (Text) +import Data.Text.Lazy.Builder qualified as T +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.TH + +data Time :: Effect where + CurrentTime :: Time m C.Time + CurrentTimeB :: Time m T.Builder + CurrentTimeT :: Time m Text + +makeEffect ''Time + +runTimeEff :: + (IOE :> es) => + Eff (Time : es) a -> + Eff es a +runTimeEff = interpret $ \_ -> \case + CurrentTime -> liftIO now + CurrentTimeB -> + builder_YmdHMS (SubsecondPrecisionFixed 4) w3c . timeToDatetime + <$> liftIO now + CurrentTimeT -> + encode_YmdHMS (SubsecondPrecisionFixed 4) w3c . timeToDatetime + <$> liftIO now diff --git a/src/Terminal.hs b/src/Terminal.hs new file mode 100644 index 0000000..246135e --- /dev/null +++ b/src/Terminal.hs @@ -0,0 +1,58 @@ +module Terminal ( + Color (..), + TextFeatures (..), + Section (..), + Term (..), +) +where + +import Data.String (IsString) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Lazy.Builder qualified as T + +data Color + = Black + | Red + | Green + | Yellow + | Blue + | Magenta + | Cyan + | White + deriving (Show, Eq, Enum) + +data TextFeatures + = AllOff + | Bold + | Underline + | BlinkOn + | BoldOff + | UnderlineOff + | BlinkOff + deriving (Eq) + +data Section + = Foreground + | Background + +class (IsString a, Monoid a) => Term a where + color :: Color -> Bool -> a -> a + + colorBright :: Color -> a -> a + colorBright c = color c True + + colorNormal :: Color -> a -> a + colorNormal c = color c False + +instance Term T.Builder where + color c bright txt = + let f = if bright then "9" else "3" + col = T.fromString . show . fromEnum $ c + in "\x1b[" <> f <> col <> "m" <> txt <> "\x1b[0m" + +instance Term Text where + color c bright txt = + let f = if bright then "9" else "3" + col = T.pack . show . fromEnum $ c + in "\x1b[" <> f <> col <> "m" <> txt <> "\x1b[0m" diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..2bc84ed --- /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: lts-20.12 + + +# 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: +- . +# 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: + - chronos-1.1.5 +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# + +# 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 0000000..8ede860 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,19 @@ +# 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: +- completed: + hackage: chronos-1.1.5@sha256:ca35be5fdbbb384414226b4467c6d1c8b44defe59a9c8a3af32c1c5fb250c781,3830 + pantry-tree: + sha256: 329bf39a05362a9c1f507a4a529725c757208843b562c55e0b7c88538dc3160f + size: 581 + original: + hackage: chronos-1.1.5 +snapshots: +- completed: + sha256: af5d667f6096e535b9c725a72cffe0f6c060e0568d9f9eeda04caee70d0d9d2d + size: 649133 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/12.yaml + original: lts-20.12