<commit_before>{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TupleSections             #-}
{-# LANGUAGE TypeSynonymInstances      #-}

-------------------------------------------------------------------------------------
------------ Code to convert Core to Administrative Normal Form ---------------------
-------------------------------------------------------------------------------------

module Language.Haskell.Liquid.ANFTransform (anormalize) where

import           CoreSyn
import           CoreUtils                        (exprType)
import           DsMonad                          (DsM, initDs)
import           FastString                       (fsLit)
import           GHC                              hiding (exprType)
import           HscTypes
import           Id                               (mkSysLocalM)
import           Literal
import           MkCore                           (mkCoreLets)
import           Outputable
import           Var                              (varType)
import           TypeRep
import           TyCon                            (tyConDataCons_maybe)
import           DataCon                          (dataConInstArgTys)
import           VarEnv                           (VarEnv, emptyVarEnv, extendVarEnv, lookupWithDefaultVarEnv)
import           Control.Monad
import           Language.Haskell.Liquid.Fixpoint (anfPrefix)
import           Language.Haskell.Liquid.GhcMisc  (MGIModGuts(..))
import           Language.Haskell.Liquid.Misc     (fst3, errorstar)
import           Data.Maybe                       (fromMaybe)
import           Data.List                        (sortBy, (\\))

anormalize :: HscEnv -> MGIModGuts -> IO [CoreBind]
anormalize hscEnv modGuts
  = do putStrLn "***************************** GHC CoreBinds ***************************" 
       putStrLn $ showPpr orig_cbs
       liftM (fromMaybe err . snd) $ initDs hscEnv m grEnv tEnv act 
    where m        = mgi_module modGuts
          grEnv    = mgi_rdr_env modGuts
          tEnv     = modGutsTypeEnv modGuts
          act      = liftM concat $ mapM (normalizeBind emptyVarEnv) orig_cbs
          orig_cbs = mgi_binds modGuts
          err      = errorstar "anormalize fails!"

modGutsTypeEnv mg = typeEnvFromEntities ids tcs fis
  where ids = bindersOfBinds (mgi_binds mg)
        tcs = mgi_tcs mg
        fis = mgi_fam_insts mg

------------------------------------------------------------------
----------------- Actual Normalizing Functions -------------------
------------------------------------------------------------------

------------------------------------------------------------------
normalizeBind :: VarEnv Id -> CoreBind -> DsM [CoreBind]
------------------------------------------------------------------

normalizeBind γ (NonRec x e)
  = do (bs, e') <- normalize γ e
       return (bs ++ [NonRec x e'])

normalizeBind γ (Rec xes)
  = do es' <- mapM (normalize γ >=> (return . stitch)) es
       return [Rec (zip xs es')]
    where (xs, es) = unzip xes

--------------------------------------------------------------------
normalizeName :: VarEnv Id -> CoreExpr -> DsM ([CoreBind], CoreExpr)
--------------------------------------------------------------------

-- normalizeNameDebug γ e 
--   = liftM (tracePpr ("normalizeName" ++ showPpr e)) $ normalizeName γ e

normalizeName _ e@(Lit (LitInteger _ _))
  = normalizeLiteral e

normalizeName _ e@(Tick _ (Lit (LitInteger _ _)))
  = normalizeLiteral e

normalizeName γ (Var x)
  = return ([], Var (lookupWithDefaultVarEnv γ x x))

normalizeName _ e@(Type _)
  = return ([], e)

normalizeName _ e@(Lit _)
  = return ([], e)

normalizeName γ (Tick n e)
  = do (bs, e') <- normalizeName γ e
       return (bs, Tick n e')

normalizeName γ e
  = do (bs, e') <- normalize γ e
       x        <- freshNormalVar $ exprType e
       return (bs ++ [NonRec x e'], Var x)

-------------------------------------------------------------------------------------
normalizeLiteral :: CoreExpr -> DsM ([CoreBind], CoreExpr)
-------------------------------------------------------------------------------------

normalizeLiteral e =
  do x <- freshNormalVar (exprType e)
     return ([NonRec x e], Var x)

freshNormalVar = mkSysLocalM (fsLit anfPrefix)

---------------------------------------------------------------------
normalize :: VarEnv Id -> CoreExpr -> DsM ([CoreBind], CoreExpr)
---------------------------------------------------------------------

normalize γ (Lam x e)
  = do e' <- stitch `fmap` normalize γ e
       return ([], Lam x e')

normalize γ (Let b e)
  = do bs'        <- normalizeBind γ b
       (bs'', e') <- normalize γ e
       return (bs' ++ bs'', e')

normalize γ (Case e x t as)
  = do (bs, n) <- normalizeName γ e
       x'      <- freshNormalVar τx -- rename "wild" to avoid shadowing
       let γ'   = extendVarEnv γ x x'
       as'     <- forM as $ \(c, xs, e') -> liftM ((c, xs,) . stitch) (normalize γ' e')
       as''    <- expandDefaultCase τx as' 
       return     (bs, Case n x' t as'')
    where τx = varType x

normalize γ (Var x)
  = return ([], Var (lookupWithDefaultVarEnv γ x x))
<commit_msg>use stitch to prevent anfbinds from floating to top<commit_after>{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TupleSections             #-}
{-# LANGUAGE TypeSynonymInstances      #-}

-------------------------------------------------------------------------------------
------------ Code to convert Core to Administrative Normal Form ---------------------
-------------------------------------------------------------------------------------

module Language.Haskell.Liquid.ANFTransform (anormalize) where

import           CoreSyn
import           CoreUtils                        (exprType)
import           DsMonad                          (DsM, initDs)
import           FastString                       (fsLit)
import           GHC                              hiding (exprType)
import           HscTypes
import           Id                               (mkSysLocalM)
import           Literal
import           MkCore                           (mkCoreLets)
import           Outputable
import           Var                              (varType)
import           TypeRep
import           TyCon                            (tyConDataCons_maybe)
import           DataCon                          (dataConInstArgTys)
import           VarEnv                           (VarEnv, emptyVarEnv, extendVarEnv, lookupWithDefaultVarEnv)
import           Control.Monad
import           Language.Haskell.Liquid.Fixpoint (anfPrefix)
import           Language.Haskell.Liquid.GhcMisc  (MGIModGuts(..))
import           Language.Haskell.Liquid.Misc     (fst3, errorstar)
import           Data.Maybe                       (fromMaybe)
import           Data.List                        (sortBy, (\\))

anormalize :: HscEnv -> MGIModGuts -> IO [CoreBind]
anormalize hscEnv modGuts
  = do putStrLn "***************************** GHC CoreBinds ***************************" 
       putStrLn $ showPpr orig_cbs
       liftM (fromMaybe err . snd) $ initDs hscEnv m grEnv tEnv act 
    where m        = mgi_module modGuts
          grEnv    = mgi_rdr_env modGuts
          tEnv     = modGutsTypeEnv modGuts
          act      = liftM concat $ mapM (normalizeBind emptyVarEnv) orig_cbs
          orig_cbs = mgi_binds modGuts
          err      = errorstar "anormalize fails!"

modGutsTypeEnv mg = typeEnvFromEntities ids tcs fis
  where ids = bindersOfBinds (mgi_binds mg)
        tcs = mgi_tcs mg
        fis = mgi_fam_insts mg

------------------------------------------------------------------
----------------- Actual Normalizing Functions -------------------
------------------------------------------------------------------

------------------------------------------------------------------
normalizeBind :: VarEnv Id -> CoreBind -> DsM [CoreBind]
------------------------------------------------------------------

normalizeBind γ (NonRec x e)
  = do (bs, e') <- normalize γ e
       return (bs ++ [NonRec x e'])

normalizeBind γ (Rec xes)
  = do es' <- mapM (normalize γ >=> (return . stitch)) es
       return [Rec (zip xs es')]
    where (xs, es) = unzip xes

--------------------------------------------------------------------
normalizeName :: VarEnv Id -> CoreExpr -> DsM ([CoreBind], CoreExpr)
--------------------------------------------------------------------

-- normalizeNameDebug γ e 
--   = liftM (tracePpr ("normalizeName" ++ showPpr e)) $ normalizeName γ e

normalizeName _ e@(Lit (LitInteger _ _))
  = normalizeLiteral e

normalizeName _ e@(Tick _ (Lit (LitInteger _ _)))
  = normalizeLiteral e

normalizeName γ (Var x)
  = return ([], Var (lookupWithDefaultVarEnv γ x x))

normalizeName _ e@(Type _)
  = return ([], e)

normalizeName _ e@(Lit _)
  = return ([], e)

normalizeName γ (Tick n e)
  = do (bs, e') <- normalizeName γ e
       return (bs, Tick n e')

normalizeName γ e
  = do (bs, e') <- normalize γ e
       x        <- freshNormalVar $ exprType e
       return (bs ++ [NonRec x e'], Var x)

---------------------------------------------------------------------
normalizeLiteral :: CoreExpr -> DsM ([CoreBind], CoreExpr)
---------------------------------------------------------------------

normalizeLiteral e =
  do x <- freshNormalVar (exprType e)
     return ([NonRec x e], Var x)

freshNormalVar = mkSysLocalM (fsLit anfPrefix)

---------------------------------------------------------------------
normalize :: VarEnv Id -> CoreExpr -> DsM ([CoreBind], CoreExpr)
---------------------------------------------------------------------

normalize γ (Lam x e)
  = do e' <- stitch `fmap` normalize γ e
       return ([], Lam x e')

normalize γ (Let b e)
  = do bs'        <- normalizeBind γ b
       (bs'', e') <- normalize γ e
       return ([], stitch (bs' ++ bs'', e'))
       -- return (bs' ++ bs'', e')

normalize γ (Case e x t as)
  = do (bs, n) <- normalizeName γ e
       x'      <- freshNormalVar τx -- rename "wild" to avoid shadowing
       let γ'   = extendVarEnv γ x x'
       as'     <- forM as $ \(c, xs, e') -> liftM ((c, xs,) . stitch) (normalize γ' e')
       as''    <- expandDefaultCase τx as' 
       return     (bs, Case n x' t as'')
    where τx = varType x

normalize γ (Var x)
  = return ([], Var (lookupWithDefaultVarEnv γ x x))

{'fraction_non_alphanumeric': 0.2685791297651136, 'fraction_numerical': 0.00019252984212552945, 'mean_word_length': 1.1779874213836479, 'pattern_counts': {'":': 0, '<': 29, '<?xml version=': 0, '>': 27, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 12, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4109909', 'n_tokens_mistral': 2907, 'n_tokens_neox': 2707, 'n_words': 831}