{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedLists #-}
module Main
  (main)
  where

import Data.Text (Text)
import Effectful
import Gyehoek.QBE as QBE
import Data.List (List)
import Data.Text.IO qualified as TIO
import Control.Lens
import Data.Vector (Vector)
import Data.Function (fix)
import Effectful.Writer.Static.Local


type Name = Text

data Value
  = ValInt Int
  | ValNil
  | ValPrim Prim
  deriving (Show)

data Sexp
  -- | Cons
  = Sexp :. Sexp
  | UseVal Value
  deriving (Show)

infixr 5 :.
pattern Cons :: Sexp -> Sexp -> Sexp
pattern Cons x y = x :. y

data Prim = PrimAdd | PrimSub | PrimMul | PrimDiv
  deriving (Show)

mapcar :: Traversal' Sexp Sexp
mapcar k (Cons x xs) = Cons <$> k x <*> mapcar k xs
mapcar k x           = pure x

type CodeGen = Writer (Vector Inst)

runCodeGen :: Eff (CodeGen : es) a -> Eff es (a, Vector Inst)
runCodeGen = runWriter

emit :: CodeGen :> es => Inst -> Eff es ()
emit = tell . pure

compile
  :: (GenSym :> es, CodeGen :> es)
  => Sexp
  -> (QBE.Val -> Eff es Jump)
  -> Eff es Jump

compile (UseVal (ValInt n)) k =
  k . ValConst . CInt . fromIntegral $ n

compile (UseVal (ValPrim p) :. args) k = f (args ^.. mapcar)
  where
    f [x,y] =
      compile x \x' ->
        compile y \y' -> do
          r <- gensym
          emit $ BinaryOp (r := Long) bop x' y'
          k (ValTemporary r)
    f _ = _
    bop = case p of
      PrimAdd -> Add
      PrimMul -> Mul
      _ -> _

compile _ _ = _

compile' :: (GenSym :> es) => Ident Label -> Sexp -> Eff es Block
compile' l e = do
  (j,is) <- runCodeGen $ compile e (pure . Ret . Just)
  pure $ Block l [] (is ^.. each) j

main :: IO ()
main = putStrLn "Hello, Haskell!"

expr = UseVal (ValPrim PrimAdd)
  :. UseVal (ValInt 1)
  :. UseVal (ValInt 2)
  -- :. UseVal (ValInt 3)
  :. UseVal ValNil