@@ -11,13 +11,14 @@
1111{-# LANGUAGE TemplateHaskell #-}
1212{-# LANGUAGE TypeFamilies #-}
1313{-# LANGUAGE UndecidableInstances #-}
14+-- | This module is not meant to be imported directly and may contain
15+-- internal mechanisms that will change without notice.
1416module Katip.Core where
1517
1618-------------------------------------------------------------------------------
1719import Control.Applicative as A
1820import Control.AutoUpdate
1921import Control.Concurrent
20−import Control.Lens
2122import Control.Monad.Base
2223import Control.Monad.Catch
2324import Control.Monad.IO.Class
@@ -47,11 +48,20 @@ import Data.Time
4748import GHC.Generics hiding (to)
4849import Language.Haskell.TH
4950import qualified Language.Haskell.TH.Syntax as TH
51+import Lens.Micro
52+import Lens.Micro.TH
5053import Network.HostName
5154import System.Posix
5255-------------------------------------------------------------------------------
5356
5457
58+readMay :: Read a => String -> Maybe a
59+readMay s = case [x | (x,t) <- reads s, ("","") <- lex t] of
60+ [x] -> Just x
61+ [] -> Nothing -- no parse
62+ _ -> Nothing -- Ambiguous parse
63+
64+
5565-------------------------------------------------------------------------------
5666-- | Represents a heirarchy of namespaces going from general to
5767-- specific. For instance: ["processname", "subsystem"]. Note that
@@ -116,27 +126,25 @@ renderSeverity s = case s of
116126
117127
118128-------------------------------------------------------------------------------
119−severityText :: Prism' Text Severity
120−severityText = prism renderSeverity toSev
121− where
122− toSev "Debug" = Right DebugS
123− toSev "Info" = Right InfoS
124− toSev "Notice" = Right NoticeS
125− toSev "Warning" = Right WarningS
126− toSev "Error" = Right ErrorS
127− toSev "Critical" = Right CriticalS
128− toSev "Alert" = Right AlertS
129− toSev "Emergency" = Right EmergencyS
130− toSev x = Left x
129+textToSeverity :: Text -> Maybe Severity
130+textToSeverity "Debug" = Just DebugS
131+textToSeverity "Info" = Just InfoS
132+textToSeverity "Notice" = Just NoticeS
133+textToSeverity "Warning" = Just WarningS
134+textToSeverity "Error" = Just ErrorS
135+textToSeverity "Critical" = Just CriticalS
136+textToSeverity "Alert" = Just AlertS
137+textToSeverity "Emergency" = Just EmergencyS
138+textToSeverity _ = Nothing
131139
132−instance ToJSON Severity where
133− toJSON s = A.String (s ^. re severityText)
134140
141+instance ToJSON Severity where
142+ toJSON s = A.String (renderSeverity s)
135143
136144instance FromJSON Severity where
137145 parseJSON = A.withText "Severity" parseSeverity
138146 where
139− parseSeverity t = case t ^? severityText of
147+ parseSeverity t = case textToSeverity t of
140148 Just x -> return x
141149 Nothing -> fail $ "Invalid Severity " ++ toS t
142150
@@ -289,13 +297,12 @@ instance FromJSON a => FromJSON (Item a) where
289297 <*> (fmap getLocJs <$> o A..: "loc")
290298
291299
292−processIDText :: Prism' Text ProcessID
293−processIDText = prism fromProcessID toProcessID
294− where
295− fromProcessID = toS . show
296− toProcessID t = case toS t ^? _Show of
297− Just i -> Right i
298− Nothing -> Left t
300+processIDToText :: ProcessID -> Text
301+processIDToText = toS . show
302+
303+
304+textToProcessID :: Text -> Maybe ProcessID
305+textToProcessID = readMay . toS
299306
300307
301308newtype ProcessIDJs = ProcessIDJs {
@@ -304,13 +311,13 @@ newtype ProcessIDJs = ProcessIDJs {
304311
305312
306313instance ToJSON ProcessIDJs where
307− toJSON (ProcessIDJs p) = A.String (p ^. re processIDText)
314+ toJSON (ProcessIDJs p) = A.String (processIDToText p)
308315
309316
310317instance FromJSON ProcessIDJs where
311318 parseJSON = A.withText "ProcessID" parseProcessID
312319 where
313− parseProcessID t = case t ^? processIDText of
320+ parseProcessID t = case textToProcessID t of
314321 Just p -> return $ ProcessIDJs p
315322 Nothing -> fail $ "Invalid ProcessIDJs " ++ toS t
316323
@@ -515,7 +522,7 @@ registerScribe
515522 -> Scribe
516523 -> LogEnv
517524 -> LogEnv
518−registerScribe nm h = logEnvScribes . at nm .~ Just h
525+registerScribe nm h = logEnvScribes %~ M.insert nm h
519526
520527
521528-------------------------------------------------------------------------------
@@ -526,7 +533,7 @@ unregisterScribe
526533 -- ^ Name of the scribe
527534 -> LogEnv
528535 -> LogEnv
529−unregisterScribe nm = logEnvScribes . at nm .~ Nothing
536+unregisterScribe nm = logEnvScribes %~ M.delete nm
530537
531538
532539-------------------------------------------------------------------------------