Primops.hs

module Language.Melody.Interpret.Env.Primops where
import Language.Melody.Syntax
import Language.Melody.Interpret.Types
import Language.Melody.Interpret.Pop
import Language.Melody.Interpret.Compile
import Control.Monad.Reader
import Control.Applicative
import Control.Lens hiding (cons, uncons)
import qualified Data.Map as M

primops :: MelodyState
primops = MS builtins M.empty []

arith :: (Double -> Double -> Double) -> Melody
arith f = liftM2 f popNum popNum >>= push . NumLit

cons :: Melody
cons = do
  t <- pop
  case t of
    StrLit s       -> pushWith popStr           $ StrLit . (++ s)
    List   l       -> pushWith pop              $ List . (:l)
    Dictionary   d -> pushWith (pop >>= toPair) $ Dictionary . (:d)
    _              -> typeError "cons: Not sequence"
  where toPair (List [a, b]) = return (a, b)
        toPair _             = typeError "cons: Not a list of two elements"
        pushWith f with = f >>= push . with

uncons :: Melody
uncons = do
  expr <- pop
  case expr of
    StrLit (s : ss)        -> pushBoth (StrLit [s]) (StrLit ss)
    List   (l : ll)        -> pushBoth l (List ll)
    Dictionary ((a,b): hh) -> pushBoth (List [a, b]) (Dictionary hh)
    _                      -> typeError "Not sequence"
  where pushBoth a b = push b >> push a

apply :: Melody
apply = do
  (body, clos) <- popFunc
  clos' <- maybe (fail "$: Caught non-closed lambda") return clos
  void . local (M.union clos') $ compile body
    -- Use the closure attached to a function

equals :: Melody
equals = do
  l <- pop
  r <- pop
  when (isOpaque l || isOpaque r) $
    typeError "Comparing Opaques"
  if l == r then true else false
  where true  = void pop
        false = pop <* pop >>= push
        isOpaque (Opaque {}) = True
        isOpaque _           = False


unbox :: Melody
unbox = popBoxed >>= mapM_ push . reverse . contents
  where contents (_, _, es) = es

builtins :: M.Map String Melody
builtins = M.fromList
           [("pop", void pop),
            ("print", pop >>= liftIO . print),
            ("putStr", popStr >>= liftIO . putStrLn),
            ("+", arith (+)),
            ("-", arith (-)),
            ("/", arith (/)),
            ("*", arith (*)),
            ("dump", use stack >>= liftIO . print),
            ("cons", cons),
            ("uncons", uncons),
            ("$", apply),
            ("no-op", return ()),
            ("=", equals),
            ("unbox", unbox),
            ("typeOf", pop >>= push . StrLit . typeName)]