Add compact lambdas

Author: ProggerX

lapse.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               lapse
-version:            2.0.2
+version:            2.0.4
 license:            GPL-3.0-only
 license-file:       LICENSE
 author:             ProggerX

src/Lapse/Lambda.hs

@@ -1,10 +1,14 @@
+{-# LANGUAGE LambdaCase #-}
+
 module Lapse.Lambda where
 
 import Control.Monad ((<=<))
 import Control.Monad.State (get, gets, put)
+import Data.List (sort)
 import Data.Map.Strict (empty, fromList)
 import Lapse.Eval (eval)
 import Lapse.Operators (lset)
+import Lapse.Scopes (getValueM)
 import Lapse.Types (Func, LapseM, Scopes, Value (..))
 
 data UnList m = Proper [Value] | Improper ([Value], Value) | Single Value deriving (Show)
@@ -77,3 +81,18 @@ macro _ = error "Wrong macro expression"
 defmacro :: Func
 defmacro (Pair (Name fname) ls@(Pair _ (Pair _ Nil))) = macro ls >>= \x -> lset (Pair (Name fname) (Pair x Nil))
 defmacro _ = error "Wrong defmacro expression"
+
+findFree :: Value -> LapseM [String]
+findFree = \case
+  Name x ->
+    getValueM x >>= \case
+      Just _ -> pure []
+      Nothing -> pure [x]
+  Pair x y -> concat <$> sequence [findFree x, findFree y]
+  _ -> pure []
+
+compact :: Func
+compact v = do
+  freeVars <- sort <$> findFree v
+  let args = foldr (Pair . Name) Nil freeVars
+  Function <$> mkFunction args v

src/Lapse/Modules.hs

@@ -9,7 +9,7 @@ import Data.ByteString.Char8 qualified as BC
 import Data.FileEmbed (embedFileRelative)
 import Data.Map.Strict (Map, empty, fromList, (!?))
 import Lapse.Eval (eval)
-import Lapse.Lambda (define, defmacro, lambda, macro)
+import Lapse.Lambda (compact, define, defmacro, lambda, macro)
 import Lapse.Modules.FS qualified as FS
 import Lapse.Modules.Json qualified as Json
 import Lapse.Modules.Web qualified as Web
@@ -63,6 +63,7 @@ std =
     , ("float", Function lflt)
     , ("floor", Function lfloor)
     , ("throw", Function lthr)
+    , ("compact", Macros compact)
     ]
 
 io :: Scope

src/Lapse/Parser.hs

@@ -21,6 +21,12 @@ stringToken (c : cs) cur = case c of
       )
   _ -> stringToken cs (cur ++ [c])
 
+compactLambda :: String -> String -> (String, String)
+compactLambda [] _ = error "Tokenize error in compactLambda"
+compactLambda (c : cs) cur = case c of
+  '}' -> (('{' : cur) ++ ['}'], cs)
+  _ -> compactLambda cs (cur ++ [c])
+
 tokenize' :: String -> [String] -> String -> [String]
 tokenize' cur tokens (c : cs) = case c of
   '(' -> tokenize' "" ("(" : add' cur tokens) cs
@@ -32,6 +38,11 @@ tokenize' cur tokens (c : cs) = case c of
     new = stringToken cs ""
     newTokens = fst new : tokens
     newCs = snd new
+  '{' -> tokenize' "" newTokens newCs
+   where
+    new = compactLambda cs ""
+    newTokens = fst new : tokens
+    newCs = snd new
   _ ->
     if isSpace c
       then tokenize' "" (add' cur tokens) cs
@@ -67,6 +78,9 @@ endsWith = (==) . last
 isString :: String -> Bool
 isString t = (t `endsWith` '"') && (t `startsWith` '"')
 
+isCompactLambda :: String -> Bool
+isCompactLambda t = (t `endsWith` '}') && (t `startsWith` '{')
+
 trim :: String -> String
 trim = init . tail
 
@@ -75,6 +89,7 @@ parseToken t
   | all (\c -> isDigit c || c == '-') t && t /= "-" = Number $ read t
   | all (\c -> isDigit c || c == '-' || c == '.') t && t /= "-" && t /= "." = Float $ read t
   | isString t = String $ trim t
+  | isCompactLambda t = Pair (Name "compact") (head $ parse $ "(" <> trim t <> ")")
   | otherwise = Name t
 
 parse' :: [Value] -> [String] -> Value

src/Lapse/Scopes.hs

@@ -32,5 +32,14 @@ getValue' k (s : ss) = case s !? k of
   Just x -> x
 getValue' k [] = error $ "getValue: no such key: " ++ k ++ "!"
 
+getValueM' :: String -> Scopes -> Maybe Value
+getValueM' k (s : ss) = case s !? k of
+  Nothing -> getValueM' k ss
+  Just x -> Just x
+getValueM' _ [] = Nothing
+
 getValue :: String -> LapseM Value
 getValue = gets . getValue'
+
+getValueM :: String -> LapseM (Maybe Value)
+getValueM = gets . getValueM'