add naive compiler

Author: Thomas Mahler

src/CCC/Compiler.hs

@@ -29,6 +29,7 @@
 
 module CCC.Compiler
   ( compileNumExpr,
+    compileNumExprNaive,
     compileEnvironment,
     tryCompileVar,
     compileNumericBindings
@@ -438,6 +439,116 @@ sIfFun = SFun $ \case
     _               -> Left "if: then branch must be integer"
   _                  -> Left "if: condition must be a Scott boolean (selector)"
 
+-- ---------------------------------------------------------------------------
+-- Naive (explicit CatExpr) compilation — no NBE
+-- ---------------------------------------------------------------------------
+
+-- | Naive CCC compilation: builds explicit CatExpr nodes directly.
+-- Unlike compileNumExpr (which uses NBE with Haskell closures for
+-- beta-reduction), this compiles into the RVal domain from a unit
+-- context, producing explicit Comp/fanC/Apply nodes at every step.
+--
+-- For first-order integer programs (no higher-order function passing),
+-- the output is identical to the NBE version — NBE only gains an
+-- advantage for higher-order terms where it can beta-reduce at compile time.
+compileNumExprNaive :: Environment -> Expr -> CatExpr () Integer
+compileNumExprNaive env expr =
+  case compileNaive env [] expr of
+    Right (RInt e) -> e
+    Right _        -> error "Naive compilation: expected integer result"
+    Left err       -> error ("Naive compilation failed: " ++ err)
+
+-- Direct CatExpr compilation (no NBE).
+-- Uses the same RVal machinery as compileRecExpr but starts from any context.
+-- Builtins are RFun closures (primitives), user-level code builds explicit nodes.
+--
+-- Key difference from compileExpr (NBE):
+--   NBE:   Lam → Haskell closure;  App → Haskell application (beta-reduces)
+--   Naive: Lam → RFun closure;     App → RFun application (same node building)
+-- For first-order programs, both produce identical CatExpr output because
+-- builtins build the same Comp/fanC nodes. The difference appears only
+-- with higher-order terms where NBE can beta-reduce at compile time.
+compileNaive :: forall c. Environment -> [(String, RVal c)] -> Expr -> Either String (RVal c)
+compileNaive env local = \case
+  Int i -> Right (RInt (IntConst i))
+  Var name ->
+    case lookup name local of
+      Just v  -> Right v
+      Nothing -> compileNaiveVar name
+  App fixHead stepExpr
+    | isNaiveFixOp env local fixHead -> compileNaiveFix env stepExpr
+  Lam param body ->
+    Right (RFun (\arg -> compileNaive env ((param, arg) : local) body))
+  App f x -> do
+    fVal <- compileNaive env local f
+    xVal <- compileNaive env local x
+    applyNaiveVal fVal xVal
+  where
+    compileNaiveVar name =
+      case lookup name env of
+        Just expr -> compileNaive env local expr
+        Nothing   -> case compileRecBuiltin name of
+                       Just v  -> Right v
+                       Nothing -> Left ("Unbound variable: " ++ name)
+
+    applyNaiveVal (RFun fn) x = fn x
+    applyNaiveVal _ _          = Left "Cannot apply non-function value"
+
+isNaiveFixOp :: Environment -> [(String, RVal c)] -> Expr -> Bool
+isNaiveFixOp env local = go []
+  where
+    go _ (Int _) = False
+    go _ (Lam _ _) = False
+    go _ (App _ _) = False
+    go seen (Var name)
+      | name `elem` map fst local = False
+      | name == "y" || name == "fix" = True
+      | name `elem` seen = False
+      | otherwise =
+          case lookup name env of
+            Just expr -> go (name : seen) expr
+            Nothing   -> False
+
+compileNaiveFix :: forall c. Environment -> Expr -> Either String (RVal c)
+compileNaiveFix env = \case
+  Lam fName stepExpr ->
+    case collectLams stepExpr of
+      (params, body) ->
+        case mkIntArgs (length params) of
+          Just (SomeIntArgs args) -> compileNaiveFixGeneric env args fName params body
+          Nothing                 -> Left "fix expects at least one integer argument"
+  _ -> Left "fix expects a lambda step function"
+
+compileNaiveFixGeneric ::
+  forall c input.
+  Environment ->
+  IntArgs input ->
+  String ->
+  [String] ->
+  Expr ->
+  Either String (RVal c)
+compileNaiveFixGeneric env args fName params body = buildCurried args []
+  where
+    buildCurried :: IntArgs remaining -> [CatExpr c Integer] -> Either String (RVal c)
+    buildCurried OneArg acc =
+      Right $ RFun $ \case
+        RInt arg -> applyNaiveFix (acc ++ [arg])
+        _        -> Left "fix expects Integer argument"
+    buildCurried (MoreArgs rest) acc =
+      Right $ RFun $ \case
+        RInt arg -> buildCurried rest (acc ++ [arg])
+        _        -> Left "fix expects Integer argument"
+
+    applyNaiveFix :: [CatExpr c Integer] -> Either String (RVal c)
+    applyNaiveFix actualArgs = do
+      paramTuple <- tupleFromExprs args actualArgs
+      recFun <- buildRecFun args
+      let fixLocal =
+            (fName, recFun) :
+            zipWith (\name proj -> (name, RInt proj)) params (argProjections args Snd)
+      stepBody <- compileNaive env fixLocal body >>= expectRInt "Recursive body must compile to Integer"
+      Right (RInt (Comp (Fix stepBody) paramTuple))
+
 -- | Compile an expression, extracting environment variables to morphisms.
 -- Returns a list of (name, morphism_string_representation) for inspection.
 compileEnvironment :: Environment -> [(String, String)]

test/CCCCompilerSpec.hs

@@ -138,6 +138,42 @@ spec = do
     it "parses and compiles tak" $ do
       verifyMainMatchesExpected tak
 
+  describe "CCC.Compiler compileNumExprNaive" $ do
+    it "compiles an integer literal" $ do
+      let morph :: CatExpr () Integer
+          morph = compileNumExprNaive [] (Int 5)
+      interp morph () `shouldBe` 5
+
+    it "compiles variable lookup" $ do
+      let morph :: CatExpr () Integer
+          morph = compileNumExprNaive [("n", Int 13)] (Var "n")
+      interp morph () `shouldBe` 13
+
+    it "compiles unary y-recursion structurally using Fix" $ do
+      let expr = App (App (Var "y") (Lam "f" (Lam "n"
+                  (App (App (App (Var "if") (App (Var "is0") (Var "n")))
+                       (Int 1))
+                       (App (App (Var "*") (Var "n"))
+                            (App (Var "f") (App (Var "sub1") (Var "n"))))))))
+                 (Int 5)
+          morph = compileNumExprNaive [] expr :: CatExpr () Integer
+      show morph `shouldSatisfy` isInfixOf "Fix"
+      interp morph () `shouldBe` 120
+
+    it "produces same results as NBE for all TestSources programs" $ do
+      mapM_ verifyNaiveMatchesNBE [cccLiteral, cccAlias, cccIdentity, cccConst,
+                                    factorial, fibonacci, gaussian, ackermann, tak]
+
+verifyNaiveMatchesNBE :: String -> Expectation
+verifyNaiveMatchesNBE source = do
+  let env = parseEnvironment source
+      mainExpr = fromJust (lookup "main" env)
+      nbeMorph :: CatExpr () Integer
+      nbeMorph = compileNumExpr env mainExpr
+      naiveMorph :: CatExpr () Integer
+      naiveMorph = compileNumExprNaive env mainExpr
+  interp naiveMorph () `shouldBe` interp nbeMorph ()
+
 verifyMainMatchesExpected :: String -> Expectation
 verifyMainMatchesExpected source = do
   let env = parseEnvironment source