diff --git a/.gitignore b/.gitignore index 115fe25..48e7f44 100644 --- a/.gitignore +++ b/.gitignore @@ -8,14 +8,30 @@ *.old -dist - cabal-dev cabal.sandbox.config .cabal-sandbox .stack-work +dist +dist-* +cabal-dev +*.chi +*.chs.h +*.dyn_o +*.dyn_hi +.hpc +.hsenv +*.prof +*.aux +*.hp +*.eventlog +cabal.project.local +cabal.project.local~ +.HTF/ +.ghc.environment.* + bingtranslator bingtranslatorconc catch-mask @@ -81,3 +97,5 @@ sudoku5 threadperf1 threadperf2 timeout + + diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 index 0000000..7168371 --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1,67 @@ +# HLint configuration file +# https://github.com/ndmitchell/hlint +########################## + +# This file contains a template configuration file, which is typically +# placed as .hlint.yaml in the root of your project + + +# Specify additional command line arguments +# +# - arguments: [--color, --cpp-simple, -XQuasiQuotes] + + +# Control which extensions/flags/modules/functions can be used +# +# - extensions: +# - default: false # all extension are banned by default +# - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used +# - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module +# +# - flags: +# - {name: -w, within: []} # -w is allowed nowhere +# +# - modules: +# - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set' +# - {name: Control.Arrow, within: []} # Certain modules are banned entirely +# +# - functions: +# - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules + + +# Add custom hints for this project +# +# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar" +# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x} + + - ignore: {name: Eta reduce} + - ignore: {name: Use tuple-section} + - ignore: {name: Use newtype instead of data} + - ignore: {name: Redundant bracket} + - ignore: {name: Use camelCase} + - ignore: {name: Unused LANGUAGE pragma} + - ignore: {name: Use otherwise} + +# Turn on hints that are off by default +# +# Ban "module X(module X) where", to require a real export list +# - warn: {name: Use explicit module export list} +# +# Replace a $ b $ c with a . b $ c +# - group: {name: dollar, enabled: true} +# +# Generalise map to fmap, ++ to <> +# - group: {name: generalise, enabled: true} + + +# Ignore some builtin hints +# - ignore: {name: Use let} +# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules + + +# Define some custom infix operators +# - fixity: infixr 3 ~^#^~ + + +# To generate a suitable file for HLint do: +# $ hlint --default > .hlint.yaml diff --git a/.travis.yml b/.travis.yml index 3a2ef93..b1d1bd7 100644 --- a/.travis.yml +++ b/.travis.yml @@ -171,7 +171,7 @@ install: # Get the list of packages from the stack.yaml file PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') - cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES + cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options='-Wall -O0' --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES ;; esac set +ex @@ -184,7 +184,7 @@ script: stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps ;; cabal) - cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES + cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options='-Wall -O0' --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES ORIGDIR=$(pwd) for dir in $PACKAGES diff --git a/Stream.hs b/Stream.hs index 73004ca..aa511b0 100644 --- a/Stream.hs +++ b/Stream.hs @@ -92,6 +92,6 @@ streamFilter p instr = do tail <- new put_ outstr (Cons x tail) loop instr' tail - | otherwise -> do + | otherwise -> loop instr' outstr diff --git a/Sudoku.hs b/Sudoku.hs index a50a24e..65f9384 100644 --- a/Sudoku.hs +++ b/Sudoku.hs @@ -139,9 +139,9 @@ gridToString g = -- ["1 2 3 "," 4 5 6 ", ...] l3 = (sublist 3) l2 -- [["1 2 3 "," 4 5 6 "," 7 8 9 "],...] - l4 = (map (concat . intersperse "|")) l3 + l4 = (map (intercalate "|")) l3 -- ["1 2 3 | 4 5 6 | 7 8 9 ",...] - l5 = (concat . intersperse [line] . sublist 3) l4 + l5 = (intercalate [line] . sublist 3) l4 in unlines l5 where sublist n [] = [] sublist n xs = ys : sublist n zs diff --git a/TBQueue2.hs b/TBQueue2.hs index e91e5e9..7d42f87 100644 --- a/TBQueue2.hs +++ b/TBQueue2.hs @@ -34,7 +34,7 @@ writeTBQueue :: TBQueue a -> a -> STM () writeTBQueue (TBQueue rsize _read wsize write) a = do w <- readTVar wsize if (w /= 0) - then do writeTVar wsize (w - 1) + then writeTVar wsize (w - 1) else do r <- readTVar rsize if (r /= 0) diff --git a/TChan.hs b/TChan.hs index 425cdd2..da11993 100644 --- a/TChan.hs +++ b/TChan.hs @@ -59,7 +59,7 @@ isEmptyTChan (TChan read _write) = do -- >> main = do - c <- atomically $ newTChan + c <- atomically newTChan atomically $ writeTChan c 'a' atomically (readTChan c) >>= print atomically (isEmptyTChan c) >>= print diff --git a/chan3.hs b/chan3.hs index 0b47356..80ccdad 100644 --- a/chan3.hs +++ b/chan3.hs @@ -42,7 +42,7 @@ writeChan (Chan _ writeVar) val = do -- < IO a -readChan (Chan readVar _) = do +readChan (Chan readVar _) = modifyMVar readVar $ \stream -> do Item val tail <- readMVar stream return (tail, val) diff --git a/chanbench.hs b/chanbench.hs index ca45c40..3af74e5 100644 --- a/chanbench.hs +++ b/chanbench.hs @@ -63,7 +63,7 @@ runtest n test = do 1 -> do replicateM_ n $ writec c (1 :: Int) replicateM_ n $ readc c - 2 -> do + 2 -> do replicateM_ (n `quot` bufsiz) $ do replicateM_ bufsiz $ writec c (1 :: Int) replicateM_ bufsiz $ readc c diff --git a/chat.hs b/chat.hs index d023f15..81690e1 100644 --- a/chat.hs +++ b/chat.hs @@ -119,7 +119,7 @@ data Message = Notice String broadcast :: Server -> Message -> STM () broadcast Server{..} msg = do clientmap <- readTVar clients - mapM_ (\client -> sendMessage client msg) (Map.elems clientmap) + mapM_ (`sendMessage` msg) (Map.elems clientmap) -- >> -- <> -- < do writeTVar (clientKicked victim) $ Just ("by " ++ by) void $ sendToName server by (Notice $ "you kicked " ++ who) - Just (ClientRemote victim) -> do + Just (ClientRemote victim) -> sendRemote server (clientHome victim) (MsgKick who by) -- >> @@ -254,7 +254,7 @@ runClient serv@Server{..} client@LocalClient{..} = do msg <- readTChan clientSendChan return $ do continue <- handleMessage serv client msg - when continue $ server + when continue server -- >> -- < liftIO $ atomically $ do ok <- checkAddClient server (ClientRemote (RemoteClient name pid)) - when (not ok) $ + unless ok $ sendRemote server pid (MsgKick name "SYSTEM") MsgClientDisconnected name pid -> liftIO $ atomically $ do @@ -379,7 +379,7 @@ newServerInfo server@Server{..} rsvp pid remote_clients = do -- ToDo: also deal with conflicts writeTVar clients new_clientmap - when rsvp $ do + when rsvp $ sendRemote server pid (MsgServerInfo False spid (localClientNames new_clientmap)) @@ -404,7 +404,7 @@ master backend port = do mypid <- getSelfPid register "chatServer" mypid - forM_ peers $ \peer -> do + forM_ peers $ \peer -> whereisRemoteAsync peer "chatServer" chatServer (read port :: Int) diff --git a/distrib-chat/chat.hs b/distrib-chat/chat.hs index ac5c719..0a152cb 100644 --- a/distrib-chat/chat.hs +++ b/distrib-chat/chat.hs @@ -176,7 +176,7 @@ kick server@Server{..} who by = do Just (ClientLocal victim) -> do writeTVar (clientKicked victim) $ Just ("by " ++ by) void $ sendToName server by (Notice $ "you kicked " ++ who) - Just (ClientRemote victim) -> do + Just (ClientRemote victim) -> sendRemote server (clientHome victim) (MsgKick who by) -- >> @@ -249,7 +249,7 @@ runClient serv@Server{..} client@LocalClient{..} = do msg <- readTChan clientSendChan return $ do continue <- handleMessage serv client msg - when continue $ server + when continue server -- >> -- < do -- <3> ok <- checkAddClient server (ClientRemote (RemoteClient name pid)) - when (not ok) $ + unless ok $ sendRemote server pid (MsgKick name "SYSTEM") MsgClientDisconnected name pid -> do -- <4> diff --git a/distrib-db/db.hs b/distrib-db/db.hs index fe1c39c..f782737 100644 --- a/distrib-db/db.hs +++ b/distrib-db/db.hs @@ -25,7 +25,7 @@ master peers = do forever $ do l <- liftIO $ do putStr "key: "; hFlush stdout; getLine - when (not (null l)) $ do + unless (null l) $ do r <- get db l liftIO $ putStrLn ("response: " ++ show r) diff --git a/distrib-ping/ping-fail.hs b/distrib-ping/ping-fail.hs index f5a03d4..f12c351 100644 --- a/distrib-ping/ping-fail.hs +++ b/distrib-ping/ping-fail.hs @@ -56,5 +56,5 @@ master = do -- <
master) Main.__remoteTable +main = distribMain (const master) Main.__remoteTable -- >> diff --git a/distrib-ping/ping-tc-notify.hs b/distrib-ping/ping-tc-notify.hs index b1b87f0..4ef4abb 100644 --- a/distrib-ping/ping-tc-notify.hs +++ b/distrib-ping/ping-tc-notify.hs @@ -50,7 +50,7 @@ master peers = do return recvport let loop [] = return () - loop (port:ps) = do + loop (port:ps) = receiveWait [ match $ \(ProcessMonitorNotification ref pid reason) -> do say (show pid ++ " died: " ++ show reason) diff --git a/distrib-ping/ping.hs b/distrib-ping/ping.hs index 3a4385a..c822dd7 100644 --- a/distrib-ping/ping.hs +++ b/distrib-ping/ping.hs @@ -51,5 +51,5 @@ master = do -- <
master) Main.__remoteTable +main = distribMain (const master) Main.__remoteTable -- >> diff --git a/findpar.hs b/findpar.hs index ef4a3c9..c44355a 100644 --- a/findpar.hs +++ b/findpar.hs @@ -14,7 +14,7 @@ find :: String -> FilePath -> IO (Maybe FilePath) find s d = do fs <- getDirectoryContents d let fs' = sort $ filter (`notElem` [".",".."]) fs - if any (== s) fs' + if s `elem` fs' then return (Just (d s)) else do let ps = map (d ) fs' -- <1> diff --git a/findpar2.hs b/findpar2.hs index f1d8eae..33a366d 100644 --- a/findpar2.hs +++ b/findpar2.hs @@ -22,7 +22,7 @@ find :: NBSem -> String -> FilePath -> IO (Maybe FilePath) find sem s d = do fs <- getDirectoryContents d let fs' = sort $ filter (`notElem` [".",".."]) fs - if any (== s) fs' + if s `elem` fs' then return (Just (d s)) else do let ps = map (d ) fs' -- <1> diff --git a/findpar3.hs b/findpar3.hs index a70390a..a6ec0cc 100644 --- a/findpar3.hs +++ b/findpar3.hs @@ -25,7 +25,7 @@ find :: NBSem -> String -> FilePath -> IO (Maybe FilePath) find sem s d = do fs <- getDirectoryContents d let fs' = sort $ filter (`notElem` [".",".."]) fs - if any (== s) fs' + if s `elem` fs' then return (Just (d s)) else do let ps = map (d ) fs' -- <1> @@ -68,7 +68,7 @@ newNBSem i = do return (NBSem m) tryWaitNBSem :: NBSem -> IO Bool -tryWaitNBSem (NBSem m) = do +tryWaitNBSem (NBSem m) = atomicModifyIORef m $ \i -> if i == 0 then (i, False) diff --git a/findpar4.hs b/findpar4.hs index 9e44611..a156520 100644 --- a/findpar4.hs +++ b/findpar4.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} + import System.Directory import Control.Concurrent import System.FilePath @@ -24,7 +24,7 @@ find :: String -> FilePath -> ParIO (Maybe FilePath) find s d = do fs <- liftIO $ getDirectoryContents d let fs' = sort $ filter (`notElem` [".",".."]) fs - if any (== s) fs' + if s `elem` fs' then return (Just (d s)) else do let ps = map (d ) fs' diff --git a/findpar5.hs b/findpar5.hs index 556f2be..85e57ac 100644 --- a/findpar5.hs +++ b/findpar5.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} + import System.Directory import Control.Applicative import Control.Concurrent @@ -25,7 +25,7 @@ find :: String -> FilePath -> EParIO (Maybe FilePath) find s d = do fs <- liftIO $ getDirectoryContents d let fs' = sort $ filter (`notElem` [".",".."]) fs - if any (== s) fs' + if s `elem` fs' then return (Just (d s)) else do let ps = map (d ) fs' -- <1> @@ -84,7 +84,7 @@ instance MonadIO EParIO where liftIO io = E $ liftIO (try io) liftPar :: ParIO a -> EParIO a -liftPar p = E $ p >>= return . Right +liftPar p = E $ Right <$> p type EVar a = IVar (Either SomeException a) @@ -95,5 +95,5 @@ get :: EVar a -> EParIO a get evar = E $ P.get evar putResult :: EParIO a -> EVar a -> ParIO () -putResult (E e) var = do e >>= P.put_ var +putResult (E e) var = e >>= P.put_ var diff --git a/findseq.hs b/findseq.hs index 49035b2..6b49b2b 100644 --- a/findseq.hs +++ b/findseq.hs @@ -17,7 +17,7 @@ find :: String -> FilePath -> IO (Maybe FilePath) find s d = do fs <- getDirectoryContents d -- <1> let fs' = sort $ filter (`notElem` [".",".."]) fs -- <2> - if any (== s) fs' -- <3> + if s `elem` fs' -- <3> then return (Just (d s)) else loop fs' -- <4> where diff --git a/fwaccel-gpu.hs b/fwaccel-gpu.hs index 3c2362d..f5d652f 100644 --- a/fwaccel-gpu.hs +++ b/fwaccel-gpu.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, BangPatterns #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-} module Main ( main, test {-, maxDistances -} ) where @@ -55,7 +55,7 @@ inf = 999 -- >> testGraph :: Graph -testGraph = toAdjMatrix $ +testGraph = toAdjMatrix [[ 0, inf, inf, 13, inf, inf], [inf, 0, inf, inf, 4, 9], [ 11, inf, 0, inf, inf, inf], @@ -65,7 +65,7 @@ testGraph = toAdjMatrix $ -- correct result: expectedResult :: Graph -expectedResult = toAdjMatrix $ +expectedResult = toAdjMatrix [[0, 16, inf, 13, 20, 20], [19, 0, inf, 5, 4, 9], [11, 27, 0, 24, 31, 31], @@ -95,3 +95,4 @@ main = do A.fromIntegral i * constant (Prelude.fromIntegral n) in A.foldAll (+) (constant 0) (shortestPathsAcc n g))) + diff --git a/fwaccel.hs b/fwaccel.hs index 8bd3d99..d617c7c 100644 --- a/fwaccel.hs +++ b/fwaccel.hs @@ -55,7 +55,7 @@ inf = 999 -- >> testGraph :: Graph -testGraph = toAdjMatrix $ +testGraph = toAdjMatrix [[ 0, inf, inf, 13, inf, inf], [inf, 0, inf, inf, 4, 9], [ 11, inf, 0, inf, inf, inf], @@ -65,7 +65,7 @@ testGraph = toAdjMatrix $ -- correct result: expectedResult :: Graph -expectedResult = toAdjMatrix $ +expectedResult = toAdjMatrix [[0, 16, inf, 13, 20, 20], [19, 0, inf, 5, 4, 9], [11, 27, 0, 24, 31, 31], diff --git a/fwdense.hs b/fwdense.hs index 72645c6..843e047 100644 --- a/fwdense.hs +++ b/fwdense.hs @@ -50,7 +50,7 @@ inf = 999 -- >> testGraph :: Graph U -testGraph = toAdjMatrix $ +testGraph = toAdjMatrix [[ 0, inf, inf, 13, inf, inf], [inf, 0, inf, inf, 4, 9], [ 11, inf, 0, inf, inf, inf], @@ -60,7 +60,7 @@ testGraph = toAdjMatrix $ -- correct result: expectedResult :: Graph U -expectedResult = toAdjMatrix $ +expectedResult = toAdjMatrix [[0, 16, inf, 13, 20, 20], [19, 0, inf, 5, 4, 9], [11, 27, 0, 24, 31, 31], @@ -81,3 +81,4 @@ main = do let g = fromListUnboxed (Z:.n:.n) [0..n^(2::Int)-1] :: Graph U print (sumAllS (shortestPaths g)) + diff --git a/fwsparse/SparseGraph.hs b/fwsparse/SparseGraph.hs index f97fafd..777e435 100644 --- a/fwsparse/SparseGraph.hs +++ b/fwsparse/SparseGraph.hs @@ -77,6 +77,6 @@ chunk n xs = as : chunk n bs where (as,bs) = splitAt n xs checksum :: Graph -> Int -checksum m = sum (concat (map Map.elems (Map.elems m))) +checksum m = sum (concatMap Map.elems (Map.elems m)) diff --git a/index/index.hs b/index/index.hs index 8fa4755..f073187 100644 --- a/index/index.hs +++ b/index/index.hs @@ -70,7 +70,7 @@ main = do forever $ do putStr "search (^D to end): " eof <- isEOF - when eof $ exitWith ExitSuccess + when eof exitSuccess s <- B.getLine putStr "wait... " diff --git a/kmeans/kmeans.hs b/kmeans/kmeans.hs index 3295be6..2ae4d60 100644 --- a/kmeans/kmeans.hs +++ b/kmeans/kmeans.hs @@ -286,7 +286,7 @@ combine = Vector.zipWith addPointSums parSteps_strat :: Int -> [Cluster] -> [[Point]] -> [Cluster] parSteps_strat nclusters clusters pointss = makeNewClusters $ - foldr1 combine $ + foldr1 combine (map (assign nclusters clusters) pointss `using` parList rseq) -- >> @@ -295,7 +295,7 @@ steps_par :: Int -> [Cluster] -> [[Point]] -> [Cluster] steps_par nclusters clusters pointss = makeNewClusters $ foldl1' combine $ - (runPar $ Par.parMap (assign nclusters clusters) pointss) + runPar ( Par.parMap (assign nclusters clusters) pointss) -- < [Cluster] diff --git a/other/BingTranslate.hs b/other/BingTranslate.hs index 7f48202..73f735f 100644 --- a/other/BingTranslate.hs +++ b/other/BingTranslate.hs @@ -30,7 +30,7 @@ detectLanguage text = do translateText :: String -> String -> String -> IO String translateText text fromLang toLang = do r <- getURL (printf "%s&text=%s&from=%s&to=%s" translateUri text fromLang toLang) - return (concat (map getString (parseXML (UTF8.toString r)))) + return (concatMap getString (parseXML (UTF8.toString r))) ----------------------------------------------------------------------------- -- Hacky XML decoding diff --git a/other/game.hs b/other/game.hs index 0d3eadc..130cccf 100644 --- a/other/game.hs +++ b/other/game.hs @@ -17,7 +17,7 @@ main = do forkIO $ forever $ do score <- readMVar scorem - threadDelay (truncate (fromIntegral 1000000 * (0.9 ^ score))) + threadDelay (truncate (1000000 * (0.9 ^ score))) putMVar m Time forkIO $ forever (do c <- getChar; putMVar m (C c)) diff --git a/parinfer/Environment.hs b/parinfer/Environment.hs index 372e4bc..f9233f6 100644 --- a/parinfer/Environment.hs +++ b/parinfer/Environment.hs @@ -34,7 +34,7 @@ lookupEnv env x = fromJust (Map.lookup x (rep env)) domEnv :: Env -> [VarId] domEnv env = Map.keys (rep env) freeTVarEnv :: Env -> [TVarId] -freeTVarEnv env = concat (map freeTVarPoly (Map.elems (rep env))) +freeTVarEnv env = concatMap freeTVarPoly (Map.elems (rep env)) instance Show Env where showsPrec d = showsEnv showsEnv :: Shows Env diff --git a/parinfer/FiniteMap.hs b/parinfer/FiniteMap.hs index 5791afe..257c03a 100644 --- a/parinfer/FiniteMap.hs +++ b/parinfer/FiniteMap.hs @@ -37,4 +37,4 @@ ranFM (MkFM abs) = [ b | (a,b) <- abs ] disjointFM :: (Eq a) => FM a b -> FM a b -> Bool f `disjointFM` g = domFM f `disjoint` domFM g disjoint :: (Eq a) => [a] -> [a] -> Bool -xs `disjoint` ys = and [ not (x `elem` ys) | x <- xs ] +xs `disjoint` ys = and [ x `notElem` ys | x <- xs ] diff --git a/parinfer/Infer.hs b/parinfer/Infer.hs index 373659b..d8ff195 100644 --- a/parinfer/Infer.hs +++ b/parinfer/Infer.hs @@ -35,8 +35,8 @@ generaliseI aa tt = getSubI `thenI` (\s -> returnI (All xxs tt) ) freeTVarSubEnv :: Sub -> Env -> [TVarId] -freeTVarSubEnv s aa = concat (map (freeTVarMono . lookupSub s) - (freeTVarEnv aa)) +freeTVarSubEnv s aa = concatMap (freeTVarMono . lookupSub s) + (freeTVarEnv aa) inferTerm :: Env -> Term -> Infer MonoType inferTerm _ (Int _) = returnI intType @@ -44,8 +44,8 @@ inferTerm aa (Var x) = (x `elem` domEnv aa) `guardI` ( let ss = lookupEnv aa x in specialiseI ss `thenI` (\tt -> - substituteI tt `thenI` (\uu -> - returnI uu))) + substituteI tt `thenI` returnI + )) inferTerm aa (Abs x v) = freshI `thenI` (\xx -> inferTerm (extendLocal aa x xx) v `thenI` (\vv -> @@ -56,8 +56,8 @@ inferTerm aa (App t u) = inferTerm aa u `thenI` (\uu -> freshI `thenI` (\xx -> unifyI tt (uu `arrow` xx) `thenI` (\() -> - substituteI xx `thenI` (\vv -> - returnI vv))))) + substituteI xx `thenI` returnI + )))) inferTerm aa (Let x u v) = do ss <- inferRhs aa u inferTerm (extendGlobal aa x ss) v diff --git a/parinfer/StateX.hs b/parinfer/StateX.hs index 738ff35..7226673 100644 --- a/parinfer/StateX.hs +++ b/parinfer/StateX.hs @@ -14,4 +14,4 @@ thenSX thenX xSX kSX = MkSX (\s -> rep xSX s `thenX` (\(x,s') -> rep (kSX x) toSX eachX xX = MkSX (\s -> xX `eachX` (\x -> (x,s))) putSX returnX s' = MkSX (\s -> returnX ((), s')) getSX returnX = MkSX (\s -> returnX (s,s)) -useSX eachX s xSX = rep xSX s `eachX` (\(x,s') -> x) +useSX eachX s xSX = rep xSX s `eachX` fst diff --git a/parinfer/Substitution.hs b/parinfer/Substitution.hs index 8726e3e..6905199 100644 --- a/parinfer/Substitution.hs +++ b/parinfer/Substitution.hs @@ -39,7 +39,7 @@ unify t (TVar y) s = unifyTVar y t s unify (TCon j ts) (TCon k us) s = (j == k) `guardM` unifies ts us s unifies :: [MonoType] -> [MonoType] -> Sub -> Maybe Sub unifies [] [] s = returnM s -unifies (t:ts) (u:us) s = unify t u s `thenM` (\s' -> unifies ts us s') +unifies (t:ts) (u:us) s = unify t u s `thenM` unifies ts us unifyTVar :: TVarId -> MonoType -> Sub -> Maybe Sub unifyTVar x t s | x `elem` domSub s = unify (lookupSub s x) t s | TVar x == t = returnM s diff --git a/parinfer/Type.hs b/parinfer/Type.hs index 8653491..066726c 100644 --- a/parinfer/Type.hs +++ b/parinfer/Type.hs @@ -33,15 +33,15 @@ intType = TCon "Int" [] freeTVarMono :: MonoType -> [TVarId] freeTVarMono (TVar x) = [x] -freeTVarMono (TCon k ts) = concat (map freeTVarMono ts) +freeTVarMono (TCon k ts) = concatMap freeTVarMono ts freeTVarPoly :: PolyType -> [TVarId] freeTVarPoly (All xs t) = nub (freeTVarMono t) `minus` xs -- WDP: too bad deriving doesn't work instance Eq MonoType where - (TVar tv1) == (TVar tv2) = tv1 == tv2 + (TVar tv1) == (TVar tv2) = tv1 == tv2 (TCon tc1 args1) == (TCon tc2 args2) = tc1 == tc2 && (args1 == args2) - other1 == other2 = False + other1 == other2 = False -- end of too bad instance Show MonoType where diff --git a/rsa-pipeline.hs b/rsa-pipeline.hs index 608113f..fff4872 100644 --- a/rsa-pipeline.hs +++ b/rsa-pipeline.hs @@ -42,7 +42,7 @@ pipeline n e d b = runPar $ do s0 <- streamFromList (chunk (size n) b) s1 <- encrypt n e s0 s2 <- decrypt n d s1 - xs <- streamFold (\x y -> (y : x)) [] s2 + xs <- streamFold (flip (:)) [] s2 return (B.unlines (reverse xs)) -- >> @@ -66,7 +66,7 @@ chunk n xs = as : chunk n bs where (as,bs) = B.splitAt (fromIntegral n) xs size :: Integer -> Int -size n = (length (show n) * 47) `div` 100 -- log_128 10 = 0.4745 +size n = (length (show n) * 47) `div` 100 -- log_128 10 = 0.4745 ------- Constructing keys ------------------------- @@ -74,7 +74,7 @@ makeKeys :: Integer -> Integer -> (Integer, Integer, Integer) makeKeys r s = (p*q, d, invert ((p-1)*(q-1)) d) where p = nextPrime r q = nextPrime s - d = nextPrime (p+q+1) + d = nextPrime (p+q+1) nextPrime :: Integer -> Integer nextPrime a = head (filter prime [odd,odd+2..]) @@ -95,7 +95,7 @@ iter g v h w = iter h w (g `mod` h) (v - (g `div` h)*w) power :: Integer -> Integer -> Integer -> Integer power 0 m x = 1 power n m x | even n = sqr (power (n `div` 2) m x) `mod` m - | True = (x * power (n-1) m x) `mod` m + | True = (x * power (n-1) m x) `mod` m sqr :: Integer -> Integer sqr x = x * x diff --git a/rsa.hs b/rsa.hs index 57cf15d..db6f829 100644 --- a/rsa.hs +++ b/rsa.hs @@ -57,7 +57,7 @@ chunk n xs = as : chunk n bs where (as,bs) = B.splitAt (fromIntegral n) xs size :: Integer -> Int -size n = (length (show n) * 47) `div` 100 -- log_128 10 = 0.4745 +size n = (length (show n) * 47) `div` 100 -- log_128 10 = 0.4745 ------- Constructing keys ------------------------- @@ -65,7 +65,7 @@ makeKeys :: Integer -> Integer -> (Integer, Integer, Integer) makeKeys r s = (p*q, d, invert ((p-1)*(q-1)) d) where p = nextPrime r q = nextPrime s - d = nextPrime (p+q+1) + d = nextPrime (p+q+1) nextPrime :: Integer -> Integer nextPrime a = head (filter prime [odd,odd+2..]) @@ -86,7 +86,7 @@ iter g v h w = iter h w (g `mod` h) (v - (g `div` h)*w) power :: Integer -> Integer -> Integer -> Integer power 0 m x = 1 power n m x | even n = sqr (power (n `div` 2) m x) `mod` m - | True = (x * power (n-1) m x) `mod` m + | True = (x * power (n-1) m x) `mod` m sqr :: Integer -> Integer sqr x = x * x diff --git a/rsa1.hs b/rsa1.hs index 95b0ff9..99fc3ff 100644 --- a/rsa1.hs +++ b/rsa1.hs @@ -59,7 +59,7 @@ chunk n xs = as : chunk n bs where (as,bs) = B.splitAt (fromIntegral n) xs size :: Integer -> Int -size n = (length (show n) * 47) `div` 100 -- log_128 10 = 0.4745 +size n = (length (show n) * 47) `div` 100 -- log_128 10 = 0.4745 ------- Constructing keys ------------------------- @@ -67,7 +67,7 @@ makeKeys :: Integer -> Integer -> (Integer, Integer, Integer) makeKeys r s = (p*q, d, invert ((p-1)*(q-1)) d) where p = nextPrime r q = nextPrime s - d = nextPrime (p+q+1) + d = nextPrime (p+q+1) nextPrime :: Integer -> Integer nextPrime a = head (filter prime [odd,odd+2..]) @@ -88,7 +88,7 @@ iter g v h w = iter h w (g `mod` h) (v - (g `div` h)*w) power :: Integer -> Integer -> Integer -> Integer power 0 m x = 1 power n m x | even n = sqr (power (n `div` 2) m x) `mod` m - | True = (x * power (n-1) m x) `mod` m + | True = (x * power (n-1) m x) `mod` m sqr :: Integer -> Integer sqr x = x * x diff --git a/rsa2.hs b/rsa2.hs index fd1dd29..ae026ae 100644 --- a/rsa2.hs +++ b/rsa2.hs @@ -59,7 +59,7 @@ chunk n xs = as : chunk n bs where (as,bs) = B.splitAt (fromIntegral n) xs size :: Integer -> Int -size n = (length (show n) * 47) `div` 100 -- log_128 10 = 0.4745 +size n = (length (show n) * 47) `div` 100 -- log_128 10 = 0.4745 ------- Constructing keys ------------------------- @@ -67,7 +67,7 @@ makeKeys :: Integer -> Integer -> (Integer, Integer, Integer) makeKeys r s = (p*q, d, invert ((p-1)*(q-1)) d) where p = nextPrime r q = nextPrime s - d = nextPrime (p+q+1) + d = nextPrime (p+q+1) nextPrime :: Integer -> Integer nextPrime a = head (filter prime [odd,odd+2..]) @@ -88,7 +88,7 @@ iter g v h w = iter h w (g `mod` h) (v - (g `div` h)*w) power :: Integer -> Integer -> Integer -> Integer power 0 m x = 1 power n m x | even n = sqr (power (n `div` 2) m x) `mod` m - | True = (x * power (n-1) m x) `mod` m + | True = (x * power (n-1) m x) `mod` m sqr :: Integer -> Integer sqr x = x * x diff --git a/server.hs b/server.hs index 56413c1..76902d0 100644 --- a/server.hs +++ b/server.hs @@ -30,6 +30,6 @@ talk h = do if line == "end" -- <4> then hPutStrLn h ("Thank you for using the " ++ -- <5> "Haskell doubling service.") - else do hPutStrLn h (show (2 * (read line :: Integer))) -- <6> + else do hPrint h (2 * (read line :: Integer)) -- <6> loop -- <7> -- >> diff --git a/server2.hs b/server2.hs index 16f1e5c..4fdaf06 100644 --- a/server2.hs +++ b/server2.hs @@ -45,15 +45,14 @@ server h factor c = do hPrintf h "Current factor: %d\n" f -- <2> loop f -- <3> where - loop f = do - action <- atomically $ do -- <4> + loop f = join + (atomically $ do -- <4> f' <- readTVar factor -- <5> if (f /= f') -- <6> then return (newfactor f') -- <7> else do l <- readTChan c -- <8> - return (command f l) -- <9> - action + return (command f l)) -- <9> newfactor f = do -- <10> hPrintf h "new factor: %d\n" f @@ -68,7 +67,7 @@ server h factor c = do atomically $ writeTVar factor (read s :: Integer) -- <13> loop f line -> do - hPutStrLn h (show (f * (read line :: Integer))) + hPrint h (f * (read line :: Integer)) loop f -- >> diff --git a/sudoku-par1.hs b/sudoku-par1.hs index 444bf77..70514dc 100644 --- a/sudoku-par1.hs +++ b/sudoku-par1.hs @@ -6,5 +6,5 @@ import Data.Maybe main :: IO () main = do [f] <- getArgs - grids <- fmap lines $ readFile f + grids <- lines <$> readFile f print (length (filter isJust (map solve grids))) diff --git a/sudoku-par2.hs b/sudoku-par2.hs index db00a9f..a9b79f1 100644 --- a/sudoku-par2.hs +++ b/sudoku-par2.hs @@ -7,7 +7,7 @@ import Control.Monad.Par.Scheds.Trace main :: IO () main = do [f] <- getArgs - grids <- fmap lines $ readFile f + grids <- lines <$> readFile f let (as,bs) = splitAt (length grids `div` 2) grids diff --git a/sudoku-par3.hs b/sudoku-par3.hs index 6033ee0..05a8def 100644 --- a/sudoku-par3.hs +++ b/sudoku-par3.hs @@ -7,5 +7,5 @@ import Control.Monad.Par main :: IO () main = do [f] <- getArgs - grids <- fmap lines $ readFile f + grids <- lines <$> readFile f print (length (filter isJust (runPar $ parMap solve grids))) diff --git a/sudoku-par4.hs b/sudoku-par4.hs index 71e3f3f..73ace3d 100644 --- a/sudoku-par4.hs +++ b/sudoku-par4.hs @@ -8,11 +8,11 @@ import Control.DeepSeq main :: IO () main = do [f,n] <- getArgs - grids <- fmap lines $ readFile f + grids <- lines <$> readFile f print (length (filter isJust (runPar $ parMapChunk (read n) solve grids))) parMapChunk :: NFData b => Int -> (a -> b) -> [a] -> Par [b] -parMapChunk n f xs = fmap concat $ parMap (map f) (chunk n xs) +parMapChunk n f xs = concat <$> parMap (map f) (chunk n xs) chunk :: Int -> [a] -> [[a]] chunk _ [] = [] diff --git a/timeout.hs b/timeout.hs index c4fcc30..9f0c856 100644 --- a/timeout.hs +++ b/timeout.hs @@ -32,4 +32,4 @@ timeout t m (\_ -> fmap Just m)) -- <9> -- >> -main = (timeout 200000 $ timeout 100000 $ timeout 300000 $ threadDelay 1000000) >>= print +main = timeout 200000 (timeout 100000 $ timeout 300000 $ threadDelay 1000000) >>= print diff --git a/timeout2.hs b/timeout2.hs index e7a6b62..b61c3e6 100644 --- a/timeout2.hs +++ b/timeout2.hs @@ -17,4 +17,4 @@ timeout n m Right a -> return (Just a) -- >> -main = (timeout 200000 $ timeout 100000 $ timeout 300000 $ threadDelay 1000000) >>= print +main = timeout 200000 (timeout 100000 $ timeout 300000 $ threadDelay 1000000) >>= print diff --git a/timetable1.hs b/timetable1.hs index 2f4d539..2cd2014 100644 --- a/timetable1.hs +++ b/timetable1.hs @@ -49,7 +49,7 @@ search finished refine emptysoln = generate emptysoln where generate partial | Just soln <- finished partial = [soln] - | otherwise = concat (map generate (refine partial)) + | otherwise = concatMap generate (refine partial) -- >> -- ---------------------------------------------------------------------------- diff --git a/timetable2.hs b/timetable2.hs index 1e8215a..bf24ec4 100644 --- a/timetable2.hs +++ b/timetable2.hs @@ -50,7 +50,7 @@ search finished refine emptysoln = generate emptysoln where generate partial | Just soln <- finished partial = [soln] - | otherwise = concat (map generate (refine partial)) + | otherwise = concatMap generate (refine partial) -- >> -- <> -- <