{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultilineStrings #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
module Gyehoek.CPS.Lower
  (
  lower) where

import Gyehoek.CPS.Syntax
import Data.Generics.Labels
import Gyehoek.Scheme.Syntax qualified as Scm
import Gyehoek.GenSym
import Data.List.NonEmpty (NonEmpty((:|)))
import Effectful
import Control.Monad.Cont qualified as Cont
import Effectful.Writer.Static.Local
import Data.Text (Text)
import Data.Vector.Strict (Vector)
import Control.Lens
import Data.Foldable
import Data.HashMap.Strict (HashMap)
import Numeric.Natural
import GHC.Generics (Generic)
import Gyehoek.Scheme.Syntax (Lit(LitInt))
import Text.Printf
import qualified Data.Text as T
import qualified Data.Vector.Strict as V
import Data.IntMap.Strict (IntMap)


data Env = MkEnv { vars :: Vector Name }
  deriving (Show, Generic)

emptyEnv :: Env
emptyEnv = MkEnv mempty

type instance Index Env = Natural
type instance IxValue Env = Name

instance Ixed Env where
  ix i = #vars . ix (fromIntegral i)



tshow :: Show a => a -> Text
tshow = T.pack . show



lowerVal :: Env -> Val -> Vector Text

lowerVal g (ValLit l) =
  case l of
    LitInt n -> [ "i32.const " <> tshow n ]
    _ -> _

lowerVal g (ValVar x) = [ "local.get " <> tshow i ]
  where
    i = V.elemIndex x g.vars ^?! _Just

lower' :: Env -> Exp -> Vector Text

lower' g (Halt [e]) = lowerVal g e

lower' g (ExpPrim p rs e) =
  case p of
    PrimAdd x y -> lowerBinOp "i32.add" g x y r e
    PrimMul x y -> lowerBinOp "i32.mul" g x y r e
  where
    r = head rs

lowerBinOp op g x y r e =
  lowerVal g x
  <> lowerVal g y
  <> [ op, "local.set " <> tshow n ]
  <> lower' g' e
  where
    g' = g & #vars <>~ [r]
    n = length (g ^. #vars)



makeFunc :: Vector Text -> Text
makeFunc = (preamble<>) . (<>postamble) . T.unlines . toList . fmap indent
  where
    indent = ("    "<>)
    preamble  = "(module\n\
                \  (func (export \"main\") (result i32)\n\
                \    (local i32 i32 i32 i32 i32 i32)\n"
    postamble = "  ))"

lower :: Exp -> Eff es Text
lower = pure . makeFunc . lower' emptyEnv