chore(users): grfn -> aspen
Change-Id: I6c6847fac56f0a9a1a2209792e00a3aec5e672b9 Reviewed-on: https://cl.tvl.fyi/c/depot/+/10809 Autosubmit: aspen <root@gws.fyi> Reviewed-by: sterni <sternenseemann@systemli.org> Tested-by: BuildkiteCI Reviewed-by: lukegb <lukegb@tvl.fyi>
This commit is contained in:
parent
0ba476a426
commit
82ecd61f5c
478 changed files with 75 additions and 77 deletions
495
users/aspen/xanthous/src/Xanthous/Orphans.hs
Normal file
495
users/aspen/xanthous/src/Xanthous/Orphans.hs
Normal file
|
|
@ -0,0 +1,495 @@
|
|||
{-# 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 hiding (Key)
|
||||
import qualified Data.Aeson.KeyMap as KM
|
||||
import Data.Aeson.Types (typeMismatch)
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import qualified Graphics.Vty.Input
|
||||
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 Test.QuickCheck.Arbitrary.Generic (Arg ())
|
||||
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))
|
||||
import qualified Graphics.Vty.Input.Events
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
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 = scale (`div` 10) $ sized node
|
||||
where
|
||||
node n | n > 0 = oneof $ leaves ++ branches (n `div` 4)
|
||||
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 = scale (`div` 8) $ 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
|
||||
|
||||
deriving anyclass instance Hashable Graphics.Vty.Input.Events.Key
|
||||
deriving anyclass instance Hashable Graphics.Vty.Input.Events.Modifier
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
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 (KM.size 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"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
deriving anyclass instance NFData Graphics.Vty.Input.Key
|
||||
deriving anyclass instance NFData Graphics.Vty.Input.Modifier
|
||||
Loading…
Add table
Add a link
Reference in a new issue