json-tracer (empty) → 0.0.1.0
raw patch · 13 files changed
+580/−0 lines, 13 filesdep +aesondep +aeson-prettydep +basesetup-changed
Dependencies added: aeson, aeson-pretty, base, bytestring, containers, ghc-prim, hashable, hspec, hspec-core, hspec-discover, hspec-expectations, json-tracer, microlens, microlens-ghc, mtl, template-haskell, text, time, transformers, unordered-containers
Files
- LICENSE +30/−0
- README.md +2/−0
- Setup.hs +2/−0
- example/Fib.hs +24/−0
- example/Fib2.hs +31/−0
- example/Main.hs +43/−0
- json-tracer.cabal +85/−0
- src/Control/Monad/CTrace.hs +93/−0
- src/Control/Monad/Trans/CTrace.hs +73/−0
- src/Data/PolyDict.hs +129/−0
- src/JSON/Trace.hs +25/−0
- test/PolyDictSpec.hs +42/−0
- test/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,2 @@+# json-tracer+Type-safe polymorphic json-structured tracing library
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ example/Fib.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE DataKinds, TypeFamilies, OverloadedLabels #-}+module Fib where+import Lens.Micro+import JSON.Trace++data Fib+type instance Assoc Fib "arg" = Int+type instance Assoc Fib "ret" = Int+type instance Assoc Fib "left" = Dict Fib+type instance Assoc Fib "right" = Dict Fib++fib :: Monad m => Int -> TracerT (Dict Fib) m Int+fib n = do+ update (access #arg ?~ n)+ r <- case n of+ 0 -> return 0+ 1 -> return 1+ n -> (+) <$> zoom (access' #left empty) (fib (n-1)) + <*> zoom (access' #right empty) (fib (n-2))+ update (access #ret ?~ r)+ return r+++
+ example/Fib2.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE DataKinds, TypeFamilies, OverloadedLabels, FlexibleContexts #-}+module Fib2 where+import Fib(Fib)+import Lens.Micro+import JSON.Trace+import Control.Monad.State.Strict+import qualified Data.IntMap as M++type instance Assoc Fib "calls" = [(Int,Int)]++memoFib :: (MonadState (M.IntMap Int) m, + MonadTrace (Dict Fib) m) => Int -> m Int+memoFib n = do+ memo <- get+ case M.lookup n memo of+ Just v -> return v+ Nothing -> do+ v <- case n of+ 0 -> return 0+ 1 -> return 1+ _ -> (+) <$> memoFib (n-1) <*> memoFib (n-2)+ modify' (M.insert n v)+ update $ access' #calls [] %~ ((n,v):)+ return v++fib :: Monad m => Int -> TracerT (Dict Fib) m Int+fib n = do+ update (access #arg ?~ n)+ r <- evalStateT (memoFib n) (M.empty)+ update (access #ret ?~ r)+ return r
+ example/Main.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE DataKinds, TypeFamilies, OverloadedLabels #-}+import JSON.Trace+import Data.Aeson.Encode.Pretty+import qualified Data.ByteString.Lazy as B+import Data.Time(NominalDiffTime, getCurrentTime, diffUTCTime)+import Control.Monad.Trans+import Control.Monad+import Lens.Micro+import qualified Fib+import qualified Fib2++data Main+type instance Assoc Main "elapsed_time" = NominalDiffTime+type instance Assoc Main "tag" = String+type instance Assoc Main "fib" = (Dict Fib.Fib)++doit1 :: TracerT (Dict Main) IO Int+doit1 = do+ update $ access #tag ?~ "doit1"+ t_start <- liftIO getCurrentTime+ r <- zoom (access' #fib empty) (Fib.fib 5)+ t_end <- liftIO getCurrentTime+ update $ access #elapsed_time ?~ (diffUTCTime t_end t_start)+ return r++doit2 :: TracerT (Dict Main) IO Int+doit2 = do+ update $ access #tag ?~ "doit2"+ t_start <- liftIO getCurrentTime+ r <- zoom (access' #fib empty) (Fib2.fib 5)+ t_end <- liftIO getCurrentTime+ update $ access #elapsed_time ?~ (diffUTCTime t_end t_start)+ return r+++main :: IO ()+main = do+ forM_ [doit1,doit2] $ \doit -> do+ (r, d) <- dictTraceT doit+ B.putStr (encodePretty d)+ putStrLn ""+ print r+
+ json-tracer.cabal view
@@ -0,0 +1,85 @@+name: json-tracer+version: 0.0.1.0+-- synopsis:+description: + .+ An polymorphic, type-safe, structured tracing library.++homepage: https://github.com/autotaker/jsontracer#readme+license: BSD3+license-file: LICENSE+author: Taku Terao+maintainer: autotaker@gmail.com+copyright: 2017 Taku Terao+category: Control+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ hs-source-dirs: src+ ghc-options: -O2 -W+ exposed-modules: Data.PolyDict+ , Control.Monad.Trans.CTrace+ , Control.Monad.CTrace+ , JSON.Trace+ build-depends: base >= 4.7 && <5,+ mtl >=2.2 && <2.3, + unordered-containers >= 0.2.8,+ hashable >= 1.2.6 && < 1.2.7,+ ghc-prim >= 0.5 && < 0.6,+ microlens > 0.4.0,+ microlens-ghc > 0.4.0,+ transformers >= 0.5 && < 0.6,+ containers >= 0.5 && < 0.6,+ text >= 1.2.2,+ aeson >= 0.11,+ template-haskell >= 2.11+ default-extensions: FlexibleInstances+ , FlexibleContexts+ , BangPatterns+ , MultiParamTypeClasses+ , ScopedTypeVariables+ , GADTs+ , OverloadedLabels+ , DataKinds+ , TypeFamilies+ , RankNTypes+ , TemplateHaskell+ default-language: Haskell2010++test-suite unit-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules: PolyDictSpec+ build-depends: base+ , json-tracer+ , hspec >= 2.2+ , hspec-core >= 2.2+ , hspec-expectations >= 0.7+ , hspec-discover+ , microlens+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010++test-suite example+ type: exitcode-stdio-1.0+ hs-source-dirs: example+ main-is: Main.hs+ other-modules: Fib, Fib2+ build-depends: base+ , json-tracer+ , microlens+ , aeson+ , aeson-pretty+ , time+ , containers+ , bytestring+ , mtl+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/autotaker/jsontracer
+ src/Control/Monad/CTrace.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, FunctionalDependencies, UndecidableInstances #-}+-- |+-- Module : Control.Monad.CTrace+-- Copyright : (c) Taku Terao, 2017 +-- License : BSD3 +-- Maintainer : autotaker@gmail.com +-- Stability : experimental +-- Portability : GHC+-- Contextual tracing monad, mtl-compatible.++module Control.Monad.CTrace( MonadTrace(..)+ , TracerT+ , zoom+ , runTracerT+ , noTracerT+ , ioTracerT) where++import Control.Monad.Trans.CTrace hiding (update)+import qualified Control.Monad.Trans.CTrace as T(update)+import Lens.Micro++import Control.Monad.Trans.Reader+import Control.Monad.Trans.Except+import Control.Monad.Trans.List+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Cont+import qualified Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.State.Lazy as Lazy+import qualified Control.Monad.Trans.Writer.Strict as Strict+import qualified Control.Monad.Trans.Writer.Lazy as Lazy+import qualified Control.Monad.Trans.RWS.Strict as Strict+import qualified Control.Monad.Trans.RWS.Lazy as Lazy+import Control.Monad.Trans.Class(lift)++-- | contextual tracing monad+class Monad m => MonadTrace c m | m -> c where+ -- | Apply the specified function to the tracing context+ update :: (c -> c) -> m ()+ -- | monomorphic version of 'zoom' operation+ zoom' :: ASetter' c c -> m a -> m a++instance Monad m => MonadTrace c (TracerT c m) where+ update = T.update + zoom' = zoom++instance MonadTrace c m => MonadTrace c (ReaderT r m) where+ update = lift . update+ zoom' = mapReaderT . zoom'++instance (Monoid w, MonadTrace c m) => MonadTrace c (Strict.WriterT w m) where+ update = lift . update+ zoom' = Strict.mapWriterT .zoom'++instance (Monoid w, MonadTrace c m) => MonadTrace c (Lazy.WriterT w m) where+ update = lift . update+ zoom' = Lazy.mapWriterT .zoom'++instance (MonadTrace c m) => MonadTrace c (ExceptT e m) where+ update = lift . update+ zoom' = mapExceptT . zoom'++instance (MonadTrace c m) => MonadTrace c (IdentityT m) where+ update = lift . update+ zoom' = mapIdentityT . zoom'++instance (MonadTrace c m) => MonadTrace c (ListT m) where+ update = lift . update+ zoom' = mapListT . zoom'++instance (MonadTrace c m) => MonadTrace c (MaybeT m) where+ update = lift . update+ zoom' = mapMaybeT . zoom'++instance (MonadTrace c m) => MonadTrace c (Strict.StateT s m) where+ update = lift . update+ zoom' = Strict.mapStateT . zoom'++instance (MonadTrace c m) => MonadTrace c (Lazy.StateT s m) where+ update = lift . update+ zoom' = Lazy.mapStateT . zoom'++instance (Monoid w, MonadTrace c m) => MonadTrace c (Strict.RWST r w s m) where+ update = lift . update+ zoom' = Strict.mapRWST . zoom'++instance (Monoid w, MonadTrace c m) => MonadTrace c (Lazy.RWST r w s m) where+ update = lift . update+ zoom' = Lazy.mapRWST . zoom'++instance (MonadTrace c m) => MonadTrace c (ContT r m) where+ update = lift . update+ zoom' = mapContT . zoom'
+ src/Control/Monad/Trans/CTrace.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, FunctionalDependencies, UndecidableInstances, StandaloneDeriving #-}+-- |+-- Module : Control.Monad.CTrace+-- Copyright : (c) Taku Terao, 2017 +-- License : BSD3 +-- Maintainer : autotaker@gmail.com +-- Stability : experimental +-- Portability : GHC+-- Contextual tracing monad transformer. transformers-compatible.+module Control.Monad.Trans.CTrace(TracerT, runTracerT, zoom, update, noTracerT, ioTracerT) where++import Control.Monad.Cont.Class+import Control.Monad.Reader+import Control.Monad.Writer.Class+import Control.Monad.Error.Class+import Control.Monad.State.Class+import Control.Monad.RWS.Class+import Lens.Micro+import Data.IORef++-- | Contextual tracing monad transformer type.+-- Tracing context c can be modified through this monad.+newtype TracerT c m a = TracerT (ReaderT (Action c m) m a)+ deriving(Functor,Monad,Applicative, MonadIO, MonadFix)++type Action c m = (c -> c) -> m ()++-- | Perform modification on the tracing context+update :: Monad m => (c -> c) -> TracerT c m ()+update f = TracerT $ ReaderT $ \tracer -> tracer f+{-# INLINE update #-}++-- | Change the tracing context. +zoom :: ASetter' c c' -> TracerT c' m a -> TracerT c m a+zoom l (TracerT m) = TracerT $ ReaderT $ \action ->+ runReaderT m (\updateFunc -> action (over l updateFunc))+{-# INLINE zoom #-}++instance MonadTrans (TracerT c) where+ lift = TracerT . lift+ {-# INLINE lift #-}++-- | Run the tracer monad with the specified update action.+runTracerT :: ((c -> c) -> m ()) -> TracerT c m a -> m a+runTracerT action (TracerT m) = runReaderT m action+{-# INLINE runTracerT #-}++-- | Run the tracer monad without tracing.+noTracerT :: Monad m => TracerT c m a -> m a+noTracerT = runTracerT (const (return ()))+{-# INLINE noTracerT #-}++-- | Run the tracer monad with update action implemented by 'IORef'+ioTracerT :: MonadIO m => c -> TracerT c m a -> m (a,c)+ioTracerT init m = do+ r <- liftIO $ newIORef init+ v <- runTracerT (liftIO . modifyIORef' r) m+ c <- liftIO $ readIORef r+ return (v,c)+{-# INLINE ioTracerT #-}++instance MonadReader r m => MonadReader r (TracerT c m) where+ ask = lift ask+ reader = lift . reader+ local f (TracerT m) = TracerT (ReaderT $ local f . runReaderT m)++deriving instance MonadWriter w m => MonadWriter w (TracerT c m) +deriving instance MonadError e m => MonadError e (TracerT c m) +deriving instance MonadState s m => MonadState s (TracerT c m) +deriving instance MonadRWS r w s m => MonadRWS r w s (TracerT c m)+deriving instance MonadCont m => MonadCont (TracerT c m)++
+ src/Data/PolyDict.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE MagicHash, MultiParamTypeClasses, TypeOperators, GeneralizedNewtypeDeriving #-}++-- |+-- Module : Data.PolyDict +-- Copyright : (c) Taku Terao, 2017 +-- License : BSD3 +-- Maintainer : autotaker@gmail.com +-- Stability : experimental +-- Portability : GHC+-- Type-safe, polymorphic dictionary. ++module Data.PolyDict( DictValue, Assoc, Dict, Key, lookup, insert, access, access', empty) where++import Prelude hiding(lookup)++import Data.Aeson+import Data.Hashable+import qualified Data.HashMap.Strict as H+import Data.Kind(Constraint)+import Data.List(intersperse)+import Data.Proxy+import Data.Text (pack)++import Data.Type.Equality++import GHC.TypeLits+import GHC.Prim(Proxy#, proxy#)+import GHC.OverloadedLabels++import Lens.Micro+import Unsafe.Coerce++-- | 'DictValue' is the constraint for values can be inserted into 'Dict'+type family DictValue v :: Constraint where+ DictValue v = (Eq v, Show v, ToJSON v)++-- | 'Assoc' n k defines the type of value associated with key k.+-- Parameter n defines the namespace for dictionary fields. For example:+-- +-- > data Log+-- > type instance Assoc Log "argments" = [String]+-- > type instance Assoc Log "count" = Int+-- Then 'Dict' Log is a dictionary type with (at least) two fields "arguments" and "count".+--+-- One can access the fields by using 'insert' and 'lookup'.+--+-- >>> insert #count 0 (empty :: Dict Log)+-- {"count": 0}+-- >>> lookup #count (insert #count 0 (empty :: Dict Log))+-- Just 0+--+-- Or by using lenses:+--+-- >>> import Lens.Micro+-- >>> (empty :: Dict Log) & (access #count ?~ 1) . (access #arguments ?~ ["a","b","c"])+-- {"arguments": ["a","b","c"], "count": 1}+--+type family Assoc n (k :: Symbol)++-- | A polymorphic, type-safe dictinary type where the parameter 'n' represents the namespace of dictionary fields.+newtype Dict n = Dict (H.HashMap (Hashed String) (Entry n))+ deriving(Eq)++instance ToJSON (Dict n) where+ toJSON (Dict dict) = + object [ pack (symbolVal' k) .= toJSON v | (Entry k v) <- H.elems dict ]++instance Eq (Entry n) where+ Entry k1 v1 == Entry k2 v2 =+ case f k1 k2 of+ Just Refl -> v1 == v2+ Nothing -> False+ where+ f :: (KnownSymbol k1, KnownSymbol k2) => Proxy# k1 -> Proxy# k2 -> Maybe (k1 :~: k2)+ f _ _ = sameSymbol Proxy Proxy+ {-# INLINE (==) #-}+++instance Show (Dict n) where+ showsPrec _ (Dict d) = + showChar '{' . + foldl1 (.) (intersperse (showString ", ") + [ shows (symbolVal' k) . showString ": " . shows v | (Entry k v) <- H.elems d ])+ . showChar '}'++data Entry n where+ Entry :: (KnownSymbol k, DictValue v, Assoc n k ~ v) => Proxy# k -> v -> Entry n++-- | The type of keys. With the OverloadedLabels extenstion, #foo is the key for field "foo"+-- +--+newtype Key (k :: Symbol) = Key (Proxy k)++instance k ~ k' => IsLabel k (Key k') where+ fromLabel _ = Key Proxy+ {-# INLINE fromLabel #-}++-- | Return the value associated with the key.+lookup :: (KnownSymbol k, DictValue v, Assoc n k ~ v) => Key k -> Dict n -> Maybe v+lookup key dict = dict ^. access key+{-# INLINE lookup #-}++-- | Insert the value at the specified key of the dictionary+insert :: (KnownSymbol k, DictValue v, Assoc n k ~ v) => Key k -> v -> Dict n -> Dict n+insert key value = access key ?~ value+{-# INLINE insert #-}++-- | Return the empty dictionary.+empty :: Dict n+empty = Dict H.empty+{-# INLINE empty #-}++-- | Give the lens accessing to the value associated with the key.+access :: forall n k v. (KnownSymbol k, DictValue v, Assoc n k ~ v) => Key k -> Lens' (Dict n) (Maybe v)+access key = lens getter setter+ where+ k = hashed (symbolVal key)+ getter (Dict dict) = case H.lookup k dict of+ Just (Entry _ v) -> Just (unsafeCoerce v)+ Nothing -> Nothing+ setter (Dict dict) Nothing = Dict $ H.delete k dict+ setter (Dict dict) (Just v) = Dict $ H.insert k (Entry (proxy# :: Proxy# k) v) dict+{-# INLINE access #-}++-- | Same as 'access' but requires the default value.+access' :: forall n k v. (KnownSymbol k, DictValue v, Assoc n k ~ v) => Key k -> v -> Lens' (Dict n) v+access' key def = access key . non def+{-# INLINE access' #-}+
+ src/JSON/Trace.hs view
@@ -0,0 +1,25 @@++{-|+Module : JSON.Trace+Copyright : (c) Taku Terao, 2017 +License : BSD3 +Maintainer : autotaker@gmail.com +Stability : experimental +Portability : GHC+type-safe json-structured tracing++-}++module JSON.Trace( dictTraceT + , module Data.PolyDict + , module Control.Monad.CTrace + )where+ +import Data.PolyDict +import Control.Monad.Trans+import Control.Monad.CTrace++-- | run the tracer monad whose tracing context is 'Dict'+dictTraceT :: (MonadIO m) => TracerT (Dict c) m a -> m (a, Dict c)+dictTraceT = ioTracerT empty+
+ test/PolyDictSpec.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedLabels, DataKinds,TypeFamilies #-}+module PolyDictSpec(spec) where++import Data.PolyDict(Assoc,Dict)+import qualified Data.PolyDict as D++import Test.Hspec.Core.Spec+import Test.Hspec.Expectations+import Lens.Micro++data Test+type instance Assoc Test "foo" = String+type instance Assoc Test "bar" = Bool+type instance Assoc Test "baz" = Dict Test++dict0 :: Dict Test+dict0 = D.empty++dict1 = dict0 & (D.access #foo ?~ "Foo")+ . (D.access #bar ?~ True )+ . (D.access #baz ?~ dict0)++specDict0 :: Spec+specDict0 = do+ describe "empty" $ do+ it "lookup always be Nothing" $ do+ D.lookup #foo dict0 `shouldBe` Nothing+ D.lookup #bar dict0 `shouldBe` Nothing+ D.lookup #baz dict0 `shouldBe` Nothing++specDict1 :: Spec+specDict1 = do+ describe "insert" $ do+ it "has" $ do+ D.lookup #foo dict1 `shouldBe` (Just "Foo")+ D.lookup #bar dict1 `shouldBe` (Just True)+ D.lookup #baz dict1 `shouldBe` (Just dict0)++spec :: Spec+spec = do+ specDict0+ specDict1
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}