Inspection.hs

{-# LANGUAGE TemplateHaskell #-}

{- | Performance tests for @prolens@. Uses the @inspection-testing@
library to make sure that lenses are as efficient as manual record
getters and update syntax.
-}

module Test.Prolens.Inspection
    ( inspectionSpecs
    ) where

import Test.Hspec (Spec, describe, it, shouldSatisfy, xit)
import Test.Inspection (Result (..), hasNoTypeClasses, inspectTest, (===))

import Prolens (preview, set, view)
import Test.Data (Grade (..), Haskeller (..), Knowledge (..), _Mark, knowledgeL, nameL, syntaxL)


setNameViaLens :: Haskeller -> Haskeller
setNameViaLens = set nameL "Dmitrii"

setNameManually :: Haskeller -> Haskeller
setNameManually h = h { haskellerName = "Dmitrii" }

getNameViaLens :: Haskeller -> String
getNameViaLens = view nameL

getNameManually :: Haskeller -> String
getNameManually (Haskeller name _ _) = name

setSyntaxViaLens :: Haskeller -> Haskeller
setSyntaxViaLens = set (knowledgeL . syntaxL) True

setSyntaxManually :: Haskeller -> Haskeller
setSyntaxManually h = h { haskellerKnowledge = (haskellerKnowledge h) { kSyntax = True } }

getSyntaxViaLens :: Haskeller -> Bool
getSyntaxViaLens = view (knowledgeL . syntaxL)

getSyntaxManually :: Haskeller -> Bool
getSyntaxManually (Haskeller _ _ (Knowledge syntax _ _ _ _)) = syntax

inspectionSpecs :: Spec
inspectionSpecs = describe "Performance Inspection Testing" $ do
    lensSpecs
    prismSpecs

lensSpecs :: Spec
lensSpecs = describe "Lens" $ do
    describe "set" $ do
        it "setting single via lens is efficient as manual record update" $
            $(inspectTest $ 'setNameViaLens === 'setNameManually) `shouldSatisfy` isSuccess
        it "setting single via lens doesn't have intermediate typeclasses" $
            $(inspectTest $ hasNoTypeClasses 'setNameViaLens) `shouldSatisfy` isSuccess
        it "setting composition via lens is efficient as manual record update" $
            $(inspectTest $ 'setSyntaxViaLens === 'setSyntaxManually) `shouldSatisfy` isSuccess
        it "setting composition via lens doesn't have intermediate typeclasses" $
            $(inspectTest $ hasNoTypeClasses 'setSyntaxViaLens) `shouldSatisfy` isSuccess
    describe "view" $ do
        it "getting single via lens is efficient as plain record function" $
            $(inspectTest $ 'getNameViaLens === 'getNameManually) `shouldSatisfy` isSuccess
        it "getting single via lens doesn't have intermediate typeclasses" $
            $(inspectTest $ hasNoTypeClasses 'getNameViaLens) `shouldSatisfy` isSuccess
        it "getting composition via lens is efficient as plain record function" $
            $(inspectTest $ 'getSyntaxViaLens === 'getSyntaxManually) `shouldSatisfy` isSuccess
        it "getting composition via lens doesn't have intermediate typeclasses" $
            $(inspectTest $ hasNoTypeClasses 'getSyntaxViaLens) `shouldSatisfy` isSuccess

matchMarkPrism :: Grade -> Maybe Int
matchMarkPrism = preview _Mark

matchMarkManual :: Grade -> Maybe Int
matchMarkManual grade = case grade of
    Mark n -> Just n
    _other -> Nothing

prismSpecs :: Spec
prismSpecs = describe "Prism" $ do
    describe "preview" $ do
        xit "preview _Ctor x ≡ case (Ctor _) of" $
            $(inspectTest $ 'matchMarkPrism === 'matchMarkManual) `shouldSatisfy` isSuccess

-- Helper functions

isSuccess :: Result -> Bool
isSuccess (Success _) = True
isSuccess (Failure _) = False