<commit_before>{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE OverloadedStrings     #-}
module Language.Malgo.MiddleEnd.TransToIR (trans) where

import           Language.Malgo.ID
import           Language.Malgo.IR.IR
import qualified Language.Malgo.IR.Syntax as S
import           Language.Malgo.Monad
import           Language.Malgo.Prelude
import           Language.Malgo.Type

throw :: MonadMalgo s m => Doc ann -> m a
throw mes = malgoError $ "error(transToIR):" <+> mes

update :: MonadMalgo UniqSupply m => ID Type -> m (ID MType)
update a = do
  mty <- toMType (typeOf a)
  return $ a & idMeta .~ mty

newTmp :: MonadMalgo s f => Name -> a -> f (ID a)
newTmp n t = ID ("$" <> n) <$> newUniq <*> return t

trans :: MonadMalgo UniqSupply m => S.Expr (ID Type) -> m (Expr (ID MType))
trans e = transToIR e

insertLet :: MonadMalgo s m => (ID MType -> m (Expr (ID MType))) -> Expr (ID MType) -> m (Expr (ID MType))
insertLet k (Var x) = k x
insertLet k v = do
  x <- newTmp "k" (mTypeOf v)
  e <- k x
  return (Let x v e)

transToIR :: MonadMalgo UniqSupply m => S.Expr (ID Type) -> m (Expr (ID MType))
transToIR (S.Var _ a)   = Var <$> update a
transToIR (S.Int _ x)   = return (Int x)
transToIR (S.Float _ x) = return (Float x)
transToIR (S.Bool _ x)  = return (Bool x)
transToIR (S.Char _ c)  = return (Char c)
transToIR (S.String _ s) = return (String s)
transToIR (S.Unit _) = return Unit
transToIR (S.Tuple _ vs) = mapM transToIR vs >>= (\vs' -> bind vs' [] (return . Tuple))
  where
    bind [] args k = k (reverse args)
    bind (x:xs) args k =
      insertLet (\x' -> bind xs (x' : args) k) x
transToIR (S.TupleAccess _ e i) =
  transToIR e >>= insertLet (\e' -> return $ Access e' [0, i])
transToIR (S.Fn _ params body) = do
  body' <- transToIR body
  params' <- mapM (update . fst) params
  fnid <- newTmp "lambda" (FunctionTy (mTypeOf body') (map mTypeOf params'))
  return (LetRec [(fnid, Just params', body')] (Var fnid))
transToIR (S.Call _ fn args) = do
  args' <- mapM transToIR args
  insertLet (\fn' -> bind args' [] (return . Apply fn')) =<< transToIR fn
  where bind [] args' k     = k (reverse args')
        bind (x:xs) args' k = insertLet (\x' -> bind xs (x' : args') k) x
transToIR (S.Seq _ e1 e2) =
  transToIR e2 >>= insertLet (const $ transToIR e1)
transToIR (S.Let info (S.ValDec _ n _ val:ds) body) = do
  val' <- transToIR val
  rest <- transToIR (S.Let info ds body)
  n' <- update n
  return $ Let n' val' rest
transToIR (S.Let info (S.FunDec _ fn params _ fbody:ds) body) = do
  fbody' <- transToIR fbody
  rest <- transToIR (S.Let info ds body)
  fn' <- update fn
  params' <- mapM (update . fst) params
  return $ LetRec [(fn', Just params', fbody')] rest
transToIR (S.Let info (S.ExDec _ n _ orig:ds) body) = do
  n' <- update n
  case mTypeOf n' of
    FunctionTy _ params -> do
      params' <- mapM (newTmp "x") params
      prim <- newTmp "prim" (mTypeOf n')
      LetRec [(n', Just params', Let prim (Prim orig (mTypeOf n')) (Apply prim params'))]
        <$> transToIR (S.Let info ds body)
    _ -> Let n' (Prim orig (mTypeOf n')) <$> transToIR (S.Let info ds body)
transToIR (S.Let _ [] body) =
  transToIR body
transToIR (S.If _ c t f) =
  insertLet (\c' -> If c' <$> transToIR t <*> transToIR f) =<< transToIR c
transToIR (S.BinOp _ op x y) = do
  x' <- transToIR x
  y' <- transToIR y
  let xty = mTypeOf x'
  let op' = transOp op xty
  opval <- newTmp "op" (mTypeOf op')
  insertLet (\x'' -> insertLet (\y'' -> return $ Let opval op' (Apply opval [x'', y''])) y') x'

transOp :: S.Op -> MType -> Expr (ID MType)<commit_msg>Revert "insertLetの機能を変更"<commit_after>{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE OverloadedStrings     #-}
module Language.Malgo.MiddleEnd.TransToIR (trans) where

import           Language.Malgo.ID
import           Language.Malgo.IR.IR
import qualified Language.Malgo.IR.Syntax as S
import           Language.Malgo.Monad
import           Language.Malgo.Prelude
import           Language.Malgo.Type

throw :: MonadMalgo s m => Doc ann -> m a
throw mes = malgoError $ "error(transToIR):" <+> mes

update :: MonadMalgo UniqSupply m => ID Type -> m (ID MType)
update a = do
  mty <- toMType (typeOf a)
  return $ a & idMeta .~ mty

newTmp :: MonadMalgo s f => Name -> a -> f (ID a)
newTmp n t = ID ("$" <> n) <$> newUniq <*> return t

trans :: MonadMalgo UniqSupply m => S.Expr (ID Type) -> m (Expr (ID MType))
trans e = transToIR e

insertLet :: MonadMalgo UniqSupply m => S.Expr (ID Type) -> (ID MType -> m (Expr (ID MType))) -> m (Expr (ID MType))
insertLet (S.Var _ x) k = update x >>= k
insertLet v k = do
  v' <- transToIR v
  x <- newTmp "k" (mTypeOf v')
  e <- k x
  return (Let x v' e)

transToIR :: MonadMalgo UniqSupply m => S.Expr (ID Type) -> m (Expr (ID MType))
transToIR (S.Var _ a)   = Var <$> update a
transToIR (S.Int _ x)   = return (Int x)
transToIR (S.Float _ x) = return (Float x)
transToIR (S.Bool _ x)  = return (Bool x)
transToIR (S.Char _ c)  = return (Char c)
transToIR (S.String _ s) = return (String s)
transToIR (S.Unit _) = return Unit
transToIR (S.Tuple _ vs) = bind vs [] (return . Tuple)
  where
    bind [] args k = k (reverse args)
    bind (x:xs) args k =
      insertLet x (\x' -> bind xs (x' : args) k)
transToIR (S.TupleAccess _ e i) =
  insertLet e (\e' -> return $ Access e' [0, i])
transToIR (S.Fn _ params body) = do
  body' <- transToIR body
  params' <- mapM (update . fst) params
  fnid <- newTmp "lambda" (FunctionTy (mTypeOf body') (map mTypeOf params'))
  return (LetRec [(fnid, Just params', body')] (Var fnid))
transToIR (S.Call _ fn args) =
  insertLet fn (\fn' -> bind args [] (return . Apply fn'))
  where bind [] args' k     = k (reverse args')
        bind (x:xs) args' k = insertLet x (\x' -> bind xs (x' : args') k)
transToIR (S.Seq _ e1 e2) =
  insertLet e2 (\_ -> transToIR e1)
transToIR (S.Let info (S.ValDec _ n _ val:ds) body) = do
  val' <- transToIR val
  rest <- transToIR (S.Let info ds body)
  n' <- update n
  return $ Let n' val' rest
transToIR (S.Let info (S.FunDec _ fn params _ fbody:ds) body) = do
  fbody' <- transToIR fbody
  rest <- transToIR (S.Let info ds body)
  fn' <- update fn
  params' <- mapM (update . fst) params
  return $ LetRec [(fn', Just params', fbody')] rest
transToIR (S.Let info (S.ExDec _ n _ orig:ds) body) = do
  n' <- update n
  case mTypeOf n' of
    FunctionTy _ params -> do
      params' <- mapM (newTmp "x") params
      prim <- newTmp "prim" (mTypeOf n')
      LetRec [(n', Just params', Let prim (Prim orig (mTypeOf n')) (Apply prim params'))]
        <$> transToIR (S.Let info ds body)
    _ -> Let n' (Prim orig (mTypeOf n')) <$> transToIR (S.Let info ds body)
transToIR (S.Let _ [] body) =
  transToIR body
transToIR (S.If _ c t f) =
  insertLet c (\c' -> If c' <$> transToIR t <*> transToIR f)
transToIR (S.BinOp _ op x y) = do
  xty <- mTypeOf <$> transToIR x
  let op' = transOp op xty
  opval <- newTmp "op" (mTypeOf op')
  insertLet x $ \x' ->
    insertLet y $ \y' ->
    return $ Let opval op' (Apply opval [x', y'])

transOp :: S.Op -> MType -> Expr (ID MType)
{'fraction_non_alphanumeric': 0.15189698144558295, 'fraction_numerical': 0.0013846579894765993, 'mean_word_length': 2.844065992549228, 'pattern_counts': {'":': 0, '<': 65, '<?xml version=': 0, '>': 84, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '3388069', 'n_tokens_mistral': 2824, 'n_tokens_neox': 2764, 'n_words': 954}