Eval.hs

{-# LANGUAGE NumericUnderscores #-}

module Test.Eval (spec) where

import qualified Data.Map as Map

import Language.PureScript.AST.Literals
import Language.PureScript.AST.SourcePos (SourceSpan(..), SourcePos(..))
import Language.PureScript.CoreFn
import Language.PureScript.DCE
import qualified Language.PureScript.DCE.Constants as C
import Language.PureScript.Names (Ident(..), ModuleName(..), Qualified(..), QualifiedBy(..))
import Language.PureScript.PSString

import Language.PureScript.DCE.Utils (showExpr)

import Test.Hspec
import Test.HUnit (assertFailure)

sp :: SourcePos
sp = SourcePos 0 0

ss :: SourceSpan
ss = SourceSpan "src/Test.purs" sp sp

ann :: Ann
ann = ssAnn ss

eq :: Qualified Ident
eq = Qualified (ByModuleName C.eqMod) (Ident "eq")

eqBoolean :: Qualified Ident
eqBoolean = Qualified (ByModuleName eqModName) (Ident "eqBoolean")

eqModName :: ModuleName
eqModName = ModuleName "Data.Eq"

mn :: ModuleName
mn = ModuleName "Test"

mp :: FilePath
mp = "src/Test.purs"

dceEvalExpr' :: Expr Ann -> [Module Ann] -> Expr Ann
dceEvalExpr' e mods = case evaluate ([testMod , eqMod , booleanMod , arrayMod, unsafeCoerceMod] ++ mods) of
    ((Module _ _ _ _ _ _ _ _ [NonRec _ _ e', _]) : _) -> e'
    _                                               -> error "not supported"
  where
  testMod = Module ss [] mn mp [] [] Map.empty []
    [ NonRec ann (Ident "v") e
    , NonRec ann (Ident "f")
        (Abs ann (Ident "x") (Var ann (Qualified (BySourcePos sp) (Ident "x"))))
    ]
  eqMod = Module ss [] C.eqMod "" [] [] Map.empty
    [ Ident "refEq" ]
    [ NonRec ann (Ident "eq")
        (Abs ann (Ident "dictEq")
          (Abs ann (Ident "x")
            (Abs ann (Ident "y")
              (Literal ann (BooleanLiteral True)))))
    , NonRec ann (Ident "eqBoolean")
        (App ann
          (Var ann (Qualified (ByModuleName C.eqMod) (Ident "Eq")))
          (Var ann (Qualified (ByModuleName C.eqMod) (Ident "refEq"))))
    , NonRec ann (Ident "Eq")
        (Abs ann (Ident "eq")
          (Literal ann (ObjectLiteral [(mkString "eq", Var ann (Qualified (BySourcePos sp) (Ident "eq")))])))
    ]
  booleanMod = Module ss [] (ModuleName "Data.Boolean") "" [] [] Map.empty []
    [ NonRec ann (Ident "otherwise") (Literal ann (BooleanLiteral True)) ]
  arrayMod = Module ss [] (ModuleName "Data.Array") ""
    [] [] Map.empty []
    [ NonRec ann (Ident "index")
        (Abs ann (Ident "as")
          (Abs ann (Ident "ix")
            (Literal ann (CharLiteral 'f'))))
    ]
  unsafeCoerceMod = Module ss [] C.unsafeCoerce ""
    [] [] Map.empty []
    [ NonRec ann (Ident "unsafeCoerce")
        (Abs ann (Ident "x")
          (Var ann (Qualified (BySourcePos sp) (Ident "x"))))
    ]

dceEvalExpr :: Expr Ann -> Expr Ann
dceEvalExpr e = dceEvalExpr' e []


-- TODO: need to generate valid `PSExpr`s.
{-
prop_eval :: PSExpr Ann -> Property
prop_eval (PSExpr g) =
  let d  = exprDepth g
      g' = dceEvalExpr g
      d' = exprDepth g'
  in
    collect (if d > 0 then 10 * (d' * 100 `div` (10 * d)) else 0)
    $ counterexample ("depth " ++ show d ++ " / " ++ show d' ++ "\n\t" ++ show g')
    $ (d' <= d)
-}


spec :: Spec
spec =
  context "evaluate" $ do
    -- specify "should evaluate" $ property $ withMaxSuccess 100_000 prop_eval
    specify "should simplify when comparing two literal values" $ do
      let v :: Expr Ann
          v =
            App ann
              (App ann
                (App ann
                  (Var ann eq)
                  (Var ann eqBoolean))
                (Literal ann (BooleanLiteral True)))
              (Literal ann (BooleanLiteral True))
          e :: Expr Ann
          e = Case ann [v]
            [ CaseAlternative
                [ LiteralBinder ann (BooleanLiteral True) ]
                (Right (Literal ann (CharLiteral 't')))
            , CaseAlternative
                [ LiteralBinder ann (BooleanLiteral False) ]
                (Right (Literal ann (CharLiteral 'f')))
            ]
      case dceEvalExpr e of
        (Literal _ (CharLiteral 't')) -> return ()
        x -> assertFailure $ "unexepcted expression:\n" ++ showExpr x
        -- Left err -> assertFailure $ "compilation error: " ++ show err

    specify "should simplify `if true`" $ do
      let e :: Expr Ann
          e = Case ann [Literal ann (BooleanLiteral True)]
            [ CaseAlternative
                [ LiteralBinder ann (BooleanLiteral True) ]
                (Right (Literal ann (CharLiteral 't')))
            , CaseAlternative
                [ LiteralBinder ann (BooleanLiteral False) ]
                (Right (Literal ann (CharLiteral 'f')))
            ]
      case dceEvalExpr e of
       (Literal _ (CharLiteral 't')) -> return ()
       x -> assertFailure $ "unexepcted expression:\n" ++ showExpr x
       -- Left err -> assertFailure $ "compilation error: " ++ show err

    specify "should simplify case when comparing two literal values" $ do
      let v :: Expr Ann
          v =
            App ann
              (App ann
                (App ann
                  (Var ann eq)
                  (Var ann eqBoolean))
                (Literal ann (BooleanLiteral True)))
              (Literal ann (BooleanLiteral True))
          e :: Expr Ann
          e = Let ann [NonRec ann (Ident "v") v]
                (Case ann [Var ann (Qualified (BySourcePos sp) (Ident "v"))]
                  [ CaseAlternative
                      [ LiteralBinder ann (BooleanLiteral True) ]
                      (Right (Literal ann (CharLiteral 't')))
                  , CaseAlternative
                      [ LiteralBinder ann (BooleanLiteral False) ]
                      (Right (Literal ann (CharLiteral 'f')))
                  ])
      case dceEvalExpr e of
        Let _ _ (Literal _ (CharLiteral 't')) -> return ()
        x -> assertFailure $ "unexpected expression:\n" ++ showExpr x
        -- Left err -> assertFailure $ "compilation error: " ++ show err

    specify "should not simplify application" $ do
      let -- f eqBoolean True True
          e :: Expr Ann
          e =
            App ann
              (App ann
                (App ann
                  (Var ann (Qualified (ByModuleName mn) (Ident "f")))
                  (Var ann eqBoolean))
                (Literal ann (BooleanLiteral True)))
              (Literal ann (BooleanLiteral True))
      case dceEvalExpr e of
        e' ->
          if showExpr e' /= showExpr e -- TODO! This is a dirty hack!
            then assertFailure $ "unexpected expression:\n" ++ showExpr e' ++ "\nexpected:\n" ++ showExpr e
            else return ()
        -- Left err -> assertFailure $ "compilation error: " ++ show err

    specify "eval guards" $ do
      let e :: Expr Ann
          e = Case ann [Literal ann (BooleanLiteral True)]
            [ CaseAlternative
              [ VarBinder ann (Ident "x") ]
                (Left
                  [ (App ann
                      (App ann
                        (App ann
                          (Var ann eq)
                          (Var ann eqBoolean))
                        (Var ann (Qualified (BySourcePos sp) (Ident "x"))))
                      (Literal ann (BooleanLiteral True))
                    , Literal ann (CharLiteral 't'))
                  , ( Var ann (Qualified (ByModuleName (ModuleName "Data.Boolean")) (Ident "otherwise"))
                    , (Literal ann (CharLiteral 'f'))
                    )
                  ])
              ]
      case dceEvalExpr e of
        (Case _
          [ Literal _ (BooleanLiteral True)]
          [ CaseAlternative
              [ VarBinder _ (Ident "x") ]
              (Left [ (Literal _ (BooleanLiteral True), Literal _ (CharLiteral 't')) ])
          ]
          ) -> return ()
        x   -> assertFailure $ "unexpected expression:\n" ++ showExpr x
        -- Left err  -> assertFailure $ "compilation error: " ++ show err

    specify "should evaluate exported literal" $ do
      let um :: Module Ann
          um = Module ss []
            (ModuleName "Utils")
            "src/Utils.purs"
            []
            [Ident "isProduction"]
            Map.empty
            []
            [NonRec ann (Ident "isProduction") (Literal ann (BooleanLiteral True))]
          e :: Expr Ann
          e = Case ann
            [ Var ann (Qualified (ByModuleName (ModuleName "Utils")) (Ident "isProduction"))]
            [ CaseAlternative [LiteralBinder ann (BooleanLiteral True)] (Right (Literal ann (CharLiteral 't')))
            , CaseAlternative [LiteralBinder ann (BooleanLiteral False)] (Right (Literal ann (CharLiteral 'f')))
            ]
          mm :: Module Ann
          mm = Module
            ss
            []
            (ModuleName "Main")
            "src/Main.purs"
            []
            []
            Map.empty
            []
            [NonRec ann (Ident "main") e]
      -- TODO
      case evaluate [mm, um] of
        ((Module _ _ _ _ _ _ _ _ [NonRec _ (Ident "main") (Literal _ (CharLiteral 't'))]) : _) -> return ()
        r -> assertFailure $ "unexpected result:\n" ++ show r
        -- Left err -> assertFailure $ "compilation error: " ++ show err

    specify "should evaluate accessor expression" $ do
      let e :: Expr Ann
          e = (Accessor ann (mkString "a") (Literal ann (ObjectLiteral [(mkString "a", Literal ann (CharLiteral 't'))])))
      case dceEvalExpr e of
        (Literal _ (CharLiteral 't')) -> return ()
        x -> assertFailure $ "unexpected expression:\n" ++ showExpr x
        -- Left err -> assertFailure $ "compilation error: " ++ show err

    specify "should evaluate accessing array by index" $ do
      let e :: Expr Ann
          e = (App ann
                (App ann
                  (Var ann (Qualified (ByModuleName (ModuleName "Data.Array")) (Ident "index")))
                  (Literal ann (ArrayLiteral [Literal ann (CharLiteral 't')])))
                (Literal ann (NumericLiteral (Left 0))))
      case dceEvalExpr e of
        (App _ (Var _ (Qualified (ByModuleName (ModuleName "Data.Maybe")) (Ident "Just"))) (Literal _ (CharLiteral 't'))) -> return ()
        x -> assertFailure $ "unexpected expression:\n" ++ showExpr x
        -- Left err -> assertFailure $ "compilation error: " ++ show err

    context "context stack" $ do
      specify "nested let bindings" $ do
        let -- let a = 'a'
            -- in let a = 'b'
            --    in a
            e :: Expr Ann
            e = Let ann [ NonRec ann (Ident "a") (Literal ann (CharLiteral 'a')) ]
                  (Let ann [ NonRec ann (Ident "a") (Literal ann (CharLiteral 'b')) ]
                    (Var ann (Qualified (BySourcePos sp) (Ident "a"))))
        case dceEvalExpr e of
          Let _ _ (Let _ _ (Literal _ (CharLiteral 'b'))) -> return ()
          x -> assertFailure $ "unexpected expression:\n" ++ showExpr x
          -- Left err -> assertFailure $ "compilation error: " ++ show err

    context "Var inlining" $ do
      let oModName = ModuleName "Other"
          oMod = Module ss [] oModName "" [] [] Map.empty []
            [ NonRec ann (Ident "o") $ Literal ann (ObjectLiteral [(mkString "a", Var ann (Qualified (ByModuleName C.eqMod) (Ident "eq"))) ])
            , NonRec ann (Ident "a") $ Literal ann (ArrayLiteral [ Var ann (Qualified (ByModuleName C.eqMod) (Ident "eq")) ])
            , NonRec ann (Ident "s") $ Literal ann (StringLiteral (mkString "very-long-string"))
            , NonRec ann (Ident "b") $ Literal ann (BooleanLiteral True)
            , NonRec ann (Ident "c") $ Literal ann (CharLiteral 'a')
            , NonRec ann (Ident "n") $ Literal ann (NumericLiteral (Left 0))
            ]
      specify "should not inline Var linking to an object literal" $ do
        let e :: Expr Ann
            e = Var ann (Qualified (ByModuleName oModName) (Ident "o"))
        case dceEvalExpr' e [oMod] of
          Var{} -> return ()
          e' -> assertFailure $ "unexpected expression: " ++ showExpr e'
          -- Left err -> assertFailure $ "compilation error: " ++ show err

      specify "should not inline Var linking to an array literal" $ do
        let e :: Expr Ann
            e = Var ann (Qualified (ByModuleName oModName) (Ident "a"))
        case dceEvalExpr' e [oMod] of
          Var{} -> return ()
          e' -> assertFailure $ "unexpected expression: " ++ showExpr e'
          -- Left err -> assertFailure $ "compilation error: " ++ show err

      specify "should not inline Var linking to a string literal" $ do
        let e :: Expr Ann
            e = Var ann (Qualified (ByModuleName oModName) (Ident "s"))
        case dceEvalExpr' e [oMod] of
          Var{} -> return ()
          e' -> assertFailure $ "unexpected expression: " ++ showExpr e'
          -- Left err -> assertFailure $ "compilation error: " ++ show err

      specify "should inline Var lining to a boolean literal" $ do
        let e :: Expr Ann
            e = Var ann (Qualified (ByModuleName oModName) (Ident "b"))
        case dceEvalExpr' e [oMod] of
          (Literal _ (BooleanLiteral{})) -> return ()
          e' -> assertFailure $ "wront expression: " ++ showExpr e'
          -- Left err -> assertFailure $ "compilation error: " ++ show err

      specify "should inline Var lining to a char literal" $ do
        let e :: Expr Ann
            e = Var ann (Qualified (ByModuleName oModName) (Ident "c"))
        case dceEvalExpr' e [oMod] of
          (Literal _ (CharLiteral{})) -> return ()
          e' -> assertFailure $ "wront expression: " ++ showExpr e'
          -- Left err -> assertFailure $ "compilation error: " ++ show err

      specify "should inline Var lining to a numeric literal" $ do
        let e :: Expr Ann
            e = Var ann (Qualified (ByModuleName oModName) (Ident "n"))
        case dceEvalExpr' e [oMod] of
          (Literal _ (NumericLiteral{})) -> return ()
          e' -> assertFailure $ "wront expression: " ++ showExpr e'
          -- Left err -> assertFailure $ "compilation error: " ++ show err