8b97683f6e
Allow the itemType raw to have density and volume fields, both of which represent *intervals* of both density and volume (because both can hypothetically vary a bit). The idea here is that when we're making an *instance* of one of these items, we pick a random value in the range. Lots of stuff in this commit is datatype and typeclass instances to support things like intervals being fields on datatypes that get serialized to saved games - including a manual definition of Ord for Item since Ord isn't well-defined for intervals Change-Id: Ia088f2f75cdce9d00560297e5c269e3310b85bc3 Reviewed-on: https://cl.tvl.fyi/c/depot/+/3225 Reviewed-by: grfn <grfn@gws.fyi> Tested-by: BuildkiteCI
483 lines
17 KiB
Haskell
483 lines
17 KiB
Haskell
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
{-# LANGUAGE PackageImports #-}
|
|
{-# OPTIONS_GHC -Wno-orphans #-}
|
|
{-# OPTIONS_GHC -Wno-type-defaults #-}
|
|
--------------------------------------------------------------------------------
|
|
module Xanthous.Orphans
|
|
( ppTemplate
|
|
) where
|
|
--------------------------------------------------------------------------------
|
|
import Xanthous.Prelude hiding (elements, (.=))
|
|
--------------------------------------------------------------------------------
|
|
import Data.Aeson
|
|
import Data.Aeson.Types (typeMismatch)
|
|
import Data.List.NonEmpty (NonEmpty(..))
|
|
import Graphics.Vty.Attributes
|
|
import Brick.Widgets.Edit
|
|
import Data.Text.Zipper.Generic (GenericTextZipper)
|
|
import Brick.Widgets.Core (getName)
|
|
import System.Random.Internal (StdGen (..))
|
|
import System.Random.SplitMix (SMGen ())
|
|
import Test.QuickCheck
|
|
import "quickcheck-instances" Test.QuickCheck.Instances ()
|
|
import Text.Megaparsec (errorBundlePretty)
|
|
import Text.Megaparsec.Pos
|
|
import Text.Mustache
|
|
import Text.Mustache.Type ( showKey )
|
|
import Control.Monad.State
|
|
import Linear
|
|
import qualified Data.Interval as Interval
|
|
import Data.Interval ( Interval, Extended (..), Boundary (..)
|
|
, lowerBound', upperBound', (<=..<), (<=..<=)
|
|
, interval)
|
|
import Test.QuickCheck.Checkers (EqProp ((=-=)))
|
|
--------------------------------------------------------------------------------
|
|
import Xanthous.Util.JSON
|
|
import Xanthous.Util.QuickCheck
|
|
import Xanthous.Util (EqEqProp(EqEqProp))
|
|
--------------------------------------------------------------------------------
|
|
|
|
instance forall s a.
|
|
( Cons s s a a
|
|
, IsSequence s
|
|
, Element s ~ a
|
|
) => Cons (NonNull s) (NonNull s) a a where
|
|
_Cons = prism hither yon
|
|
where
|
|
hither :: (a, NonNull s) -> NonNull s
|
|
hither (a, ns) =
|
|
let s = toNullable ns
|
|
in impureNonNull $ a <| s
|
|
|
|
yon :: NonNull s -> Either (NonNull s) (a, NonNull s)
|
|
yon ns = case nuncons ns of
|
|
(_, Nothing) -> Left ns
|
|
(x, Just xs) -> Right (x, xs)
|
|
|
|
instance forall a. Cons (NonEmpty a) (NonEmpty a) a a where
|
|
_Cons = prism hither yon
|
|
where
|
|
hither :: (a, NonEmpty a) -> NonEmpty a
|
|
hither (a, x :| xs) = a :| (x : xs)
|
|
|
|
yon :: NonEmpty a -> Either (NonEmpty a) (a, NonEmpty a)
|
|
yon ns@(x :| xs) = case xs of
|
|
(y : ys) -> Right (x, y :| ys)
|
|
[] -> Left ns
|
|
|
|
|
|
instance Arbitrary PName where
|
|
arbitrary = PName . pack <$> listOf1 (elements ['a'..'z'])
|
|
|
|
instance Arbitrary Key where
|
|
arbitrary = Key <$> listOf1 arbSafeText
|
|
where arbSafeText = pack <$> listOf1 (elements ['a'..'z'])
|
|
shrink (Key []) = error "unreachable"
|
|
shrink k@(Key [_]) = pure k
|
|
shrink (Key (p:ps)) = Key . (p :) <$> shrink ps
|
|
|
|
instance Arbitrary Pos where
|
|
arbitrary = mkPos . succ . abs <$> arbitrary
|
|
shrink (unPos -> 1) = []
|
|
shrink (unPos -> x) = mkPos <$> [x..1]
|
|
|
|
instance Arbitrary Node where
|
|
arbitrary = sized node
|
|
where
|
|
node n | n > 0 = oneof $ leaves ++ branches (n `div` 2)
|
|
node _ = oneof leaves
|
|
branches n =
|
|
[ Section <$> arbitrary <*> subnodes n
|
|
, InvertedSection <$> arbitrary <*> subnodes n
|
|
]
|
|
subnodes = fmap concatTextBlocks . listOf . node
|
|
leaves =
|
|
[ TextBlock . pack <$> listOf1 (elements ['a'..'z'])
|
|
, EscapedVar <$> arbitrary
|
|
, UnescapedVar <$> arbitrary
|
|
-- TODO fix pretty-printing of mustache partials
|
|
-- , Partial <$> arbitrary <*> arbitrary
|
|
]
|
|
shrink = genericShrink
|
|
|
|
concatTextBlocks :: [Node] -> [Node]
|
|
concatTextBlocks [] = []
|
|
concatTextBlocks [x] = [x]
|
|
concatTextBlocks (TextBlock txt₁ : TextBlock txt₂ : xs)
|
|
= concatTextBlocks $ TextBlock (txt₁ <> txt₂) : concatTextBlocks xs
|
|
concatTextBlocks (x : xs) = x : concatTextBlocks xs
|
|
|
|
instance Arbitrary Template where
|
|
arbitrary = do
|
|
template <- concatTextBlocks <$> arbitrary
|
|
-- templateName <- arbitrary
|
|
-- rest <- arbitrary
|
|
let templateName = "template"
|
|
rest = mempty
|
|
pure $ Template
|
|
{ templateActual = templateName
|
|
, templateCache = rest & at templateName ?~ template
|
|
}
|
|
shrink (Template actual cache) =
|
|
let Just tpl = cache ^. at actual
|
|
in do
|
|
cache' <- shrink cache
|
|
tpl' <- shrink tpl
|
|
actual' <- shrink actual
|
|
pure $ Template
|
|
{ templateActual = actual'
|
|
, templateCache = cache' & at actual' ?~ tpl'
|
|
}
|
|
|
|
instance CoArbitrary Template where
|
|
coarbitrary = coarbitrary . ppTemplate
|
|
|
|
instance Function Template where
|
|
function = functionMap ppTemplate parseTemplatePartial
|
|
where
|
|
parseTemplatePartial txt
|
|
= compileMustacheText "template" txt ^?! _Right
|
|
|
|
ppNode :: Map PName [Node] -> Node -> Text
|
|
ppNode _ (TextBlock txt) = txt
|
|
ppNode _ (EscapedVar k) = "{{" <> showKey k <> "}}"
|
|
ppNode ctx (Section k body) =
|
|
let sk = showKey k
|
|
in "{{#" <> sk <> "}}" <> foldMap (ppNode ctx) body <> "{{/" <> sk <> "}}"
|
|
ppNode _ (UnescapedVar k) = "{{{" <> showKey k <> "}}}"
|
|
ppNode ctx (InvertedSection k body) =
|
|
let sk = showKey k
|
|
in "{{^" <> sk <> "}}" <> foldMap (ppNode ctx) body <> "{{/" <> sk <> "}}"
|
|
ppNode _ (Partial n _) = "{{> " <> unPName n <> "}}"
|
|
|
|
ppTemplate :: Template -> Text
|
|
ppTemplate (Template actual cache) =
|
|
case cache ^. at actual of
|
|
Nothing -> error "Template not found?"
|
|
Just nodes -> foldMap (ppNode cache) nodes
|
|
|
|
instance ToJSON Template where
|
|
toJSON = String . ppTemplate
|
|
|
|
instance FromJSON Template where
|
|
parseJSON
|
|
= withText "Template"
|
|
$ either (fail . errorBundlePretty) pure
|
|
. compileMustacheText "template"
|
|
|
|
deriving anyclass instance NFData Node
|
|
deriving anyclass instance NFData Template
|
|
|
|
instance FromJSON Color where
|
|
parseJSON (String "black") = pure black
|
|
parseJSON (String "red") = pure red
|
|
parseJSON (String "green") = pure green
|
|
parseJSON (String "yellow") = pure yellow
|
|
parseJSON (String "blue") = pure blue
|
|
parseJSON (String "magenta") = pure magenta
|
|
parseJSON (String "cyan") = pure cyan
|
|
parseJSON (String "white") = pure white
|
|
parseJSON (String "brightBlack") = pure brightBlack
|
|
parseJSON (String "brightRed") = pure brightRed
|
|
parseJSON (String "brightGreen") = pure brightGreen
|
|
parseJSON (String "brightYellow") = pure brightYellow
|
|
parseJSON (String "brightBlue") = pure brightBlue
|
|
parseJSON (String "brightMagenta") = pure brightMagenta
|
|
parseJSON (String "brightCyan") = pure brightCyan
|
|
parseJSON (String "brightWhite") = pure brightWhite
|
|
parseJSON n@(Number _) = Color240 <$> parseJSON n
|
|
parseJSON x = typeMismatch "Color" x
|
|
|
|
instance ToJSON Color where
|
|
toJSON color
|
|
| color == black = "black"
|
|
| color == red = "red"
|
|
| color == green = "green"
|
|
| color == yellow = "yellow"
|
|
| color == blue = "blue"
|
|
| color == magenta = "magenta"
|
|
| color == cyan = "cyan"
|
|
| color == white = "white"
|
|
| color == brightBlack = "brightBlack"
|
|
| color == brightRed = "brightRed"
|
|
| color == brightGreen = "brightGreen"
|
|
| color == brightYellow = "brightYellow"
|
|
| color == brightBlue = "brightBlue"
|
|
| color == brightMagenta = "brightMagenta"
|
|
| color == brightCyan = "brightCyan"
|
|
| color == brightWhite = "brightWhite"
|
|
| Color240 num <- color = toJSON num
|
|
| otherwise = error $ "unimplemented: " <> show color
|
|
|
|
instance (Eq a, Show a, Read a, FromJSON a) => FromJSON (MaybeDefault a) where
|
|
parseJSON Null = pure Default
|
|
parseJSON (String "keepCurrent") = pure KeepCurrent
|
|
parseJSON x = SetTo <$> parseJSON x
|
|
|
|
instance ToJSON a => ToJSON (MaybeDefault a) where
|
|
toJSON Default = Null
|
|
toJSON KeepCurrent = String "keepCurrent"
|
|
toJSON (SetTo x) = toJSON x
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
instance Arbitrary Color where
|
|
arbitrary = oneof [ Color240 <$> choose (0, 239)
|
|
, ISOColor <$> choose (0, 15)
|
|
]
|
|
|
|
deriving anyclass instance CoArbitrary Color
|
|
deriving anyclass instance Function Color
|
|
|
|
instance (Eq a, Show a, Read a, Arbitrary a) => Arbitrary (MaybeDefault a) where
|
|
arbitrary = oneof [ pure Default
|
|
, pure KeepCurrent
|
|
, SetTo <$> arbitrary
|
|
]
|
|
|
|
instance CoArbitrary a => CoArbitrary (MaybeDefault a) where
|
|
coarbitrary Default = variant @Int 1
|
|
coarbitrary KeepCurrent = variant @Int 2
|
|
coarbitrary (SetTo x) = variant @Int 3 . coarbitrary x
|
|
|
|
instance (Eq a, Show a, Read a, Function a) => Function (MaybeDefault a) where
|
|
function = functionShow
|
|
|
|
deriving via (EqEqProp Attr) instance EqProp Attr
|
|
|
|
instance Arbitrary Attr where
|
|
arbitrary = do
|
|
attrStyle <- arbitrary
|
|
attrForeColor <- arbitrary
|
|
attrBackColor <- arbitrary
|
|
attrURL <- arbitrary
|
|
pure Attr {..}
|
|
|
|
deriving anyclass instance CoArbitrary Attr
|
|
deriving anyclass instance Function Attr
|
|
|
|
instance ToJSON Attr where
|
|
toJSON Attr{..} = object
|
|
[ "style" .= maybeDefaultToJSONWith styleToJSON attrStyle
|
|
, "foreground" .= attrForeColor
|
|
, "background" .= attrBackColor
|
|
, "url" .= attrURL
|
|
]
|
|
where
|
|
maybeDefaultToJSONWith _ Default = Null
|
|
maybeDefaultToJSONWith _ KeepCurrent = String "keepCurrent"
|
|
maybeDefaultToJSONWith tj (SetTo x) = tj x
|
|
styleToJSON style
|
|
| style == standout = "standout"
|
|
| style == underline = "underline"
|
|
| style == reverseVideo = "reverseVideo"
|
|
| style == blink = "blink"
|
|
| style == dim = "dim"
|
|
| style == bold = "bold"
|
|
| style == italic = "italic"
|
|
| otherwise = toJSON style
|
|
|
|
instance FromJSON Attr where
|
|
parseJSON = withObject "Attr" $ \obj -> do
|
|
attrStyle <- parseStyle =<< obj .:? "style" .!= Default
|
|
attrForeColor <- obj .:? "foreground" .!= Default
|
|
attrBackColor <- obj .:? "background" .!= Default
|
|
attrURL <- obj .:? "url" .!= Default
|
|
pure Attr{..}
|
|
|
|
where
|
|
parseStyle (SetTo (String "standout")) = pure (SetTo standout)
|
|
parseStyle (SetTo (String "underline")) = pure (SetTo underline)
|
|
parseStyle (SetTo (String "reverseVideo")) = pure (SetTo reverseVideo)
|
|
parseStyle (SetTo (String "blink")) = pure (SetTo blink)
|
|
parseStyle (SetTo (String "dim")) = pure (SetTo dim)
|
|
parseStyle (SetTo (String "bold")) = pure (SetTo bold)
|
|
parseStyle (SetTo (String "italic")) = pure (SetTo italic)
|
|
parseStyle (SetTo n@(Number _)) = SetTo <$> parseJSON n
|
|
parseStyle (SetTo v) = typeMismatch "Style" v
|
|
parseStyle Default = pure Default
|
|
parseStyle KeepCurrent = pure KeepCurrent
|
|
|
|
deriving stock instance Ord Color
|
|
deriving stock instance Ord a => Ord (MaybeDefault a)
|
|
deriving stock instance Ord Attr
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
instance (SemiSequence a, Arbitrary (Element a), Arbitrary a)
|
|
=> Arbitrary (NonNull a) where
|
|
arbitrary = ncons <$> arbitrary <*> arbitrary
|
|
|
|
instance ToJSON a => ToJSON (NonNull a) where
|
|
toJSON = toJSON . toNullable
|
|
|
|
instance (FromJSON a, MonoFoldable a) => FromJSON (NonNull a) where
|
|
parseJSON = maybe (fail "Found empty list") pure . fromNullable <=< parseJSON
|
|
|
|
instance NFData a => NFData (NonNull a) where
|
|
rnf xs = xs `seq` toNullable xs `deepseq` ()
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
instance forall t name. (NFData t, Monoid t, NFData name)
|
|
=> NFData (Editor t name) where
|
|
rnf ed = getName @_ @name ed `deepseq` getEditContents ed `deepseq` ()
|
|
|
|
deriving via (ReadShowJSON SMGen) instance ToJSON SMGen
|
|
deriving via (ReadShowJSON SMGen) instance FromJSON SMGen
|
|
|
|
instance ToJSON StdGen where
|
|
toJSON = toJSON . unStdGen
|
|
toEncoding = toEncoding . unStdGen
|
|
|
|
instance FromJSON StdGen where
|
|
parseJSON = fmap StdGen . parseJSON
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
instance CoArbitrary a => CoArbitrary (NonNull a) where
|
|
coarbitrary = coarbitrary . toNullable
|
|
|
|
instance (MonoFoldable a, Function a) => Function (NonNull a) where
|
|
function = functionMap toNullable $ fromMaybe (error "null") . fromNullable
|
|
|
|
instance (Arbitrary t, Arbitrary n, GenericTextZipper t)
|
|
=> Arbitrary (Editor t n) where
|
|
arbitrary = editor <$> arbitrary <*> arbitrary <*> arbitrary
|
|
|
|
instance forall t n. (CoArbitrary t, CoArbitrary n, Monoid t)
|
|
=> CoArbitrary (Editor t n) where
|
|
coarbitrary ed = coarbitrary (getName @_ @n ed, getEditContents ed)
|
|
|
|
instance CoArbitrary StdGen where
|
|
coarbitrary = coarbitrary . show
|
|
|
|
instance Function StdGen where
|
|
function = functionMap unStdGen StdGen
|
|
|
|
instance Function SMGen where
|
|
function = functionShow
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
deriving newtype instance (Arbitrary s, CoArbitrary (m (a, s)))
|
|
=> CoArbitrary (StateT s m a)
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
deriving via (GenericArbitrary (V2 a)) instance Arbitrary a => Arbitrary (V2 a)
|
|
instance CoArbitrary a => CoArbitrary (V2 a)
|
|
instance Function a => Function (V2 a)
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
instance CoArbitrary Boundary
|
|
instance Function Boundary
|
|
|
|
instance Arbitrary a => Arbitrary (Extended a) where
|
|
arbitrary = oneof [ pure NegInf
|
|
, pure PosInf
|
|
, Finite <$> arbitrary
|
|
]
|
|
|
|
instance CoArbitrary a => CoArbitrary (Extended a) where
|
|
coarbitrary NegInf = variant 1
|
|
coarbitrary PosInf = variant 2
|
|
coarbitrary (Finite x) = variant 3 . coarbitrary x
|
|
|
|
instance (Function a) => Function (Extended a) where
|
|
function = functionMap g h
|
|
where
|
|
g NegInf = Left True
|
|
g (Finite a) = Right a
|
|
g PosInf = Left False
|
|
h (Left False) = PosInf
|
|
h (Left True) = NegInf
|
|
h (Right a) = Finite a
|
|
|
|
instance ToJSON a => ToJSON (Extended a) where
|
|
toJSON NegInf = String "NegInf"
|
|
toJSON PosInf = String "PosInf"
|
|
toJSON (Finite x) = toJSON x
|
|
|
|
instance FromJSON a => FromJSON (Extended a) where
|
|
parseJSON (String "NegInf") = pure NegInf
|
|
parseJSON (String "PosInf") = pure PosInf
|
|
parseJSON val = Finite <$> parseJSON val
|
|
|
|
instance (EqProp a, Show a) => EqProp (Extended a) where
|
|
NegInf =-= NegInf = property True
|
|
PosInf =-= PosInf = property True
|
|
(Finite x) =-= (Finite y) = x =-= y
|
|
x =-= y = counterexample (show x <> " /= " <> show y) False
|
|
|
|
instance Arbitrary Interval.Boundary where
|
|
arbitrary = elements [ Interval.Open , Interval.Closed ]
|
|
|
|
instance (Ord r, Arbitrary r) => Arbitrary (Interval r) where
|
|
arbitrary = do
|
|
lower <- arbitrary
|
|
upper <- arbitrary
|
|
pure $ (if upper < lower then flip else id)
|
|
Interval.interval
|
|
lower
|
|
upper
|
|
|
|
instance CoArbitrary a => CoArbitrary (Interval a) where
|
|
coarbitrary int = coarbitrary (lowerBound' int) . coarbitrary (upperBound' int)
|
|
|
|
instance (Function a, Ord a) => Function (Interval a) where
|
|
function = functionMap g h
|
|
where
|
|
g = lowerBound' &&& upperBound'
|
|
h = uncurry interval
|
|
|
|
deriving via (EqEqProp (Interval a)) instance Eq a => (EqProp (Interval a))
|
|
|
|
instance ToJSON a => ToJSON (Interval a) where
|
|
toJSON x = Array . fromList $
|
|
[ object [ lowerKey .= lowerVal ]
|
|
, object [ upperKey .= upperVal ]
|
|
]
|
|
where
|
|
(lowerVal, lowerBoundary) = lowerBound' x
|
|
(upperVal, upperBoundary) = upperBound' x
|
|
upperKey = boundaryToKey upperBoundary
|
|
lowerKey = boundaryToKey lowerBoundary
|
|
boundaryToKey Open = "Excluded"
|
|
boundaryToKey Closed = "Included"
|
|
|
|
instance forall a. (FromJSON a, Ord a) => FromJSON (Interval a) where
|
|
parseJSON x =
|
|
boundPairWithBoundary x
|
|
<|> boundPairWithoutBoundary x
|
|
<|> singleVal x
|
|
where
|
|
boundPairWithBoundary = withArray "Bound pair" $ \arr -> do
|
|
checkLength arr
|
|
lower <- parseBound $ arr ^?! ix 0
|
|
upper <- parseBound $ arr ^?! ix 1
|
|
pure $ interval lower upper
|
|
parseBound = withObject "Bound" $ \obj -> do
|
|
when (length obj /= 1) $ fail "Expected an object with a single key"
|
|
let [(k, v)] = obj ^@.. ifolded
|
|
boundary <- case k of
|
|
"Excluded" -> pure Open
|
|
"Open" -> pure Open
|
|
"Included" -> pure Closed
|
|
"Closed" -> pure Closed
|
|
_ -> fail "Invalid boundary specification"
|
|
val <- parseJSON v
|
|
pure (val, boundary)
|
|
boundPairWithoutBoundary = withArray "Bound pair" $ \arr -> do
|
|
checkLength arr
|
|
lower <- parseJSON $ arr ^?! ix 0
|
|
upper <- parseJSON $ arr ^?! ix 1
|
|
pure $ lower <=..< upper
|
|
singleVal v = do
|
|
val <- parseJSON v
|
|
pure $ val <=..<= val
|
|
checkLength arr =
|
|
when (length arr /= 2) $ fail "Expected array of length 2"
|