content: {-# LANGUAGE DisambiguateRecordFields #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE NamedFieldPuns #-}
  {-# LANGUAGE TemplateHaskell #-}
  module Test.Group
  ( Entry(..)
  , mkGroup
  , deriveGroup
  , mkProp
  , entryName
  , Loc(..)
  , here
  , zero
  , Semiring(..)
  , Unital(..)
  , horizontal
  , sumWidths
  , vertical
  , maxWidths
  , Width(..)
  , HasWidth(..)
    -- * Statuses
  , stat
  , Status(..)
    -- * Tallies
  , hasFailures
  , hasSuccesses
  , unit
  , Tally(..)
  ) where
  
  import Data.Char (isSpace)
  import Fresnel.Tropical
  import GHC.Stack
  import Language.Haskell.TH.Lib
  import Language.Haskell.TH.Syntax (Module(..), modString)
  import Numeric (readDec)
  import Test.QuickCheck (Property, allProperties)
  
  data Entry
    = Group String [Entry]
    | Prop String Loc Property
  
  mkGroup :: String -> [(String, Property)] -> Entry
  mkGroup name = Group name . map (uncurry mkProp)
  
  deriveGroup :: ExpQ
  deriveGroup = [e| mkGroup $(thisModule >>= \ (Module _ name) -> stringE (modString name)) $allProperties |]
  
  mkProp :: String -> Property -> Entry
  mkProp s = Prop name Loc{ path, lineNumber }
    where
    (name, path, lineNumber) = case breaks [isSpace, not . isSpace, isSpace, not . isSpace, (== ':'), (/= ':')] s of
      [n, _, _, _, p, _, l] -> (unwords (filter (\ s -> s /= "_" && s /= "prop") (breakAll (== '_') n)), p, fst (head (readDec l)))
      _                     -> ("", "", 0)
  
  entryName :: Entry -> String
  entryName = \case
    Group name _  -> name
    Prop name _ _ -> name
  
  
  data Loc = Loc { path :: FilePath, lineNumber :: Int }
  
  here :: HasCallStack => Loc
  here = Loc{ path = srcLocFile srcLoc, lineNumber = srcLocStartLine srcLoc }
    where
    (_, srcLoc) = head (getCallStack callStack)
  
  
  breaks :: [a -> Bool] -> [a] -> [[a]]
  breaks ps as = case ps of
    []   -> [as]
    p:ps -> let (h, t) = break p as in h : breaks ps t
  
  breakAll :: (a -> Bool) -> [a] -> [[a]]
  breakAll p = go False where
    go b = \case
      [] -> []
      as -> let (h, t) = break (if b then not . p else p) as in h : go (not b) t
  
  
  zero :: Monoid s => s
  zero = mempty
  
  class Semigroup s => Semiring s where
    (><) :: s -> s -> s
    infixr 7 ><
  
  instance (Semigroup a, Ord a) => Semiring (Tropical a) where
    Tropical a1 >< Tropical a2 = Tropical ((<>) <$> a1 <*> a2)
  
  class (Monoid s, Semiring s) => Unital s where
    one :: s
  
  instance (Monoid a, Ord a) => Unital (Tropical a) where
    one = finite zero
  
  
  horizontal :: (Foldable t, Unital r) => (a -> r) -> t a -> r
  horizontal f = foldr ((><) . f) one
  
  sumWidths :: (Foldable t, HasWidth a) => t a -> Tropical Width
  sumWidths = horizontal maxWidth
  
  vertical :: (Foldable t, Semiring r, Monoid r) => (a -> r) -> t a -> r
  vertical f = foldr ((<>) . f) zero
  
  maxWidths :: (Foldable t, HasWidth a) => t a -> Tropical Width
  maxWidths = vertical maxWidth
  
  newtype Width = Width { width :: Int }
    deriving (Eq, Ord)
  
  instance Semigroup Width where
    Width a1 <> Width a2 = Width (a1 + a2)
  
  instance Monoid Width where
    mempty = Width 0
  
  instance Semiring Width where
    Width a1 >< Width a2 = Width (a1 * a2)
  
  instance Unital Width where
    one = Width 1
  
  
  class HasWidth t where
    maxWidth :: t -> Tropical Width
  
  instance HasWidth Char where
    maxWidth _ = finite one
  
  instance HasWidth Entry where
    maxWidth = \case
      Group groupName entries -> sumWidths groupName <> maxWidths entries
      Prop name _ _           -> sumWidths name
  
  
  -- Statuses
  
  stat :: a -> a -> Status -> a
  stat pass fail = \case{ Pass -> pass ; Fail -> fail }
  
  data Status = Pass | Fail
    deriving (Eq)
  
  
  -- Tallies
  
  hasSuccesses :: Tally -> Bool
  hasSuccesses = (/= 0) . successes
  
  hasFailures :: Tally -> Bool
  hasFailures = (/= 0) . failures
  
  unit :: Status -> Tally
  unit = stat (Tally 1 0) (Tally 0 1)
  
  data Tally = Tally { successes :: Int, failures :: Int }
  
  instance Semigroup Tally where
    Tally s1 f1 <> Tally s2 f2 = Tally (s1 + s2) (f1 + f2)
  
  instance Monoid Tally where
    mempty = Tally 0 0
  