template instantiation

rlp.cabal

@@ -21,6 +21,7 @@ library
     exposed-modules:  Core
                     , TI
     other-modules:    Data.Heap
+                    , Control.DFA
 
     -- other-extensions:
     build-depends:    base ^>=4.18.0.0

src/Control/DFA.hs

@@ -0,0 +1,17 @@
+module Control.DFA
+    ( DFA(..)
+    , evalDFA
+    )
+    where
+----------------------------------------------------------------------------------
+import Data.Maybe       (isJust, catMaybes)
+----------------------------------------------------------------------------------
+
+newtype DFA s = DFA { stepDFA :: s -> Maybe s }
+
+evalDFA :: DFA s -> s -> [s]
+evalDFA dfa s = catMaybes $ iterateM (stepDFA dfa) s
+    where
+        iterateM :: (Monad m) => (a -> m a) -> a -> [m a]
+        iterateM k z = iterate (>>=k) (pure z)
+

src/Core.hs

@@ -11,12 +11,14 @@ data Expr = Var Name
           | Lam [Name] Expr
           | App Expr Expr
           | IntP Int
+          deriving Show
 
 infixl 2 :$
 pattern (:$) :: Expr -> Expr -> Expr
 pattern f :$ x = App f x
 
 data Binding = Binding Name Expr
+    deriving Show
 
 infixl 1 :=
 pattern (:=) :: Name -> Expr -> Binding
@@ -24,8 +26,10 @@ pattern k := v = Binding k v
 
 data Rec = Rec
          | NonRec
+         deriving Show
 
 data Alter = Alter Int [Name] Expr
+    deriving Show
 
 type Name = String
 

src/Data/Heap.hs

@@ -1,11 +1,12 @@
 module Data.Heap
     ( Heap
+    , Addr
     , alloc
     , update
     , free
-    , hlookup
+    , hLookup
     , addresses
-    , hsize
+    , hSize
     )
     where
 ----------------------------------------------------------------------------------
@@ -15,6 +16,7 @@ import Data.List                    (intersect)
 ----------------------------------------------------------------------------------
 
 data Heap a = Heap [Addr] (Map Addr a)
+    deriving Show
 
 type Addr = Int
 
@@ -50,12 +52,12 @@ update (Heap u m) k v = Heap u (M.adjust (const v) k m)
 free :: Heap a -> Addr -> Heap a
 free (Heap u m) k = Heap (k:u) (M.delete k m)
 
-hlookup :: Heap a -> Addr -> Maybe a
+hLookup :: Addr -> Heap a -> Maybe a
-hlookup (Heap _ m) k = m !? k
+hLookup k (Heap _ m) = m !? k
 
 addresses :: Heap a -> [Addr]
 addresses (Heap _ m) = M.keys m
 
-hsize :: Heap a -> Int
+hSize :: Heap a -> Int
-hsize (Heap _ m) = M.size m
+hSize (Heap _ m) = M.size m
 

src/TI.hs

@@ -1,28 +1,34 @@
+{-# LANGUAGE LambdaCase, BlockArguments #-}
 module TI where
 ----------------------------------------------------------------------------------
-import Data.Map (Map, (!?), (!))
+import Data.Map                 (Map, (!?), (!))
-import qualified Data.Map as M
+import Data.Map qualified as M
-import Data.Set (Set)
+import Data.Set                 (Set)
-import qualified Data.Set as S
+import Data.Set qualified as S
-import Data.Maybe (fromJust)
+import Data.Maybe               (fromJust, fromMaybe)
-import Data.List (mapAccumL)
+import Data.List                (mapAccumL)
+import Control.Monad            (guard)
+import Data.Function            ((&))
+import Data.Heap
+import Control.DFA
 import Core
 ----------------------------------------------------------------------------------
 
-data TiState = TiState [Addr] Dump Heap [(Name, Addr)] Stats
+data TiState = TiState [Addr] Dump TiHeap [(Name, Addr)] Stats
+    deriving Show
 
-type Heap = Set Node
+type TiHeap = Heap Node
 
 data Node = NAp Addr Addr
           | NSupercomb Name [Name] Expr
           | NNum Int
+          deriving Show
 
 data Dump = DumpTempDummy
+    deriving Show
 
 type Stats = Int
 
-type Addr = Int
-
 ----------------------------------------------------------------------------------
 
 tiStatIncSteps :: Stats -> Stats
@@ -40,15 +46,85 @@ compile prog = Just $ TiState s d h g stats
         d = DumpTempDummy
         (h,g) = buildInitialHeap defs
         defs = prog <> corePrelude
-        stats = undefined
+        stats = 0
 
         mainAddr = fromJust $ lookup "main" g
 
-buildInitialHeap :: Program -> (Heap, [(Name, Addr)])
+buildInitialHeap :: Program -> (TiHeap, [(Name, Addr)])
-buildInitialHeap = undefined
+buildInitialHeap (Program scdefs) = mapAccumL allocateSc mempty scdefs
+    where
+        allocateSc :: TiHeap -> ScDef -> (TiHeap, (Name, Addr))
+        allocateSc h (ScDef n a b) = (h', (n, addr))
+            where
+                (h', addr) = alloc h (NSupercomb n a b)
+
+evalProgram :: Program -> Maybe TiState
+evalProgram p = last <$> evalDFA step <$> compile p
+
+step :: DFA TiState
+step = DFA \ st@(TiState stack _ heap _ _) -> do
+    case stack of
+        []    -> error "stack is empty"
+        [a]   -> case hLookup a heap of
+            Just (NNum n) -> Nothing
+            _             -> error "i don't wanna properly handle errors rn :3"
+        (a:_) -> case hLookup a heap of
+            Just node -> Just $ dispatch st node
+            Nothing   -> error "imaginary segfault oooh"
+    where
+        dispatch :: TiState -> Node -> TiState
+        dispatch st = \case
+            NNum n           -> numStep st n
+            NAp f x          -> apStep  st f x
+            NSupercomb n a b -> scStep  st n a b
+
+        numStep :: TiState -> Int -> TiState
+        numStep _ _ = error "number applied as a function"
+
+        apStep :: TiState -> Addr -> Addr -> TiState
+        apStep (TiState s d h g sts) f x =
+            TiState (f:s) d h g sts
+
+        scStep :: TiState -> Name -> [Name] -> Expr -> TiState
+        scStep (TiState s d h g sts) n as b =
+            TiState s' d h' g sts
+            where
+                s' = resAddr : drop (length as + 1) s
+                (h', resAddr) = instantiate b h env
+                env = argBinds ++ g
+                argBinds = as `zip` getArgs h s
+
+getArgs :: TiHeap -> [Addr] -> [Addr]
+getArgs h (sc:s) = fmap f s
+    where
+        f addr = case hLookup addr h of
+            Just (NAp _ arg) -> arg
+            _                -> error "glados yuri"
+
+instantiate :: Expr -> TiHeap -> [(Name, Addr)] -> (TiHeap, Addr)
+instantiate (IntP n)   h _ = alloc h (NNum n)
+instantiate (App f x)  h g = alloc h'' (NAp f' x')
+    where
+        (h', f') = instantiate f h g
+        (h'', x') = instantiate x h' g
+instantiate (Var k)    h g = (h, fromMaybe (error "variable not in scope") v)
+    where v = lookup k g
+instantiate (Case _ _) _ _ = error "cannot instantiate case expressions"
+instantiate _          _ _ = error "unimplemented"
+
+isFinal :: TiState -> Bool
+isFinal (TiState [addr] _ h _ _) =
+    case hLookup addr h of
+        Just a -> isDataNode a
+        _      -> error "i don't wanna properly handle errors rn :3"
+isFinal (TiState [] _ _ _ _) = error "empty stack..."
+isFinal _ = False
+
+isDataNode :: Node -> Bool
+isDataNode (NNum _) = True
+isDataNode _        = False
+
+doAdmin :: TiState -> TiState
+doAdmin (TiState s d h g stats) = TiState s d h g (stats+1)
 
--- buildInitialHeap (Program scdefs) = mapAccumL allocateSc mempty scdefs
---     where
---         allocateSc :: Heap -> ScDef -> (Heap, (Name, Addr))
---         allocateSc = undefined