status: working, IO not yet implemented

src/Main.hs

@@ -0,0 +1,157 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+
+module Main (main) where
+
+import CombParse (Expr (..), Value (Id, Str), parseExpr, runParser, toComblang)
+import Data.Bifunctor (Bifunctor (bimap))
+import Data.Foldable (find)
+import Data.Maybe (fromMaybe)
+import State (State (..))
+import System.Console.Haskeline (InputT, defaultSettings, getInputLine, outputStrLn, runInputT)
+import Unicode.Char (isLowerCase)
+
+type Defs = [(String, (Expr, Int))]
+
+type Interpreted = State Defs
+
+builtins :: Defs
+builtins =
+  [ ("Q", (Var (Id "Q"), 1)),
+    ("L", (Comb (Var (Id "L")) (Comb (Param 0) (Param 1)), 2))
+  ]
+
+funsRepl :: [(String, Expr -> InputT IO (Maybe (Either String Expr)))]
+funsRepl =
+  let getInput (Var (Str line)) = Just . Right . Var . Str . fromMaybe "" <$> getInputLine line
+      getInput (Comb _ _) = pure Nothing
+      getInput (Op _ _) = pure Nothing
+      getInput v = pure $ Just $ Left $ "Expected Str input to getInput, got " ++ toComblang v ++ " instead"
+
+      sendOutput v@(Var (Str line)) = Just (Right v) <$ outputStrLn line
+      sendOutput (Comb _ _) = pure Nothing
+      sendOutput (Op _ _) = pure Nothing
+      sendOutput v = pure $ Just $ Left $ "Expected Str input to sendOutput, got " ++ toComblang v ++ " instead"
+   in [ ("getInput", getInput),
+        ("sendOutput", sendOutput)
+      ]
+
+libs :: [(String, Defs)]
+libs =
+  [ ( "SKI",
+      [ ("S", (Comb (Comb (Param 0) (Param 2)) (Comb (Param 1) (Param 2)), 3)),
+        ("K", (Param 0, 2)),
+        ("I", (Param 0, 1))
+      ]
+    ),
+    ( "BCKW",
+      [ ("B", (Comb (Param 0) (Comb (Param 1) (Param 2)), 3)),
+        ("C", (Comb (Comb (Param 0) (Param 2)) (Param 1), 3)),
+        ("K", (Param 0, 2)),
+        ("W", (Comb (Comb (Param 0) (Param 1)) (Param 1), 2))
+      ]
+    ),
+    ( "IO",
+      [ ("Input", (Op "getInput" (Param 0), 1)),
+        ("Output", (Op "sendOutput" (Param 0), 1))
+      ]
+    )
+  ]
+
+normalize :: Expr -> Interpreted Expr
+normalize = State . reduceExpr
+  where
+    reduceExpr :: Expr -> Defs -> (Either String Expr, Defs)
+    reduceExpr (Comb (Var (Id "L")) e) rules = case reduceExpr e rules of
+      (Right e'@(Var (Str name)), rules') -> case find ((== name) . fst) libs of
+        Nothing -> (Left $ "unknown lib " ++ name, rules')
+        Just (_, defs) -> case filter (\(n, _) -> any ((== n) . fst) rules') defs of
+          [] -> (Right e', rules' ++ defs)
+          found -> case filter (\(n, expr) -> any (uncurry (&&) . bimap (== n) (/= expr)) rules') found of
+            [] -> (Right e', rules' ++ filter (not . (`elem` found)) defs)
+            found' -> (Left $ "error while importing lib " ++ name ++ ", " ++ show (map fst found') ++ " already defined with different impl", rules')
+      (Right c@(Comb _ _), rules') -> (Right $ Comb (Var (Id "L")) c, rules')
+      (Right i@(Var (Id _)), rules') -> (Right $ Comb (Var (Id "L")) i, rules')
+      (Right o, rules') -> (Left $ "invalid argoument " ++ toComblang o ++ " passed to L, string expected", rules')
+      err -> err
+    reduceExpr expr@(Comb _ _) rules = uncurry reduceHead (collect expr) rules
+    reduceExpr expr@(Var (Id name)) rules =
+      case lookup name rules of
+        Just rule | snd rule == 0 -> reduceExpr (fst rule) rules
+        _ -> (Right expr, rules)
+    reduceExpr expr rules = (Right expr, rules)
+
+    parametrize :: [Expr] -> Either String [String]
+    parametrize =
+      fst
+        . (`runState` [])
+        . mapM
+          ( State . \e params -> case e of
+              (Var (Id v))
+                | isLowerCase $ head v ->
+                    if v `elem` params
+                      then (Left $ v ++ " param named twice in same definition", params)
+                      else (Right v, v : params)
+              expr -> (Left $ "params must be lowercase names, " ++ toComblang expr ++ " is not a valid param", params)
+          )
+
+    toParams :: [(String, Int)] -> Expr -> Expr
+    toParams mapping expr@(Var (Id name)) = case find ((== name) . fst) mapping of
+      Just (_, n) -> Param n
+      Nothing -> expr
+    toParams mapping (Comb expr1 expr2) = Comb (toParams mapping expr1) (toParams mapping expr2)
+    toParams _ e = e
+
+    reduceHead (Var (Id "D")) (Var (Id name) : rest) rules =
+      let isDstart (Comb (Var (Id "Dstart")) _) = True
+          isDstart _ = False
+          (params, more) = break isDstart rest
+       in if any ((== name) . fst) rules || name == "D" || name == "Dstart"
+            then (Left $ name ++ " is already a combinator", rules)
+            else case more of
+              (Comb (Var (Id "Dstart")) body : leftover) ->
+                case parametrize params of
+                  (Left err) -> (Left err, rules)
+                  (Right ps) ->
+                    let body' = toParams (zip ps [0 ..]) body
+                        rules' = (name, (body', length ps)) : rules
+                     in reduceExpr (foldl' Comb (Var (Id name)) leftover) rules'
+              _ -> (Left "D without Dstart", rules)
+    reduceHead (Var (Id name)) args rules =
+      case lookup name rules of
+        Just rule
+          | length args >= snd rule ->
+              let (used, rest) = splitAt (snd rule) args
+                  body = substitute used (fst rule)
+               in reduceExpr (foldl' Comb body rest) rules
+        _ -> rebuild (Var (Id name)) args rules
+    reduceHead headExpr args rules = rebuild headExpr args rules
+
+    rebuild :: Expr -> [Expr] -> Defs -> (Either String Expr, Defs)
+    rebuild headExpr args = (foldl' Comb headExpr <$> mapM (State . reduceExpr) args).runState
+
+collect :: Expr -> (Expr, [Expr])
+collect =
+  let go args (Comb f x) = go (x : args) f
+      go args headExpr = (headExpr, args)
+   in go []
+
+substitute :: [Expr] -> Expr -> Expr
+substitute args (Param i) = args !! i
+substitute args (Comb f x) = Comb (substitute args f) (substitute args x)
+substitute _ atom = atom
+
+main :: IO ()
+main = runInputT defaultSettings $ loop builtins
+  where
+    loop b = do
+      minput <- getInputLine "> "
+      case minput of
+        Nothing -> return ()
+        Just "" -> loop b
+        Just input
+          | Just e <- runParser parseExpr input ->
+              case (normalize e).runState b of
+                (Left err, _) -> outputStrLn err >> loop b
+                (Right v@(Var (Id "Q")), _) -> outputStrLn (show v)
+                (Right v, d) -> outputStrLn (show v) >> loop d
+          | otherwise -> outputStrLn "Nothing" >> loop b

src/State.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE TupleSections #-}
+
+module State (State (..)) where
+
+import Control.Applicative (Alternative (empty, (<|>)))
+import Control.Arrow (Arrow (first), ArrowChoice (right))
+import Control.Monad (MonadPlus, ap)
+
+newtype State s a = State {runState :: s -> (Either String a, s)}
+
+instance Functor (State s) where
+  {-# INLINE fmap #-}
+  fmap f (State a) = State $ first (right f) . a
+
+instance Applicative (State s) where
+  {-# INLINE pure #-}
+  pure a = State (Right a,)
+  {-# INLINE (<*>) #-}
+  (<*>) = ap
+
+instance Monad (State s) where
+  {-# INLINE (>>=) #-}
+  (State a) >>= b = State $ runOnNotError b . a
+
+instance MonadFail (State s) where
+  fail err = State (Left err,)
+
+instance Alternative (State s) where
+  empty = fail ""
+  (State a) <|> (State b) = State $ \s ->
+    let r1 = a s
+        r2 = b s
+        ret = if erroring r1 then r2 else r1
+     in ret
+
+instance MonadPlus (State s)
+
+runOnNotError :: (a -> State s b) -> (Either String a, s) -> (Either String b, s)
+runOnNotError f (Right a, s) = runState (f a) s
+runOnNotError _ (Left err, s) = (Left err, s)
+
+erroring :: (Either String a, s) -> Bool
+erroring (Left _, _) = True
+erroring _ = False