<commit_before>{-# LANGUAGE FlexibleInstances #-}

module Pyrec.CheckSpec where

import           Prelude                  hiding (map, mapM)

import           Control.Applicative
import           Control.Monad            hiding (mapM)
import           Control.Monad.Writer     hiding (mapM, sequence)

import           Data.Traversable         hiding (for, sequence)

import           Text.Parsec.Error

import           Control.Monad         (mzero)

import           Test.Hspec
import           Test.Hspec.QuickCheck (prop)
import           Test.QuickCheck       hiding ((.&.))

import           Pyrec.Misc
import           Pyrec.Error
import           Pyrec.PrettyPrint

import           Pyrec

import qualified Pyrec.AST        as A

import           Pyrec.IR

import qualified Pyrec.IR.Desugar as D
import qualified Pyrec.IR.Core    as R

import qualified Pyrec.Parse      as P
import qualified Pyrec.Desugar    as D
import qualified Pyrec.Check      as C
import qualified Pyrec.Report     as R
import qualified Pyrec.Compile    as O
import qualified Pyrec.Emit       as E


{-

e l = D.E (pos l) TUnknown

eLet l n v i = Let (Def Val (D.BT (pos l) n TUnknown) v) i
eVar l n v i = Let (Def Var (D.BT (pos l) n TUnknown) v) i
eSeq     v i = Let (Def Val (D.BT (pos 0) "$temp" TUnknown) v) i

prog1 = e 1 $ eLet 2 "x" (e 3 $ Num 55) $ e 2 $ Ident "x"

prog2 = e 1 $ eVar 2 "x" (e 3 $ Num 55)
            $ e 4 $ eSeq (e 6 $ Assign "x" $ e 7 $ Num 37)
                  $ e 8 $ Ident "x"

prog3 = e 1 $ App (e 2 $ Ident "f") $ map (\a -> e (round a) $ Num a) [1..4]
env3  = M.singleton "f" $ Def Val (D.BT (pos 9) "f" $ T $ TFun (replicate 4 $ T $ TIdent "Number") $ T $ TIdent "String") ()

prog4 = e 1 $ eLet 2 "x" (e 3 $ Num 77)
            $ e 4 $ App (e 5 $ Ident "@pyretTimes") [e 6 $ Ident "x", e 7 $ Num 33]
-}

strip (D.E          l t e) = D.E l t $ strip <$> e
strip (D.Constraint _ _ e) = strip e

pd :: String -> Either ParseError (D.Expr, [D.ErrorMessage])
pd = runWriter <.> parseDesugar

testInfer :: C.Env -> String -> Either ParseError (Bool, R.Expr, R.Expr,
                                                   [R.ErrorMessage],
                                                   [R.ErrorMessage],
                                                   [R.ErrorMessage])
testInfer env src = for (pd src) $ \case
  (e, errors) -> (e1' == e2', e1', e2', errors', e1r, e2r)
    where errors'    = (fmap . fmap) R.Earlier errors
          (e1', e1r) = runWriter $ checkReport env e
          (e2', e2r) = runWriter $ checkReport env $ strip e

noErrors ::
  Either ParseError (Bool, R.Expr, R.Expr,
                     [R.ErrorMessage],
                     [R.ErrorMessage],
                     [R.ErrorMessage]) -> Bool
noErrors = \case
  (Right (_, _, _, [], [], [])) -> True
  _                             -> False


instance Show R.Expr where
  show = pp

instance Show (Pyrec.Error.Message R.Error) where
  show = pp

spec :: Spec
spec = do
  describe "the type checker" $ do

    it "accepts the identity function" $
      testInfer env "fun<A>(x :: A): x;" `shouldSatisfy` noErrors
<commit_msg>Added tests relating to typing literals<commit_after>{-# LANGUAGE FlexibleInstances #-}

module Pyrec.CheckSpec where

import           Prelude                  hiding (map, mapM)

import           Control.Applicative
import           Control.Monad            hiding (mapM)
import           Control.Monad.Writer     hiding (mapM, sequence)

import           Data.Traversable         hiding (for, sequence)

import           Text.Parsec.Error

import           Control.Monad         (mzero)

import           Test.Hspec
import           Test.Hspec.QuickCheck (prop)
import           Test.QuickCheck       hiding ((.&.))

import           Pyrec.Misc
import           Pyrec.Error
import           Pyrec.PrettyPrint

import           Pyrec

import qualified Pyrec.AST        as A

import           Pyrec.IR

import qualified Pyrec.IR.Desugar as D
import qualified Pyrec.IR.Core    as R

import qualified Pyrec.Parse      as P
import qualified Pyrec.Desugar    as D
import qualified Pyrec.Check      as C
import qualified Pyrec.Report     as R
import qualified Pyrec.Compile    as O
import qualified Pyrec.Emit       as E


{-

e l = D.E (pos l) TUnknown

eLet l n v i = Let (Def Val (D.BT (pos l) n TUnknown) v) i
eVar l n v i = Let (Def Var (D.BT (pos l) n TUnknown) v) i
eSeq     v i = Let (Def Val (D.BT (pos 0) "$temp" TUnknown) v) i

prog1 = e 1 $ eLet 2 "x" (e 3 $ Num 55) $ e 2 $ Ident "x"

prog2 = e 1 $ eVar 2 "x" (e 3 $ Num 55)
            $ e 4 $ eSeq (e 6 $ Assign "x" $ e 7 $ Num 37)
                  $ e 8 $ Ident "x"

prog3 = e 1 $ App (e 2 $ Ident "f") $ map (\a -> e (round a) $ Num a) [1..4]
env3  = M.singleton "f" $ Def Val (D.BT (pos 9) "f" $ T $ TFun (replicate 4 $ T $ TIdent "Number") $ T $ TIdent "String") ()

prog4 = e 1 $ eLet 2 "x" (e 3 $ Num 77)
            $ e 4 $ App (e 5 $ Ident "@pyretTimes") [e 6 $ Ident "x", e 7 $ Num 33]
-}

strip (D.E          l t e) = D.E l t $ strip <$> e
strip (D.Constraint _ _ e) = strip e

pd :: String -> Either ParseError (D.Expr, [D.ErrorMessage])
pd = runWriter <.> parseDesugar

testInfer :: C.Env -> String -> Either ParseError (Bool, R.Expr, R.Expr,
                                                   [R.ErrorMessage],
                                                   [R.ErrorMessage],
                                                   [R.ErrorMessage])
testInfer env src = for (pd src) $ \case
  (e, errors) -> (e1' == e2', e1', e2', errors', e1r, e2r)
    where errors'    = (fmap . fmap) R.Earlier errors
          (e1', e1r) = runWriter $ checkReport env e
          (e2', e2r) = runWriter $ checkReport env $ strip e

noErrors ::
  Either ParseError (Bool, R.Expr, R.Expr,
                     [R.ErrorMessage],
                     [R.ErrorMessage],
                     [R.ErrorMessage]) -> Bool
noErrors = \case
  (Right (_, _, _, [], [], [])) -> True
  _                             -> False

fillsOutConstraints = \case
  (Right (b, _, _, _, _, _)) -> b
  _                          -> False


instance Show R.Expr where
  show = pp

instance Show (Pyrec.Error.Message R.Error) where
  show = pp

spec :: Spec
spec = do
  describe "the type checker" $ do

    it "type checks literal number" $
      property $ \(num :: Double) -> fillsOutConstraints $ testInfer env $ "(" ++ show num ++ " :: Number)"

    it "type checks literal string" $
      property $ \(num :: String) -> fillsOutConstraints $ testInfer env $ "(" ++ show num ++ " :: String)"

    it "accepts the identity function" $
      testInfer env "fun<A>(x :: A): x;" `shouldSatisfy` noErrors

{'fraction_non_alphanumeric': 0.11829249962422968, 'fraction_numerical': 0.015030813166992334, 'mean_word_length': 1.7427864798021435, 'pattern_counts': {'":': 0, '<': 9, '<?xml version=': 0, '>': 29, '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': '2997096', 'n_tokens_mistral': 2228, 'n_tokens_neox': 2132, 'n_words': 763}