Skip to content

Commit 6b55b9a

Browse files
layuslayus
authored
Merge #954: Main.hs: refactors
First, got rid of `opts` interspersing, and also trying a new way to write cascading maybe. It keeps vertical-align between equal expressions instead of the runaway indent of nested expressions that is all too common in Haskell, and disrupts the important patterns. Uses ad-hoc operators abundantly. Do you like it ?
1 parent 42b5489 commit 6b55b9a

File tree

1 file changed

+65
-65
lines changed

1 file changed

+65
-65
lines changed

‎main/Main.hs‎

Lines changed: 65 additions & 65 deletions
Original file line numberDiff line numberDiff line change
@@ -2,8 +2,9 @@
22
{-# LANGUAGE ScopedTypeVariables #-}
33
{-# LANGUAGE TypeFamilies #-}
44
{-# LANGUAGE ViewPatterns #-}
5+
{-# LANGUAGE RecordWildCards #-}
56

6-
module Main where
7+
module Main ( main ) where
78

89
import Nix.Utils
910
import Control.Comonad ( extract )
@@ -46,59 +47,61 @@ main =
4647
time <- getCurrentTime
4748
opts <- execParser $ nixOptionsInfo time
4849

49-
runWithBasicEffectsIO opts $ execContentsFilesOrRepl opts
50+
main' opts
5051

52+
main' :: Options -> IO ()
53+
main' (opts@Options{..}) = runWithBasicEffectsIO opts execContentsFilesOrRepl
5154
where
52-
execContentsFilesOrRepl opts =
53-
maybe
54-
(maybe
55-
(maybe
56-
(list
57-
(withNixContext mempty Repl.main) -- run REPL
58-
(\case
59-
["-"] -> handleResult opts mempty . parseNixTextLoc =<< liftIO Text.getContents
60-
_paths -> traverse_ (processFile opts) _paths
61-
)
62-
(filePaths opts)
63-
)
64-
(\ x ->
65-
-- We can start use Text as in the base case, requires changing FilePath -> Text
66-
traverse_ (processFile opts) . String.lines =<< liftIO
67-
(case x of
68-
"-" -> getContents -- get user input
69-
_path -> readFile _path
70-
)
71-
)
72-
(fromFile opts)
73-
)
74-
(handleResult opts mempty . parseNixTextLoc)
75-
(expression opts)
76-
)
77-
(\ path ->
78-
do
55+
execContentsFilesOrRepl =
56+
firstJust
57+
-- The `--read` option: load expression from a serialized file.
58+
[ readFrom <&> \path -> do
7959
let file = addExtension (dropExtension path) "nixc"
80-
process opts (pure file) =<< liftIO (readCache path)
81-
)
82-
(readFrom opts)
60+
process (Just file) =<< liftIO (readCache path)
8361

84-
processFile opts path =
85-
do
86-
eres <- parseNixFileLoc path
87-
handleResult opts (pure path) eres
62+
-- The `--expr` option: read expression from the argument string
63+
, expression <&> processText
64+
65+
-- The `--file` argument: read expressions from the files listed in the argument file
66+
, fromFile <&> \x ->
67+
-- We can start use Text as in the base case, requires changing FilePath -> Text
68+
traverse_ processFile . String.lines =<< liftIO
69+
(case x of
70+
"-" -> getContents
71+
fp -> readFile fp
72+
)
73+
]
74+
`orElse`
75+
-- The base case: read expressions from the files listed on the command line
76+
case filePaths of
77+
-- With no files, fall back to running the REPL
78+
[] -> withNixContext mempty Repl.main
79+
["-"] -> processText =<< liftIO Text.getContents
80+
_paths -> traverse_ processFile _paths
81+
82+
firstJust :: [Maybe a] -> Maybe a
83+
firstJust = asum
84+
85+
orElse :: Maybe a -> a -> a
86+
orElse = flip fromMaybe
87+
88+
processText text = handleResult Nothing $ parseNixTextLoc text
89+
90+
processFile path = handleResult (Just path) =<< parseNixFileLoc path
8891

89-
handleResult opts mpath =
92+
handleResult mpath =
9093
either
9194
(\ err ->
9295
bool
9396
errorWithoutStackTrace
9497
(liftIO . hPutStrLn stderr)
95-
(ignoreErrors opts)
98+
ignoreErrors
9699
$ "Parse failed: " <> show err
97100
)
98101

99102
(\ expr ->
100103
do
101-
when (check opts) $
104+
when check $
102105
do
103106
expr' <- liftIO (reduceExpr mpath expr)
104107
either
@@ -111,7 +114,7 @@ main =
111114
-- liftIO $ putStrLn $ runST $
112115
-- runLintM opts . renderSymbolic =<< lint opts expr
113116

114-
catch (process opts mpath expr) $
117+
catch (process mpath expr) $
115118
\case
116119
NixException frames ->
117120
errorWithoutStackTrace . show =<<
@@ -120,53 +123,50 @@ main =
120123
@(StdThunk (StandardT (StdIdT IO)))
121124
frames
122125

123-
when (repl opts) $
126+
when repl $
124127
withNixContext mempty $
125128
bool
126129
Repl.main
127130
(do
128131
val <- Nix.nixEvalExprLoc mpath expr
129132
Repl.main' $ pure val
130133
)
131-
(evaluate opts)
134+
evaluate
132135
)
133136

134-
process opts mpath expr
135-
| evaluate opts =
137+
process mpath expr
138+
| evaluate =
136139
if
137-
| tracing opts -> evaluateExpression mpath Nix.nixTracingEvalExprLoc printer expr
138-
| Just path <- reduce opts -> evaluateExpression mpath (reduction path) printer expr
139-
| not ( null (arg opts)
140-
&& null (argstr opts)
141-
) -> evaluateExpression mpath Nix.nixEvalExprLoc printer expr
142-
| otherwise -> processResult printer =<< Nix.nixEvalExprLoc mpath expr
143-
| xml opts = fail "Rendering expression trees to XML is not yet implemented"
144-
| json opts = fail "Rendering expression trees to JSON is not implemented"
145-
| verbose opts >= DebugInfo = liftIO $ putStr $ PS.ppShow $ stripAnnotation expr
146-
| cache opts
147-
, Just path <- mpath = liftIO $ writeCache (addExtension (dropExtension path) "nixc") expr
148-
| parseOnly opts = void $ liftIO $ Exc.evaluate $ Deep.force expr
149-
| otherwise =
140+
| tracing -> evaluateExpression mpath Nix.nixTracingEvalExprLoc printer expr
141+
| Just path <- reduce -> evaluateExpression mpath (reduction path) printer expr
142+
| not (null arg && null argstr) -> evaluateExpression mpath Nix.nixEvalExprLoc printer expr
143+
| otherwise -> processResult printer =<< Nix.nixEvalExprLoc mpath expr
144+
| xml = fail "Rendering expression trees to XML is not yet implemented"
145+
| json = fail "Rendering expression trees to JSON is not implemented"
146+
| verbose >= DebugInfo = liftIO $ putStr $ PS.ppShow $ stripAnnotation expr
147+
| cache , Just path <- mpath = liftIO $ writeCache (addExtension (dropExtension path) "nixc") expr
148+
| parseOnly = void $ liftIO $ Exc.evaluate $ Deep.force expr
149+
| otherwise =
150150
liftIO $
151151
renderIO
152152
stdout
153153
. layoutPretty (LayoutOptions $ AvailablePerLine 80 0.4)
154154
. prettyNix
155-
. stripAnnotation $
156-
expr
155+
. stripAnnotation
156+
$ expr
157157
where
158158
printer
159-
| finder opts = findAttrs <=< fromValue @(AttrSet (StdValue (StandardT (StdIdT IO))))
160-
| xml opts = liftIO . Text.putStrLn . stringIgnoreContext . toXML <=< normalForm
159+
| finder = findAttrs <=< fromValue @(AttrSet (StdValue (StandardT (StdIdT IO))))
160+
| xml = liftIO . Text.putStrLn . stringIgnoreContext . toXML <=< normalForm
161161
-- 2021-05-27: NOTE: With naive fix of the #941
162162
-- This is overall a naive printer implementation, as options should interact/respect one another.
163163
-- A nice question: "Should respect one another to what degree?": Go full combinator way, for which
164164
-- old Nix CLI is nototrious for (and that would mean to reimplement the old Nix CLI),
165165
-- OR: https://github.com/haskell-nix/hnix/issues/172 and have some sane standart/default behaviour for (most) keys.
166-
| json opts = liftIO . Text.putStrLn . stringIgnoreContext <=< nvalueToJSONNixString <=< normalForm
167-
| strict opts = liftIO . print . prettyNValue <=< normalForm
168-
| values opts = liftIO . print . prettyNValueProv <=< removeEffects
169-
| otherwise = liftIO . print . prettyNValue <=< removeEffects
166+
| json = liftIO . Text.putStrLn . stringIgnoreContext <=< nvalueToJSONNixString <=< normalForm
167+
| strict = liftIO . print . prettyNValue <=< normalForm
168+
| values = liftIO . print . prettyNValueProv <=< removeEffects
169+
| otherwise = liftIO . print . prettyNValue <=< removeEffects
170170
where
171171
findAttrs
172172
:: AttrSet (StdValue (StandardT (StdIdT IO)))

0 commit comments

Comments
 (0)