CoreFn.hs

module Test.CoreFn (spec)  where

import Data.List (foldl', intersect)
import qualified Data.List as L

import Language.PureScript.AST.Literals
import Language.PureScript.AST.SourcePos (SourceSpan (..), SourcePos (..))
import Language.PureScript.CoreFn
import Language.PureScript.DCE
import Language.PureScript.Names (Ident (..), Qualified (..), QualifiedBy (..))
import Language.PureScript.PSString

import Test.Hspec
import Test.QuickCheck

import Test.Generators hiding (ann)


getNames :: Bind a -> [Ident]
getNames (NonRec _ i _) = [i]
getNames (Rec l) = (\((_, i), _) -> i) `map` l

hasIdent :: Ident -> [Bind Ann] -> Bool
hasIdent i = (i `elem`) . concatMap getNames

sp :: SourcePos
sp = SourcePos 0 0

ann :: Ann
ann = ssAnn (SourceSpan "src/Test.purs" sp sp)

prop_exprDepth :: PSExpr Ann -> Property
prop_exprDepth (PSExpr e) =
  let b = NonRec ann (Ident "x") e
      e' = case runBindDeadCodeElimination b of
        NonRec _ _ a -> a
        _ -> error "runBindDeadCodeElimination: recursive binds are unsupported"
      d  = exprDepth e
      d' = exprDepth e'
  in collect (10 * (d' * 100 `div` (10 * d)))
    $ counterexample (show e)
    $ d' <= d

prop_lets :: PSExpr Ann -> Property
prop_lets (PSExpr f) =
  let b = NonRec ann (Ident "x") f
      f' = case runBindDeadCodeElimination b of
        NonRec _ _ a -> a
        _ -> error "runBindDeadCodeElimination: recursive binds are unsupported"
      d  = countLets f
      d' = countLets f'
      idents = findBindIdents f'
  in label ((if d > 0 then show (10 * ((d' * 100 `div` d) `div` 10)) ++ "%" else "-") ++ " of removed let bindings")
    $ counterexample (show f)
    $  d' <= d
    && L.null (intersect idents unusedIdents)
  where
  countLets :: Expr a -> Int
  countLets (Literal _ (ArrayLiteral es)) = foldl' (\x e -> x + countLets e) 0 es
  countLets (Literal _ (ObjectLiteral o)) = foldl' (\x (_, e) -> x + countLets e) 0 o
  countLets Literal{} = 0
  countLets Constructor{} = 0
  countLets (Accessor _ _ e) = countLets e
  countLets (ObjectUpdate _ e o) = countLets e + foldl' (\x (_, e') -> x + countLets e') 0 o
  countLets (Abs _ _ e) = countLets e
  countLets (App _ e f') = countLets e + countLets f'
  countLets Var{} = 0
  countLets (Case _ es cs) = foldl' (\x e -> x + countLets e) 0 es + foldl countLetsInCaseAlternative 0 cs
    where
    countLetsInCaseAlternative x (CaseAlternative _ r) = 
      x + either (foldl' (\y (g, e) -> y + countLets g + countLets e) 0) countLets r
  countLets (Let _ _ e) = 1 + countLets e

  findBindIdents :: Expr a -> [Ident]
  findBindIdents (Literal _ (ArrayLiteral es)) = concatMap findBindIdents es
  findBindIdents (Literal _ (ObjectLiteral o)) = concatMap (findBindIdents . snd) o
  findBindIdents Literal{} = []
  findBindIdents Constructor{} = []
  findBindIdents (Accessor _ _ e) = findBindIdents e
  findBindIdents (ObjectUpdate _ e o) = findBindIdents e ++ concatMap (findBindIdents . snd) o
  findBindIdents (Abs _ _ e) = findBindIdents e
  findBindIdents (App _ e f') = findBindIdents e ++ findBindIdents f'
  findBindIdents Var{} = []
  findBindIdents (Case _ es cs) = concatMap findBindIdents es ++ concatMap countLetsInCaseAlternative cs
    where
    countLetsInCaseAlternative (CaseAlternative _ r) = 
      either (concatMap (\(g, e1) -> findBindIdents g ++ findBindIdents e1)) findBindIdents r
  findBindIdents (Let _ bs e) = concatMap fn bs ++ findBindIdents e
    where
    fn (NonRec _ i e1) = i : findBindIdents e1
    fn (Rec as)        = foldl' (\acc ((_, i), e1) -> i : findBindIdents e1 ++ acc) [] as

spec :: Spec
spec = do
  context "generators" $ do
    specify "should generate Expr" $ property $ prop_exprDistribution
  context "corefn" $ 
    context "runBindDeadCodeElimination" $ do
      specify "should reduce the depth of the tree" $ property $ withMaxSuccess 10000 prop_exprDepth
      specify "should reduce the number of let bindings" $ property $ withMaxSuccess 10000 prop_lets
      specify "should remove unused identifier" $ do
        let e :: Expr Ann
            e = Let ann
                  [ NonRec ann (Ident "notUsed") (Literal ann (CharLiteral 'a'))
                  , NonRec ann (Ident "used") (Literal ann (CharLiteral 'b'))
                  ]
                  (Var ann (Qualified (BySourcePos sp) (Ident "used")))
        case runBindDeadCodeElimination (NonRec ann (Ident "v") e) of
          NonRec _ _ (Let _ bs _) -> do
            bs `shouldSatisfy` not . hasIdent (Ident "notUsed")
            bs `shouldSatisfy` hasIdent (Ident "used")
          _ -> return ()

      specify "should not remove transitive dependency" $ do
        let e :: Expr Ann
            e = Let ann
                  [ NonRec ann (Ident "used") (Abs ann (Ident "x") (Var ann (Qualified (BySourcePos sp) (Ident "trDep"))))
                  , NonRec ann (Ident "trDep") (Literal ann (CharLiteral 'a'))
                  ]
                  (Var ann (Qualified (BySourcePos sp) (Ident "used")))
        case runBindDeadCodeElimination (NonRec ann (Ident "v") e) of
          NonRec _ _ (Let _ bs _) -> do
            bs `shouldSatisfy` hasIdent (Ident "trDep")
            bs `shouldSatisfy` hasIdent (Ident "used")
          _ -> return ()

      specify "should include all used recursive binds" $ do
        let e :: Expr Ann
            e = Let ann
                  [ NonRec ann (Ident "entry") (Abs ann (Ident "x") (Var ann (Qualified (BySourcePos sp) (Ident "mutDep1"))))
                  , Rec
                    [ ((ann, Ident "mutDep1"), Abs ann (Ident "x") (Var ann (Qualified (BySourcePos sp) (Ident "mutDep2"))))
                    , ((ann, Ident "mutDep2"), Abs ann (Ident "x") (Var ann (Qualified (BySourcePos sp) (Ident "mutDep1"))))
                    ]
                  ]
                  (App ann (Var ann (Qualified (BySourcePos sp) (Ident "entry"))) (Literal ann (CharLiteral 'a')))
        case runBindDeadCodeElimination (NonRec ann (Ident "v") e) of
          NonRec _ _ (Let _ bs _) -> do
            bs `shouldSatisfy` hasIdent (Ident "entry")
            bs `shouldSatisfy` hasIdent (Ident "mutDep1")
            bs `shouldSatisfy` hasIdent (Ident "mutDep2")
          _ -> return ()

      specify "should dce case expressions" $ do
        let e :: Expr Ann
            e = Let ann
                  [ NonRec ann (Ident "usedInExpr") (Literal ann (CharLiteral 'a'))
                  , NonRec ann (Ident "notUsed") (Literal ann (CharLiteral 'a'))
                  , NonRec ann (Ident "usedInGuard") (Literal ann (CharLiteral 'a'))
                  , NonRec ann (Ident "usedInResult1") (Literal ann (CharLiteral 'a'))
                  , NonRec ann (Ident "usedInResult2") (Literal ann (CharLiteral 'a'))
                  ]
                  (Case ann
                    [Var ann (Qualified (BySourcePos sp) (Ident "usedInExpr"))]
                    [ CaseAlternative
                        [NullBinder ann]
                        (Left
                          [ ( Var ann (Qualified (BySourcePos sp) (Ident "usedInGuard"))
                            , Var ann (Qualified (BySourcePos sp) (Ident "usedInResult1"))
                            )
                          ])
                    , CaseAlternative
                        [NullBinder ann]
                        (Right $ Var ann (Qualified (BySourcePos sp) (Ident "usedInResult2")))
                    ])
        case runBindDeadCodeElimination (NonRec ann (Ident "v") e) of
          NonRec _ _ (Let _ bs _) -> do
            bs `shouldSatisfy` hasIdent (Ident "usedInExpr")
            bs `shouldSatisfy` not . hasIdent (Ident "notUsed")
            bs `shouldSatisfy` hasIdent (Ident "usedInGuard")
            bs `shouldSatisfy` hasIdent (Ident "usedInResult1")
            bs `shouldSatisfy` hasIdent (Ident "usedInResult2")
          _ -> return ()

      specify "should not remove shadowed identifiers" $ do
        let e :: Expr Ann
            e = Let ann
                  [ NonRec ann (Ident "shadow") (Literal ann (CharLiteral 'a'))
                  , NonRec ann (Ident "sunny") (Literal ann (CharLiteral 'a'))
                  ]
                  $ Let ann
                    [ NonRec ann (Ident "shadow") (Literal ann (CharLiteral 'a')) ]
                    $ Literal ann
                      $ ObjectLiteral 
                        [ ( mkString "a", Var ann (Qualified (BySourcePos sp) (Ident "shadow")) )
                        , ( mkString "b", Var ann (Qualified (BySourcePos sp) (Ident "sunny")) )
                        ]
        case runBindDeadCodeElimination (NonRec ann (Ident "v") e) of
          NonRec _ _ (Let _ bs (Let _ cs _)) -> do
            bs `shouldSatisfy` hasIdent (Ident "sunny")
            bs `shouldSatisfy` not . hasIdent (Ident "shadow")
            cs `shouldSatisfy` hasIdent (Ident "shadow")
          _ -> error "runBindDeadCodeElimination: recursive binds are unsupported"