Compile.hs

module Language.Melody.Interpret.Compile (compile) where
import Language.Melody.Syntax
import Language.Melody.Interpret.Types
import Language.Melody.Interpret.Pop
import Control.Monad.Error
import Control.Monad.Reader
import Control.Lens
import Control.Applicative
import qualified Data.Map as M
import Data.Maybe


resolve :: [([TypeName], Melody)] -> MelodyM (Maybe Melody)
resolve cs = fmap snd . foldr choose Nothing <$> filterM matches cs
  where matches (ts, _) = do
          s <- map typeName <$> use stack
          return $ length s >= length ts && s <<: ts
        choose (t1, body1) (Just (t2, body2)) | t1 <<: t2  = Just (t1, body1)
                                              | t2 <<: t1  = Just (t2, body2)
                                              | otherwise = Nothing
        choose t  Nothing   = Just t
        t1 <<: t2 = all (uncurry (<:)) $ zip t1 t2
        
-- | Bind a list of expressions into a closure
addClosure :: Expr NotCompiled -> MelodyM (Expr NotCompiled)
addClosure body = (Func body . Just) <$> ask

-- | Ask whether a word is in a closure, inlining it
-- if it is.
inlineClosedWord :: String -> MelodyM (Expr NotCompiled)
inlineClosedWord w = maybe (Word w) id . M.lookup w <$> ask

-- | Attach a closure to a function without
-- and inline a closed word running and recurses on all
-- other compound structures
close :: Expr NotCompiled -> MelodyM (Expr NotCompiled)
close (Func body Nothing) = addClosure body
close (Word w)            = inlineClosedWord w
close (Dictionary d)      = Dictionary <$> mapM (both close) d
close (List l)            = List <$> mapM close l
close a                   = return a

-- | Resolve a variable name in the current scope
selectVariable :: String -> Melody
selectVariable w = do
  global <- use (env.at w)        -- Global
  mult   <- use (multi.at w) >>= resolving
  loc    <- M.lookup w <$> ask    -- Local
  assertExists $ pushing loc <|> mult <|> global
  where pushing      = fmap push
        resolving    = maybe (return Nothing) id . fmap resolve
        assertExists = fromMaybe . lift . throwError $ NoSuchName w

-- | Compile a group of expressions in order
compileMany :: [Expr NotCompiled] -> Melody
compileMany = mapM_ compile

-- | Bind the list of names to the top items on the stack
addEnv :: [String] -> Melody -> Melody
addEnv names m = do
  vals <- topN (length names)
  local (M.union . M.fromList $ zip names vals) m

-- | Compile a Melody expression.
-- If the expression is a word, than it is evaluated in the
-- current context, otherwise it is pushed on to the stack
compile :: Expr NotCompiled -> Melody
compile (Word w) = selectVariable w
compile (Binding nms exprs) = addEnv nms $ compileMany exprs
compile (Comp es) = compileMany es
compile (Func body Nothing) = addClosure body >>= push
compile (List es) = mapM close es >>= push . List
compile (Dictionary es) = mapM (both close) es >>= push . Dictionary
compile e = push e