diff options
Diffstat (limited to 'users/grfn/xanthous/src/Xanthous/Orphans.hs')
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Orphans.hs | 495 |
1 files changed, 0 insertions, 495 deletions
diff --git a/users/grfn/xanthous/src/Xanthous/Orphans.hs b/users/grfn/xanthous/src/Xanthous/Orphans.hs deleted file mode 100644 index 66004163f6ea..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Orphans.hs +++ /dev/null @@ -1,495 +0,0 @@ -{-# 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 |