Programs.hs

{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}

-- | Tests of medium size, defined by terminating within a certain number of
-- steps (configured in 'defSpec').

-- These tests will be run with garbage collection enabled, and should have the
-- scope of small functions a Haskell beginner might play around with.
module Test.Machine.Evaluate.Programs (tests) where



import Data.Foldable

import           Stg.Machine.Types
import           Stg.Marshal
import           Stg.Parser.QuasiQuoter
import qualified Stg.Prelude            as Stg

import           Test.Machine.Evaluate.TestTemplates.MachineState
import qualified Test.Machine.Evaluate.TestTemplates.MarshalledValue as MVal
import           Test.Machine.Evaluate.TestTemplates.Util
import           Test.Orphans                                        ()
import           Test.QuickCheck.Modifiers
import           Test.Tasty



tests :: TestTree
tests = testGroup "Programs"
    [ add3
    , takeRepeat
    , fibonacci
    , testGroup "mean of a list"
        [ meanNaive
        , meanNaiveWithFoldl'
        , meanGood ]
    ]

add3 :: TestTree
add3 = machineStateTest defSpec
    { testName = "add3 x y z = x+y+z"
    , successPredicate = "main" `hasValue` (6 :: Integer)
    , source = [stg|
        add3 = \x y z -> case x of
            Int# i -> case y of
                Int# j -> case +# i j of
                    ij -> case z of
                        Int# k -> case +# ij k of
                            ijk -> Int# ijk;
                        badInt -> Error_add3_1 badInt;
                badInt -> Error_add3_2 badInt;
            badInt -> Error_add3_3 badInt;

        one   = \ -> Int# 1#;
        two   = \ -> Int# 2#;
        three = \ -> Int# 3#;
        main = \ => add3 one two three
        |] }

takeRepeat :: TestTree
takeRepeat = machineStateTest defSpec
    { testName = "take 2 (repeat ())"
    , successPredicate = "twoUnits" `hasValue` replicate 2 ()
    , source = mconcat
        [ toStg "two" (2 :: Integer)
        , Stg.take
        , Stg.repeat
        , Stg.foldr
        , Stg.force
        , [stg|
        consBang = \x xs -> case xs of v -> Cons x v;
        nil = \ -> Nil;
        forceSpine = \xs -> foldr consBang nil xs;

        twoUnits = \ =>
            letrec
                repeated = \(unit) => repeat unit;
                unit = \ -> Unit;
                take2 = \(repeated) => take two repeated
            in forceSpine take2;

        main = \ -> force twoUnits
        |] ]}

fibonacci :: TestTree
fibonacci = machineStateTest defSpec
    { testName = "Fibonacci sequence"
    , successPredicate = "main" `hasValue` take numFibos fibo
    , maxSteps = 10000
    , source = mconcat
        [ toStg "zero" (0 :: Int)
        , toStg "one" (1 :: Int)
        , toStg "numFibos" (numFibos :: Int)
        , Stg.add
        , Stg.take
        , Stg.zipWith
        , Stg.force
        , [stg|
        main = \ =>
            letrec
                fibos = \(fibo) => take numFibos fibo;
                fibo = \ =>
                    letrec
                        fib0 = \(fib1) -> Cons zero fib1;
                        fib1 = \(fib2) -> Cons one fib2;
                        fib2 = \(fib0 fib1) => zipWith add fib0 fib1
                    in fib0
            in force fibos
        |] ]}
  where
    fibo :: [Integer]
    fibo = 0 : 1 : zipWith (+) fibo (tail fibo)
    numFibos :: Num a => a
    numFibos = 10

meanTestTemplate :: MVal.MarshalledValueTestSpec (NonEmptyList Integer) Integer
meanTestTemplate =
    let mean :: [Integer] -> Integer
        mean xs = let (total, count) = foldl' go (0,0) xs
                      go (!t, !c) x = (t+x, c+1)
                  in total `div` count
    in MVal.MarshalledValueTestSpec
        { MVal.testName = "Mena test template"
        , MVal.maxSteps = 1024
        , MVal.failWithInfo = False
        , MVal.failPredicate = const False
        , MVal.sourceSpec = \(NonEmpty inputList) -> MVal.MarshalSourceSpec
            { MVal.resultVar = "main"
            , MVal.expectedValue = mean inputList
            , MVal.source = mconcat
                [ Stg.add
                , Stg.div
                , toStg "zero" (0 :: Int)
                , toStg "one"  (1 :: Int)
                , toStg "inputList" inputList
                , [stg| main = \ => mean inputList |] ]}}

meanNaive :: TestTree
meanNaive = MVal.marshalledValueTest meanTestTemplate
    { MVal.testName = "Naïve: foldl and lazy tuple"
    , MVal.sourceSpec = \inputList -> (MVal.sourceSpec meanTestTemplate inputList)
        { MVal.source = mconcat
            [ MVal.source (MVal.sourceSpec meanTestTemplate inputList)
            , Stg.foldl
            , [stg|
            mean = \xs ->
                letrec
                    totals = \(go zeroTuple) -> foldl go zeroTuple;
                    zeroTuple = \ -> Tuple zero zero;
                    go = \acc x -> case acc of
                        Tuple t n ->
                            let tx = \(t x) => add t x;
                                n1 = \(n) => add n one
                            in Tuple tx n1;
                        badTuple -> Error_mean1 badTuple
                in case totals xs of
                    Tuple t n -> div t n;
                    badTuple -> Error_mean2 badTuple
            |] ]}}

meanNaiveWithFoldl' :: TestTree
meanNaiveWithFoldl' = MVal.marshalledValueTest meanTestTemplate
    { MVal.testName = "Naïve with insufficient optimization: foldl'"
    , MVal.sourceSpec = \inputList -> (MVal.sourceSpec meanTestTemplate inputList)
        { MVal.source = mconcat
            [ MVal.source (MVal.sourceSpec meanTestTemplate inputList)
            , Stg.foldl'
            , [stg|
            mean = \xs ->
                letrec
                    totals = \(go zeroTuple) -> foldl' go zeroTuple;
                    zeroTuple = \ -> Tuple zero zero;
                    go = \acc x -> case acc of
                        Tuple t n ->
                            let tx = \(t x) => add t x;
                                n1 = \(n) => add n one
                            in Tuple tx n1;
                        badTuple -> Error_mean1 badTuple
                in case totals xs of
                    Tuple t n -> div t n;
                    badTuple -> Error_mean2 badTuple
            |] ]}}

meanGood :: TestTree
meanGood = MVal.marshalledValueTest meanTestTemplate
    { MVal.testName = "Proper: foldl' and strict tuple"
    , MVal.failWithInfo = False
    , MVal.failPredicate = \stgState -> length (stgStack stgState) >= 9
    , MVal.sourceSpec = \inputList -> (MVal.sourceSpec meanTestTemplate inputList)
        { MVal.source = mconcat
            [ MVal.source (MVal.sourceSpec meanTestTemplate inputList)
            , Stg.foldl'
            , [stg|
            mean = \xs ->
                letrec
                    totals = \(go zeroTuple) -> foldl' go zeroTuple;
                    zeroTuple = \ -> Tuple zero zero;
                    go = \acc x -> case acc of
                        Tuple t n ->
                            let tx = \(t x) => add t x;
                                n1 = \(n) => add n one
                            in case tx of
                                default -> case n1 of
                                    default -> Tuple tx n1;
                        badTuple -> Error_mean1 badTuple
                in case totals xs of
                    Tuple t n -> div t n;
                    badTuple -> Error_mean2 badTuple
            |] ]}}