v1.1.1 :: Format and style

Author: ProggerX

app/Main.hs

@@ -4,39 +4,31 @@ import Control.DeepSeq (NFData, force)
 import Control.Exception (SomeException (..), catch, evaluate)
 import Control.Monad (forever, unless)
 import Lapse (runExpression', runExpressionIO)
+import Lapse.Modules (fileExists)
 import System.Environment (getArgs)
 import System.IO (
-  IOMode (ReadMode),
-  hClose,
   hFlush,
-  openFile,
   readFile',
   stdout,
  )
 
-fileExists :: FilePath -> IO Bool
-fileExists path =
-  do
-    handle <- openFile path ReadMode
-    hClose handle
-    return True
-    `catch` (\(SomeException _) -> return False)
-
 catchAny :: (NFData (m String)) => m String -> (SomeException -> IO (m String)) -> IO (m String)
 catchAny = catch . evaluate . force
 
 repl :: IO ()
-repl = forever $ do
-  putStr "(repl@lapse)>> "
-  hFlush stdout
-  expr <- getLine
-  res <- catchAny (runExpression' expr) (pure . pure . show)
-  putStrLn $ head res
+repl = forever $ read' >>= eval >>= print'
+ where
+  read' = do
+    putStr "(repl@lapse)>> "
+    hFlush stdout
+    getLine
+  eval expr = catchAny (runExpression' expr) (pure . pure . show)
+  print' = putStrLn . head
 
 executeFile :: String -> IO ()
 executeFile s = do
   exists <- fileExists s
-  unless exists (error $ "No such file: " ++ s)
+  unless exists $ error $ "No such file: " ++ s
   expr <- readFile' s
   _ <- runExpressionIO expr
   pure ()

lapse.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               lapse
-version:            1.1.0
+version:            1.1.1
 license:            GPL-3.0-only
 license-file:       LICENSE
 author:             ProggerX
@@ -24,30 +24,28 @@ library
   hs-source-dirs:
     src
   build-depends:
-    base ^>=4.18.2.1
+    base >=4.18.2.1 && <4.20
     , containers
     , mtl
-    , split
   default-language: GHC2021
 
 test-suite test
   type: exitcode-stdio-1.0
   hs-source-dirs: test
   main-is: Main.hs
   build-depends:
-    base ^>=4.18.2.1
+    base >=4.18.2.1 && <4.20
+    , lapse
     , tasty
     , tasty-hunit
-    , lapse
   default-language: GHC2021
 
 executable lapse
   import:           warnings
   main-is:          Main.hs
   build-depends:
-    base ^>=4.18.2.1
-    , lapse
-    , mtl
+    base >=4.18.2.1 && <4.20
     , deepseq
+    , lapse
   hs-source-dirs:   app
   default-language: GHC2021

src/Lapse.hs

@@ -26,7 +26,7 @@ runExpression :: (Monad m) => String -> m [Value m]
 runExpression = evalLapseM . mapM eval . parse
 
 runExpression' :: (Monad m) => String -> m String
-runExpression' = (pure . show) <=< runExpression
+runExpression' = pure . show <=< runExpression
 
 evalLapseMIO :: LapseM IO a -> IO a
 evalLapseMIO = (`evalStateT` 0) . (`evalStateT` initIOState)

src/Lapse/Modules.hs

@@ -1,6 +1,6 @@
 module Lapse.Modules where
 
-import Control.Exception (SomeException (..), catch)
+import Control.Exception (onException)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.State (evalStateT, runStateT)
 import Data.Map.Strict (Map, empty, fromList, (!?))
@@ -12,9 +12,8 @@ import Lapse.Scopes (addScope, addScopes)
 import Lapse.Types (Func, LapseM, Scope, Scopes, Value (..))
 import System.IO (
   IOMode (ReadMode),
-  hClose,
-  openFile,
   readFile',
+  withFile,
  )
 
 std :: (Monad m) => Scope m
@@ -69,11 +68,7 @@ builtins =
 
 fileExists :: FilePath -> IO Bool
 fileExists path =
-  do
-    handle <- openFile path ReadMode
-    hClose handle
-    return True
-    `catch` (\(SomeException _) -> return False)
+  withFile path ReadMode (\_ -> pure True) `onException` pure False
 
 getScopesIO' :: LapseM IO a -> IO (Scopes IO)
 getScopesIO' = (snd <$>) . (`evalStateT` 0) . (`runStateT` initIOState)

src/Lapse/Parser.hs

@@ -102,5 +102,5 @@ unList Nil = []
 unList (Pair h t) = h : unList t
 unList _ = error "Parse error in unList"
 
-parse :: (Monad m) => String -> [Value m]
+parse :: String -> [Value m]
 parse = unList . parse' [Nil] . tokenize

src/Lapse/Scopes.hs

@@ -1,28 +1,29 @@
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE LambdaCase #-}
 
 module Lapse.Scopes where
 
-import Control.Monad.State (get, gets, put)
+import Control.Monad.State (gets, modify)
 import Data.Map.Strict ((!?))
 import Data.Map.Strict qualified as Map
 import Lapse.Types (LapseM, Scope, Scopes, Value (..))
 
 newScope :: (Monad m) => LapseM m ()
-newScope = get >>= put . (Map.empty :)
+newScope = modify (Map.empty :)
 
 addScope :: (Monad m) => Scope m -> LapseM m ()
-addScope = (get >>=) . (put .) . (:)
+addScope = modify . (:)
 
 addScopes :: (Monad m) => Scopes m -> LapseM m ()
-addScopes = (get >>=) . (put .) . (++) . foldr (:) []
+addScopes = modify . (++)
 
 dropScope :: (Monad m) => LapseM m ()
-dropScope = get >>= put . tail
+dropScope = modify $ drop 1
 
 changeValue :: (Monad m) => String -> Value m -> LapseM m ()
 changeValue k v =
-  get >>= \case
-    (s : ss) -> put (Map.insert k v s : ss)
+  modify \case
+    (s : ss) -> Map.insert k v s : ss
     _ -> undefined
 
 getValue' :: String -> Scopes m -> Value m

test/Main.hs

@@ -1,7 +1,7 @@
 import Test.Tasty (defaultMain, testGroup)
 import Test.Tasty.HUnit (testCase, (@?=))
 
-import Data.Functor.Identity (Identity)
+import Data.Functor.Identity (Identity, runIdentity)
 import Lapse (evalLapseM, list, numList, runExpression')
 import Lapse.Operators
 import Lapse.Types (Func, LapseM, Value (..))
@@ -18,57 +18,61 @@ showTests =
   , (Pair (Number 5) Nil, "(5)")
   ]
 
-opTests :: [(LapseM Identity PValue, Identity PValue)]
+opTests :: [(LapseM Identity PValue, PValue)]
 opTests =
-  [ (ladd Nil, pure $ Number 0)
-  , (lmul Nil, pure $ Number 1)
-  , (ladd $ numList [1, 2, 3], pure $ Number 6)
-  , (lsub $ numList [5, 3], pure $ Number 2)
-  , (lmul $ numList [1, 2, 3, 4], pure $ Number 24)
-  , (ldiv $ numList [55, 11], pure $ Number 5)
-  , (lgrt $ numList [7, 2], pure $ Number 1)
-  , (lgrt $ numList [2, 7], pure Nil)
-  , (lgrt $ numList [5, 5], pure Nil)
-  , (llss $ numList [7, 2], pure Nil)
-  , (llss $ numList [2, 7], pure $ Number 1)
-  , (llss $ numList [5, 5], pure Nil)
-  , (leql $ numList [7, 2], pure Nil)
-  , (leql $ numList [2, 7], pure Nil)
-  , (leql $ numList [5, 5], pure $ Number 1)
+  [ (ladd Nil, Number 0)
+  , (lmul Nil, Number 1)
+  , (ladd $ numList [1, 2, 3], Number 6)
+  , (lsub $ numList [5, 3], Number 2)
+  , (lmul $ numList [1, 2, 3, 4], Number 24)
+  , (ldiv $ numList [55, 11], Number 5)
+  , (lgrt $ numList [7, 2], Number 1)
+  , (lgrt $ numList [2, 7], Nil)
+  , (lgrt $ numList [5, 5], Nil)
+  , (llss $ numList [7, 2], Nil)
+  , (llss $ numList [2, 7], Number 1)
+  , (llss $ numList [5, 5], Nil)
+  , (leql $ numList [7, 2], Nil)
+  , (leql $ numList [2, 7], Nil)
+  , (leql $ numList [5, 5], Number 1)
   ]
 
-condTests :: [(PValue, Identity PValue)]
+condTests :: [(PValue, PValue)]
 condTests =
-  [ (Nil, pure Nil)
-  , (list [list [Number 1, Number 2], list [Number 2, Number 3], list [Number 3, Number 4]], pure $ Number 2)
-  , (list [list [Nil, Number 2], list [Number 2, Number 3], list [Number 3, Number 4]], pure $ Number 3)
-  , (list [list [Nil, Number 2], list [Nil, Number 3], list [Number 3, Number 4]], pure $ Number 4)
-  , (list [list [Nil, Number 2], list [Nil, Number 3], list [Nil, Number 4]], pure Nil)
+  [ (Nil, Nil)
+  , (list [list [Number 1, Number 2], list [Number 2, Number 3], list [Number 3, Number 4]], Number 2)
+  , (list [list [Nil, Number 2], list [Number 2, Number 3], list [Number 3, Number 4]], Number 3)
+  , (list [list [Nil, Number 2], list [Nil, Number 3], list [Number 3, Number 4]], Number 4)
+  , (list [list [Nil, Number 2], list [Nil, Number 3], list [Nil, Number 4]], Nil)
   ]
 
-exprTests :: [(String, Identity String)]
+exprTests :: [(String, String)]
 exprTests =
-  [ ("(+ 1 2)", pure "[3]")
-  , ("(let ((a 1)) a)", pure "[1]")
-  , ("(let ((a 1) (b 2) (c 3)) '(,a ,b ,c ,(+ a b c)))", pure "[(1 2 3 6)]")
-  , ("(let ((a \"stra\") (b \"bstr\")) (concat a b))", pure "[\"strabstr\"]")
+  [ ("(+ 1 2)", "[3]")
+  , ("(let ((a 1)) a)", "[1]")
+  , ("(let ((a 1) (b 2) (c 3)) '(,a ,b ,c ,(+ a b c)))", "[(1 2 3 6)]")
+  , ("(let ((a \"stra\") (b \"bstr\")) (concat a b))", "[\"strabstr\"]")
   ]
 
 main :: IO ()
 main =
   defaultMain $
     testGroup
       "all"
-      [ testGroup
-          "show"
-          $ map (\(t, x) -> testCase "test" $ show t @?= x) showTests
+      [ testGroup "show" [testCase x $ show t @?= x | (t, x) <- showTests]
       , testGroup
           "operators"
-          $ map (\(t, x) -> testCase "test" $ evalLapseM t @?= x) opTests
+          [ testCase (show x) $ runIdentity (evalLapseM t) @?= x
+          | (t, x) <- opTests
+          ]
       , testGroup
           "cond"
-          $ map (\(t, x) -> testCase "test" $ (evalLapseM . cond) t @?= x) condTests
+          [ testCase (show x) $ (runIdentity . evalLapseM . cond) t @?= x
+          | (t, x) <- condTests
+          ]
       , testGroup
           "expression tests"
-          $ map (\(t, x) -> testCase "test" $ runExpression' t @?= x) exprTests
+          [ testCase x $ runIdentity (runExpression' t) @?= x
+          | (t, x) <- exprTests
+          ]
       ]