tvl-depot/users/grfn/xanthous/src/Xanthous/Orphans.hs

Ignoring revisions in .git-blame-ignore-revs. Click here to bypass and see the normal blame view.

484 lines
17 KiB
Haskell
Raw Normal View History

{-# 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 = 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
--------------------------------------------------------------------------------
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"