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

module Language.Haskell.Liquid.TransformRec (
     transformRecExpr, transformScope
     ) where

import           Bag
import           Coercion
import           Control.Arrow       (second, (***))
import           Control.Monad.State
import           CoreLint
import           CoreSyn
import           CoreSubst
import qualified Data.HashMap.Strict as M
import           ErrUtils
import           Id                  (idOccInfo, setIdInfo)
import           IdInfo
import           MkCore              (mkCoreLams)
import           SrcLoc
import           Type                (mkForAllTys)
import           TypeRep
import           Unique              hiding (deriveUnique)
import           Var
import           Language.Haskell.Liquid.GhcMisc
import           Language.Haskell.Liquid.Misc (mapSndM)
import           Language.Fixpoint.Misc       (mapSnd)

import           Data.List                (foldl', isInfixOf)
import           Control.Applicative      ((<$>))

import qualified Data.List as L

transformRecExpr :: CoreProgram -> CoreProgram
transformRecExpr cbs
  | isEmptyBag $ filterBag isTypeError e
  =  {-trace "new cbs"-} pg 
  | otherwise 
  = error (showPpr pg ++ "Type-check" ++ showSDoc (pprMessageBag e))
  where pg0    = evalState (transPg cbs) initEnv
        (_, e) = lintCoreBindings [] pg
        pg     = inlineFailCases pg0


inlineFailCases pg = substExpr [] su pg'
  where 
    (pg', su) = runState act emptySubst
    act       = mapM (go []) pg 
    go su (Rec xes)    = Rec (mapSnd (go' su) <$> xes)
    go su (NonRec x e) = NonRec x (go' su e)

    go' su (App (Var x) _)       | isFailId x, Just e <- getFailExpr x su = e  
    go' su (Let (NonRec x ex) e) | isFailId x   = go' (addFailExpr x ex su) e

    go' su (App e1 e2)      = App (go' su e1) (go' su e2)
    go' su (Lam x e)        = Lam x (go' su e)
    go' su (Let xs e)       = Let (go su xs) (go' su e)
    go' su (Case e x t alt) = Case (go' su e) x t (goalt su <$> alt) 
    go' su (Cast e c)       = Cast (go' su e) c
    go' su (Tick t e)       = Tick t (go' su e)
    go' su e = e

    goalt su (c, xs, e)     = (c, xs, go' su e)

    isFailId x  = isLocalId x && L.isPrefixOf "fail" (show x)
    getFailExpr = L.lookup

    addFailExpr x (Lam _ e) su = (x, e):su 
    addFailExpr x e         _  = error "Internal Error"

isTypeError s | isInfixOf "Non term variable" (showSDoc s) = False
isTypeError _ = True

scopeTr = outerScTr . innerScTr
transformScope = outerScTr . innerScTr

outerScTr = mapNonRec (go [])
  where<commit_msg>minor<commit_after>{-# LANGUAGE DeriveDataTypeable        #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TupleSections             #-}
{-# LANGUAGE TypeSynonymInstances      #-}

module Language.Haskell.Liquid.TransformRec (
     transformRecExpr, transformScope
     ) where

import           Bag
import           Coercion
import           Control.Arrow       (second, (***))
import           Control.Monad.State
import           CoreLint
import           CoreSyn
import qualified Data.HashMap.Strict as M
import           ErrUtils
import           Id                  (idOccInfo, setIdInfo)
import           IdInfo
import           MkCore              (mkCoreLams)
import           SrcLoc
import           Type                (mkForAllTys)
import           TypeRep
import           Unique              hiding (deriveUnique)
import           Var
import           Language.Haskell.Liquid.GhcMisc
import           Language.Haskell.Liquid.Misc (mapSndM)
import           Language.Fixpoint.Misc       (mapSnd)

import           Data.List                (foldl', isInfixOf)
import           Control.Applicative      ((<$>))

import qualified Data.List as L

transformRecExpr :: CoreProgram -> CoreProgram
transformRecExpr cbs
  | isEmptyBag $ filterBag isTypeError e
  =  {-trace "new cbs"-} pg 
  | otherwise 
  = error (showPpr pg ++ "Type-check" ++ showSDoc (pprMessageBag e))
  where pg0    = evalState (transPg cbs) initEnv
        (_, e) = lintCoreBindings [] pg
        pg     = inlineFailCases pg0


inlineFailCases :: CoreProgram -> CoreProgram
inlineFailCases = (go [] <$>)
  where 
    go su (Rec xes)    = Rec (mapSnd (go' su) <$> xes)
    go su (NonRec x e) = NonRec x (go' su e)

    go' su (App (Var x) _)       | isFailId x, Just e <- getFailExpr x su = e  
    go' su (Let (NonRec x ex) e) | isFailId x   = go' (addFailExpr x ex su) (go' su e)

    go' su (App e1 e2)      = App (go' su e1) (go' su e2)
    go' su (Lam x e)        = Lam x (go' su e)
    go' su (Let xs e)       = Let (go su xs) (go' su e)
    go' su (Case e x t alt) = Case (go' su e) x t (goalt su <$> alt) 
    go' su (Cast e c)       = Cast (go' su e) c
    go' su (Tick t e)       = Tick t (go' su e)
    go' su e                = e

    goalt su (c, xs, e)     = (c, xs, go' su e)

    isFailId x  = isLocalId x && L.isPrefixOf "fail" (show x)
    getFailExpr = L.lookup

    addFailExpr x (Lam _ e) su = (x, e):su 
    addFailExpr x e         _  = error "internal error" -- this cannot happen

isTypeError s | isInfixOf "Non term variable" (showSDoc s) = False
isTypeError _ = True

scopeTr = outerScTr . innerScTr
transformScope = outerScTr . innerScTr

outerScTr = mapNonRec (go [])
  where
{'fraction_non_alphanumeric': 0.10087797885683569, 'fraction_numerical': 0.002150152302454757, 'mean_word_length': 1.9425408539799685, 'pattern_counts': {'":': 0, '<': 12, '<?xml version=': 0, '>': 13, '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': '5272995', 'n_tokens_mistral': 1934, 'n_tokens_neox': 1873, 'n_words': 602}