packages feed

preamble (empty) → 0.0.1

raw patch · 13 files changed

+609/−0 lines, 13 filesdep +aesondep +basedep +basic-preludesetup-changed

Dependencies added: aeson, base, basic-prelude, exceptions, fast-logger, lens, monad-control, monad-logger, mtl, resourcet, shake, template-haskell, text, text-manipulate, time, transformers-base, unordered-containers

Files

+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Shakefile.hs view
@@ -0,0 +1,215 @@+#!/usr/bin/env stack+{- stack+    runghc+    --package basic-prelude+    --package shake+ -}++{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Shake makefile for project.+--+import BasicPrelude+import Data.Char+import Development.Shake++-- | This file used for version change detection.+--+thisFile :: FilePath+thisFile = "Shakefile.hs"++-- | Location of build supporting files.+--+buildDir :: FilePath+buildDir = ".build"++-- | Location of stack's work files.+--+stackDir :: FilePath+stackDir = ".stack-work"++-- | Build directory where "touch" files are kept.+--+fakeDir :: FilePath+fakeDir = buildDir </> "fake"++-- | Fake directory path builder.+--+fd :: FilePath -> FilePath+fd = (fakeDir </>)++-- | Remove right excess on string.+--+rstrip :: String -> String+rstrip = reverse . dropWhile isSpace . reverse++-- | Typeful command args with return string.+--+cmdArgs :: String -> [String] -> Action String+cmdArgs c as = rstrip . fromStdout <$> cmd c as++-- | Typeful command args with no return.+--+cmdArgs_ :: String -> [String] -> Action ()+cmdArgs_ c as = unit $ cmd c as++-- | Stack command.+--+stack :: [String] -> Action ()+stack = cmdArgs_ "stack"++-- | Sylish command.+--+stylish :: [String] -> Action ()+stylish = cmdArgs_ "stylish-haskell"++-- | Lint command.+--+lint :: [String] -> Action ()+lint = cmdArgs_ "hlint"++-- | Git command.+--+git :: [String] -> Action String+git = cmdArgs "git"++-- | m4 command.+--+m4 :: [String] -> Action String+m4 = cmdArgs "m4"++-- | Version.+--+version :: Action String+version = git [ "describe", "--tags", "--abbrev=0" ]++-- | Touch a file for fake files.+--+touchFile :: FilePath -> Action ()+touchFile = flip writeFile' mempty++-- | Use a fake file to keep track of the last time an file-free action ran.+--+fake :: [FilePattern] -> String -> ([FilePath] -> Action ()) -> Rules ()+fake pats target act = do+  fd target %> \out -> do+    files <- getDirectoryFiles "." pats+    need files+    act files+    touchFile out++  phony target $+    need [ fd target ]++-- | Preprocess a file with m4+--+preprocess :: FilePattern -> FilePath -> Action [(String, String)] -> Rules ()+preprocess target file macros =+  target %> \out -> do+    need [ file ]+    let f k v = "-D" <> k <> "=" <> v+    macros' <- macros+    content <- m4 $ file : (uncurry f <$> macros')+    writeFileChanged out content++-- | Global rules+--+globalRules :: Rules ()+globalRules = do+  let pats =+        [ "stack.yaml"+        , "Shakefile.hs"+        , "src//*.hs"+        ]++  -- | preamble.cabal+  --+  preprocess "preamble.cabal" "preamble.cabal.m4" $ do+    v <- version+    return [ ("VERSION", v) ]++  -- | build+  --+  fake pats "build" $ \_files -> do+    need [ "preamble.cabal" ]+    stack [ "build", "--fast" ]++  -- | build-error+  --+  fake pats "build-error" $ \_files -> do+    need [ "preamble.cabal" ]+    stack [ "build", "--fast", "--ghc-options=-Werror" ]++  -- | ghci+  --+  phony "ghci" $ do+    need [ "preamble.cabal" ]+    stack [ "ghci", "--fast" ]++  -- | install+  --+  fake pats "install" $ \_files -> do+    need [ "preamble.cabal" ]+    stack [ "build", "--fast", "--copy-bins" ]++  -- | publish+  --+  phony "publish" $ do+    need [ "preamble.cabal" ]+    stack [ "sdist" ]+    stack [ "upload", "." ]++  -- | clean+  --+  phony "clean" $ do+    need [ "preamble.cabal" ]+    stack [ "clean" ]+    removeFilesAfter buildDir [ "//*" ]++  -- | clear+  --+  phony "clear" $+    forM_ [ fakeDir ] $ \dir ->+      removeFilesAfter dir [ "//*" ]++  -- | wipe+  --+  phony "wipe" $ do+    removeFilesAfter buildDir [ "//*" ]+    removeFilesAfter stackDir [ "//*" ]++  -- | sanity+  --+  phony "sanity" $+    need [ "build-error", "lint" ]++-- | Haskell source rules+--+hsRules :: Rules ()+hsRules = do+  let pats =+        [ "Shakefile.hs"+        , "src//*.hs"+        ]++  -- | format+  --+  fake pats "format" $ \files -> do+    need [ ".stylish-haskell.yaml" ]+    stylish $ [ "-c", ".stylish-haskell.yaml", "-i" ] <> files++  -- | lint+  --+  fake pats "lint" $ \files ->+    lint files++-- | Main entry point+--+main :: IO ()+main = do+  v <- getHashedShakeVersion [thisFile]+  shakeArgs shakeOptions { shakeFiles = buildDir, shakeVersion = v } $ do+    want [ "build-error", "lint", "format" ]+    globalRules+    hsRules
+ preamble.cabal view
@@ -0,0 +1,56 @@+name:                  preamble+version:               0.0.1+synopsis:              Yet another prelude.+homepage:              https://github.com/swift-nav/preamble+license:               MIT+author:                Swift Navigation Inc.+maintainer:            Mark Fine <dev@swiftnav.com>+copyright:             Copyright (C) 2016 Swift Navigation, Inc.+category:              Prelude+build-type:            Simple+cabal-version:         >= 1.10+description:+  Yet another prelude, built on BasicPrelude.++library+  hs-source-dirs:      src+  exposed-modules:     Preamble+  other-modules:       Preamble.Aeson+                     , Preamble.Ctx+                     , Preamble.Lens+                     , Preamble.Prelude+                     , Preamble.Trace+                     , Preamble.Types+                     , Preamble.Types.Alias+                     , Preamble.Types.Ctx+                     , Preamble.Types.Trans+  default-language:    Haskell2010+  ghc-options:         -Wall+  build-depends:       aeson+                     , base >= 4.7 && < 5+                     , basic-prelude+                     , exceptions+                     , fast-logger+                     , lens+                     , monad-control+                     , monad-logger+                     , mtl+                     , resourcet+                     , template-haskell+                     , text+                     , text-manipulate+                     , time+                     , transformers-base+                     , unordered-containers++executable shake-preamble+  main-is:             Shakefile.hs+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall -O2+  build-depends:       base >= 4.7 && < 5+                     , basic-prelude+                     , shake+  default-language:    Haskell2010++source-repository head+  type:                git+  location:            git@github.com:swift-nav/preamble.git
+ src/Preamble.hs view
@@ -0,0 +1,12 @@+-- | Public Module+--+module Preamble+  ( module Exports+  ) where++import Preamble.Aeson   as Exports+import Preamble.Ctx     as Exports+import Preamble.Lens    as Exports+import Preamble.Prelude as Exports+import Preamble.Trace   as Exports+import Preamble.Types   as Exports
+ src/Preamble/Aeson.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE NoImplicitPrelude #-}++-- | Aeson generic deriving options.+--+module Preamble.Aeson+  ( camelOptions+  , snakeOptions+  , spinalOptions+  ) where++import Data.Aeson.Types+import Data.Char+import Data.Text+import Data.Text.Manipulate+import Preamble.Prelude     hiding (dropWhile)++-- | Remove characters up to the first upper case character.+--+unprefix :: Text -> Text+unprefix = dropWhile (not . isUpper)++-- | Derive fields with camelCase.+--+camelOptions :: Options+camelOptions = defaultOptions+  { fieldLabelModifier     = unpack . toCamel . unprefix . pack+  , constructorTagModifier = unpack . toCamel . unprefix . lowerHead . pack+  , omitNothingFields      = True+  }++-- | Derive fields with snake_case.+--+snakeOptions :: Options+snakeOptions = defaultOptions+  { fieldLabelModifier     = unpack . toSnake . unprefix . pack+  , constructorTagModifier = unpack . toSnake . unprefix . lowerHead . pack+  , omitNothingFields      = True+  }++-- | Derive fields with spinal-case.+--+spinalOptions :: Options+spinalOptions = defaultOptions+  { fieldLabelModifier     = unpack . toSpinal . unprefix . pack+  , constructorTagModifier = unpack . toSpinal . unprefix . lowerHead . pack+  , omitNothingFields      = True+  }
+ src/Preamble/Ctx.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Preamble.Ctx+  ( runTransT+  , runCtx+  , preCtx+  ) where++import Control.Monad.Logger+import Control.Monad.Reader+import Preamble.Prelude+import Preamble.Trace+import Preamble.Types++-- | Run monad transformer, picking up logger from context.+--+runTransT :: HasCtx c => c -> TransT c m a -> m a+runTransT c m =+  runReaderT (runLoggingT (unTransT m) (c ^. cTrace)) c++-- | Run base context.+--+runCtx :: MonadIO m => TransT Ctx m a -> m a+runCtx action = do+  t <- liftIO $ newStderrTrace LevelInfo+  runTransT (Ctx mempty t) action++-- | Update base context's preamble.+--+preCtx :: MonadCtx c m => Pairs -> TransT Ctx m a -> m a+preCtx preamble action = do+  c <- view ctx <&> cPreamble <>~ preamble+  runTransT c action+
+ src/Preamble/Lens.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | makeClassy with constraints.+--+module Preamble.Lens+  ( makeClassyConstraints+  ) where++import Language.Haskell.TH+import Preamble.Prelude++-- | makeClassy with list of class constraints.+--+makeClassyConstraints :: Name -> [Name] -> DecsQ+makeClassyConstraints name names = do+  decls <- makeClassy name+  return $ addConstraints names decls++-- | Add constaints to a class.+--+addConstraints :: [Name] -> [Dec] -> [Dec]+addConstraints names = \case+  ClassD cs n tvs f d : ds ->+    ClassD (newConstraints names tvs ++ cs) n tvs f d : ds+  ds -> ds++-- | Create new constaints.+--+newConstraints :: [Name] -> [TyVarBndr] -> [Type]+newConstraints ns =+  loop where+    loop = \case+      PlainTV name : _tvs ->+        flip map ns $ \n ->+          AppT (ConT n) (VarT name)+      _tv : tvs -> loop tvs+      [] -> []
+ src/Preamble/Prelude.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE NoImplicitPrelude #-}++-- | Local Prelude.+--++module Preamble.Prelude+  ( module Exports+  ) where++import BasicPrelude as Exports+import Control.Lens as Exports hiding (uncons, (.=), (<.>))
+ src/Preamble/Trace.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Tracing functionality around MonadLogger.+--+module Preamble.Trace+  ( newStderrTrace+  , newStdoutTrace+  , nullTrace+  , traceDebug+  , traceInfo+  , traceWarn+  , traceError+  ) where++import           Control.Monad.Logger+import           Data.Aeson+import           Data.Aeson.Encode+import qualified Data.HashMap.Strict    as M+import qualified Data.Text.Lazy         as LT+import           Data.Text.Lazy.Builder+import           Data.Time+import           Preamble.Prelude+import           Preamble.Types+import           System.Log.FastLogger++-- | Trace out only if gte configured level.+--+levelTrace :: LogLevel -> LoggerSet -> Trace+levelTrace level ls _loc _source level' s =+  unless (level' < level) $ do+    pushLogStr ls s+    flushLogStr ls++-- | New logger to stderr.+--+newStderrTrace :: MonadIO m => LogLevel -> m Trace+newStderrTrace level =+  liftIO $ levelTrace level <$> newStderrLoggerSet defaultBufSize++-- | New logger to stdout.+--+newStdoutTrace :: MonadIO m => LogLevel -> m Trace+newStdoutTrace level =+  liftIO $ levelTrace level <$> newStdoutLoggerSet defaultBufSize++-- | Logger to nowhere.+--+nullTrace :: Trace+nullTrace _loc _source _level _s =+  return ()++-- | Trace out event with preamble and timestamp.+--+trace :: MonadCtx c m => (Text -> m ()) -> Text -> Pairs -> m ()+trace logN e ps = do+  t <- liftIO getCurrentTime+  let preamble = [ "event" .= e, "time" .= t ]+  p <- view cPreamble+  logN $ LT.toStrict $ toLazyText $ (<> singleton '\n') $+    encodeToTextBuilder $ Object $ M.fromList $ preamble <> p <> ps++-- | Debug tracing.+--+traceDebug :: MonadCtx c m => Text -> Pairs -> m ()+traceDebug = trace logDebugN++-- | Info tracing.+--+traceInfo :: MonadCtx c m => Text -> Pairs -> m ()+traceInfo = trace logInfoN++-- | Warn tracing.+--+traceWarn :: MonadCtx c m => Text -> Pairs -> m ()+traceWarn = trace logWarnN++-- | Error tracing.+--+traceError :: MonadCtx c m => Text -> Pairs -> m ()+traceError = trace logErrorN
+ src/Preamble/Types.hs view
@@ -0,0 +1,9 @@+-- | Export all the modules in the Types directory.+--+module Preamble.Types+  ( module Exports+  ) where++import Preamble.Types.Alias as Exports+import Preamble.Types.Ctx   as Exports+import Preamble.Types.Trans as Exports
+ src/Preamble/Types/Alias.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE NoImplicitPrelude #-}++-- | Various alias types.+--+module Preamble.Types.Alias where++import Control.Monad.Logger+import Data.Aeson+import Preamble.Prelude++-- | Pairs+--+type Pairs = [(Text, Value)]++-- | Trace+--+type Trace = Loc -> LogSource -> LogLevel -> LogStr -> IO ()
+ src/Preamble/Types/Ctx.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE ConstraintKinds   #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TemplateHaskell   #-}++-- | Context objects for monad transformers.+--+module Preamble.Types.Ctx where++import Control.Monad.Catch+import Control.Monad.Logger+import Control.Monad.Reader+import Control.Monad.Trans.Resource+import Preamble.Prelude+import Preamble.Types.Alias++-- | Ctx+--+-- Base context, supports tracing.+--+data Ctx = Ctx+  { _cPreamble :: Pairs+    -- ^ Object to encode on every trace line.+  , _cTrace    :: Trace+    -- ^ Configurable tracing function.+  }++$(makeClassy ''Ctx)++type MonadCtx c m =+  ( MonadBaseControl IO m+  , MonadIO m+  , MonadReader c m+  , MonadLogger m+  , MonadCatch m+  , MonadResource m+  , HasCtx c+  )
+ src/Preamble/Types/Trans.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoImplicitPrelude          #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}++-- | Monad transformer.+--+module Preamble.Types.Trans where++import Control.Monad.Base+import Control.Monad.Catch+import Control.Monad.Logger+import Control.Monad.Reader+import Control.Monad.Trans.Control+import Control.Monad.Trans.Resource+import Preamble.Prelude++-- | Monad transformer for reading and logging.+--+newtype TransT c m a = TransT+  { unTransT :: LoggingT (ReaderT c m) a+    -- ^ LoggingT and ReaderT transformer.+  } deriving (Functor, Applicative, Monad, MonadLogger, MonadReader c, MonadIO, MonadThrow, MonadCatch, MonadMask)++instance MonadBase b m => MonadBase b (TransT c m) where+  liftBase = liftBaseDefault++instance MonadBaseControl b m => MonadBaseControl b (TransT c m) where+    type StM (TransT c m) a = ComposeSt (TransT c) m a+    liftBaseWith = defaultLiftBaseWith+    restoreM = defaultRestoreM++instance MonadTransControl (TransT c) where+  type StT (TransT c) a = StT (ReaderT c) a+  liftWith f = TransT $+    liftWith $ \g ->+      liftWith $ \h ->+        f (h . g . unTransT)+  restoreT = TransT . restoreT . restoreT++instance MonadTrans (TransT c) where+  lift = TransT . lift . lift++instance MonadResource m => MonadResource (TransT c m) where+  liftResourceT = lift . liftResourceT