Skip to content

Navigation Menu

Sign in
Appearance settings

Search code, repositories, users, issues, pull requests...

Provide feedback

We read every piece of feedback, and take your input very seriously.

Saved searches

Use saved searches to filter your results more quickly
Sign up
Appearance settings

Commit 7023b23

Browse files
piq9117Gitea
piq9117
authored and
Gitea
committed
logging (#11)
1 parent e47ef5e commit 7023b23

File tree

7 files changed

+154
-39
lines changed

7 files changed

+154
-39
lines changed

‎shell.nix‎

Lines changed: 6 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -5,8 +5,9 @@ let
55
inherit (nixpkgs) pkgs;
66

77
f = { mkDerivation, ansi-terminal, base, bytestring
8-
, classy-prelude, errors, file-embed, mtl, optparse-applicative
9-
, stdenv, template-haskell, text, transformers, turtle
8+
, classy-prelude, errors, file-embed, microlens, microlens-th, mtl
9+
, optparse-applicative, stdenv, template-haskell, text
10+
, transformers, turtle
1011
}:
1112
mkDerivation {
1213
pname = "umu-react-basic";
@@ -15,8 +16,9 @@ let
1516
isLibrary = true;
1617
isExecutable = true;
1718
libraryHaskellDepends = [
18-
ansi-terminal base bytestring classy-prelude errors file-embed mtl
19-
optparse-applicative template-haskell text transformers turtle
19+
ansi-terminal base bytestring classy-prelude errors file-embed
20+
microlens microlens-th mtl optparse-applicative template-haskell
21+
text transformers turtle
2022
];
2123
executableHaskellDepends = [ base classy-prelude ];
2224
license = "unknown";

‎src/UmuReactBasic.hs‎

Lines changed: 27 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -3,8 +3,11 @@ module UmuReactBasic where
33

44
import Import
55
import Options.Applicative
6+
import UmuReactBasic.Capability.LogMessage
67
import UmuReactBasic.Capability.ManageCommand
8+
import UmuReactBasic.Log
79
import UmuReactBasic.Parser
10+
import Lens.Micro
811

912
newtype AppM m a
1013
= AppM
@@ -26,6 +29,30 @@ startApp = do
2629
instance MonadIO m => ManageCommand ( AppM m ) where
2730
generateProject = generateProj
2831

32+
instance MonadIO m => LogMessage ( AppM m ) where
33+
logMessage l = case l ^. logReason of
34+
Info -> do
35+
mkTerminalLog
36+
( l ^. logMsg . logMessageText )
37+
Info
38+
( l ^. logMsg . logMessageHeader )
39+
Debug -> do
40+
mkTerminalLog
41+
( l ^. logMsg . logMessageText )
42+
Debug
43+
( l ^. logMsg . logMessageHeader )
44+
Error -> do
45+
mkTerminalLog
46+
( l ^. logMsg . logMessageText )
47+
Error
48+
( l ^. logMsg . logMessageHeader )
49+
Warn -> do
50+
mkTerminalLog
51+
( l ^. logMsg . logMessageText )
52+
Warn
53+
( l ^. logMsg . logMessageHeader )
54+
55+
2956
runAppM :: MonadIO m => AppM m a -> m a
3057
runAppM app = unAppM app
3158

Lines changed: 22 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,22 @@
1+
module UmuReactBasic.Capability.LogMessage where
2+
3+
import Import hiding (log)
4+
import UmuReactBasic.Log
5+
6+
class Monad m => LogMessage m where
7+
logMessage :: Log -> m ()
8+
9+
log :: ( MonadIO m, LogMessage m ) => LogReason -> Text -> m ()
10+
log reason = logMessage <=< mkLog reason
11+
12+
logInfo :: ( MonadIO m, LogMessage m ) => Text -> m ()
13+
logInfo = log Info
14+
15+
logWarn :: ( MonadIO m, LogMessage m ) => Text -> m ()
16+
logWarn = log Warn
17+
18+
logDebug :: ( MonadIO m, LogMessage m ) => Text -> m ()
19+
logDebug = log Debug
20+
21+
logError :: ( MonadIO m, LogMessage m ) => Text -> m ()
22+
logError = log Error

‎src/UmuReactBasic/Capability/ManageCommand.hs‎

Lines changed: 27 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -5,7 +5,8 @@ module UmuReactBasic.Capability.ManageCommand
55

66
import Import
77
import qualified Turtle
8-
import qualified Turtle.Prelude as TP
8+
import qualified Turtle.Prelude as TP
9+
import UmuReactBasic.Capability.LogMessage
910
import UmuReactBasic.Templates
1011
import UmuReactBasic.Util
1112

@@ -18,7 +19,7 @@ instance ManageCommand IO where
1819
-- ManageCommand constraint is just so this function can only be used if
1920
-- there's an instance of ManageCommand
2021
generateProj
21-
:: ( MonadIO m, ManageCommand m )
22+
:: ( MonadIO m, ManageCommand m, LogMessagem )
2223
=> Maybe Text
2324
-> m ()
2425
generateProj mLoc = do
@@ -35,67 +36,67 @@ generateProj mLoc = do
3536
writeMakefile mLoc
3637
writePackageJsonFile mLoc
3738

38-
writeSrcDir :: MonadIO m => Maybe Text -> m ()
39+
writeSrcDir :: ( MonadIO m, LogMessagem ) => Maybe Text -> m ()
3940
writeSrcDir mLoc = do
4041
liftIO $ TP.mkdir ( Turtle.fromText $ mkPathName mLoc "src" )
41-
mkMessage "Generating src..."
42+
logInfo "Generating src..."
4243

43-
writeHtmlDir :: MonadIO m => Maybe Text -> m ()
44+
writeHtmlDir :: ( MonadIO m, LogMessagem ) => Maybe Text -> m ()
4445
writeHtmlDir mLoc = do
4546
liftIO $ TP.mkdir ( Turtle.fromText $ mkPathName mLoc "html" )
46-
mkMessage "Generating html..."
47+
logInfo "Generating html..."
4748

48-
writeIndexHtml :: MonadIO m => Maybe Text -> m ()
49+
writeIndexHtml :: ( MonadIO m, LogMessagem ) => Maybe Text -> m ()
4950
writeIndexHtml mLoc = do
5051
liftIO $ TP.writeTextFile
5152
( Turtle.fromText $ mkPathName mLoc "html/index.html" ) indexHtmlFile
52-
mkMessage "Generating html/index.html..."
53+
logInfo "Generating html/index.html..."
5354

54-
writeSrcMainFile :: MonadIO m => Maybe Text -> m ()
55+
writeSrcMainFile :: ( MonadIO m, LogMessagem ) => Maybe Text -> m ()
5556
writeSrcMainFile mLoc = do
5657
liftIO $ TP.writeTextFile
5758
( Turtle.fromText $ mkPathName mLoc "/src/Main.purs" ) srcMainFile
58-
mkMessage "Generating src/Main.purs..."
59+
logInfo "Generating src/Main.purs..."
5960

60-
writeComponentDir :: MonadIO m => Maybe Text -> m ()
61+
writeComponentDir :: ( MonadIO m, LogMessagem ) => Maybe Text -> m ()
6162
writeComponentDir mLoc = do
6263
liftIO $ TP.mkdir ( Turtle.fromText $ mkPathName mLoc "src/Component" )
63-
mkMessage "Generating Component..."
64+
logInfo "Generating Component..."
6465

65-
writeTitleComponentFile :: MonadIO m => Maybe Text -> m ()
66+
writeTitleComponentFile :: ( MonadIO m, LogMessagem ) => Maybe Text -> m ()
6667
writeTitleComponentFile mLoc = do
6768
liftIO $ TP.writeTextFile
6869
( Turtle.fromText $ mkPathName mLoc "src/Component/Title.purs" ) titleComponentFile
69-
mkMessage "Generating src/Component/Title.purs..."
70+
logInfo "Generating src/Component/Title.purs..."
7071

71-
writeSpagoDhallFile :: MonadIO m => Maybe Text -> m ()
72+
writeSpagoDhallFile :: ( MonadIO m, LogMessagem ) => Maybe Text -> m ()
7273
writeSpagoDhallFile mLoc = do
7374
liftIO $ TP.writeTextFile
7475
( Turtle.fromText $ mkPathName mLoc "spago.dhall" ) spagoDhallFile
75-
mkMessage "Generating spago.dhall..."
76+
logInfo "Generating spago.dhall..."
7677

77-
writePackagesDhallFile :: MonadIO m => Maybe Text -> m ()
78+
writePackagesDhallFile :: ( MonadIO m, LogMessagem ) => Maybe Text -> m ()
7879
writePackagesDhallFile mLoc = do
7980
liftIO $
8081
TP.writeTextFile ( Turtle.fromText $ mkPathName mLoc "packages.dhall" ) packagesDhallFile
81-
mkMessage "Generating packages.dhall..."
82+
logInfo "Generating packages.dhall..."
8283

83-
writeTestDir :: MonadIO m => Maybe Text -> m ()
84+
writeTestDir :: ( MonadIO m, LogMessagem ) => Maybe Text -> m ()
8485
writeTestDir mLoc = do
8586
liftIO $ TP.mkdir ( Turtle.fromText $ mkPathName mLoc "test" )
86-
mkMessage "Generating test..."
87+
logInfo "Generating test..."
8788

88-
writeTestMainFile :: MonadIO m => Maybe Text -> m ()
89+
writeTestMainFile :: ( MonadIO m, LogMessagem ) => Maybe Text -> m ()
8990
writeTestMainFile mLoc = do
9091
liftIO $ TP.writeTextFile ( Turtle.fromText $ mkPathName mLoc "test/Main.purs" ) testMainFile
91-
mkMessage "Generating test/Main.purs..."
92+
logInfo "Generating test/Main.purs..."
9293

93-
writeMakefile :: MonadIO m => Maybe Text -> m ()
94+
writeMakefile :: ( MonadIO m, LogMessagem ) => Maybe Text -> m ()
9495
writeMakefile mLoc = do
9596
liftIO $ TP.writeTextFile ( Turtle.fromText $ mkPathName mLoc "Makefile" ) makeFile
96-
mkMessage "Generating Makefile..."
97+
logInfo "Generating Makefile..."
9798

98-
writePackageJsonFile :: MonadIO m => Maybe Text -> m ()
99+
writePackageJsonFile :: ( MonadIO m, LogMessagem ) => Maybe Text -> m ()
99100
writePackageJsonFile mLoc = do
100101
liftIO $ TP.writeTextFile ( Turtle.fromText $ mkPathName mLoc "package.json" ) packageJsonFile
101-
mkMessage "Generating package.json..."
102+
logInfo "Generating package.json..."

‎src/UmuReactBasic/Log.hs‎

Lines changed: 68 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,68 @@
1+
{-# LANGUAGE RecordWildCards #-}
2+
{-# LANGUAGE TemplateHaskell #-}
3+
module UmuReactBasic.Log
4+
( LogReason (..)
5+
, Log
6+
, mkLog
7+
, logMessageText
8+
, logMessageHeader
9+
, logReason
10+
, logMsg
11+
, mkTerminalLog
12+
) where
13+
14+
import Import
15+
import Lens.Micro.TH
16+
import System.Console.ANSI as ANSI
17+
18+
data LogReason
19+
= Debug
20+
| Info
21+
| Warn
22+
| Error
23+
deriving ( Eq, Show )
24+
25+
data LogMessage = LogMessage
26+
{ _logMessageText :: Text
27+
, _logMessageHeader :: Text
28+
} deriving ( Show )
29+
30+
makeLenses ''LogMessage
31+
32+
data Log = Log
33+
{ _logReason :: LogReason
34+
, _logMsg :: LogMessage
35+
} deriving ( Show )
36+
37+
makeLenses ''Log
38+
39+
mkLog :: MonadIO m => LogReason -> Text -> m Log
40+
mkLog reason msg = do
41+
pure $ Log
42+
{ _logReason = reason
43+
, _logMsg = LogMessage
44+
{ _logMessageText = msg
45+
, _logMessageHeader = mkHeader reason
46+
}
47+
}
48+
where
49+
mkHeader :: LogReason -> Text
50+
mkHeader res = case res of
51+
Debug -> "[DEBUG]: "
52+
Info -> "[INFO]: "
53+
Warn -> "[WARN]: "
54+
Error -> "[ERROR]: "
55+
56+
mkTerminalLog :: MonadIO m => Text -> LogReason -> Text -> m ()
57+
mkTerminalLog msg reason logHeader = do
58+
liftIO $ ANSI.setSGR [ ANSI.SetColor ANSI.Foreground ANSI.Dull ( reasonToColor reason )]
59+
putStr logHeader
60+
liftIO $ ANSI.setSGR []
61+
putStrLn msg
62+
where
63+
reasonToColor :: LogReason -> Color
64+
reasonToColor lr = case lr of
65+
Info -> ANSI.Green
66+
Debug -> ANSI.Blue
67+
Error -> ANSI.Red
68+
Warn -> ANSI.Yellow

‎src/UmuReactBasic/Util.hs‎

Lines changed: 0 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -1,18 +1,9 @@
11
module UmuReactBasic.Util
22
( mkPathName
3-
, mkMessage
43
) where
54

65
import Import
7-
import System.Console.ANSI as ANSI
86

97
mkPathName :: Maybe Text -> Text -> Text
108
mkPathName mLoc fileName =
119
maybe "./" (\loc -> "./" <> loc <> "/") mLoc <> fileName
12-
13-
mkMessage :: MonadIO m => Text -> m ()
14-
mkMessage msg = do
15-
liftIO $ ANSI.setSGR [ ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Green ]
16-
putStr "[INFO]: "
17-
liftIO $ ANSI.setSGR []
18-
putStrLn msg

‎umu-react-basic.cabal‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -24,8 +24,10 @@ library
2424
, UmuReactBasic.Util
2525
, UmuReactBasic.Parser
2626
, UmuReactBasic.Capability.ManageCommand
27+
, UmuReactBasic.Capability.LogMessage
2728
, UmuReactBasic.TH
2829
, UmuReactBasic.Templates
30+
, UmuReactBasic.Log
2931
build-depends: base >=4.12 && <4.14
3032
, classy-prelude
3133
, turtle
@@ -38,6 +40,8 @@ library
3840
, ansi-terminal
3941
, template-haskell
4042
, file-embed
43+
, microlens
44+
, microlens-th
4145
hs-source-dirs: src
4246
default-language: Haskell2010
4347
default-extensions: NoImplicitPrelude

0 commit comments

Comments
(0)

AltStyle によって変換されたページ (->オリジナル) /