refactor(users/glittershark): Rename to grfn
Rename my //users directory and all places that refer to glittershark to grfn, including nix references and documentation. This may require some extra attention inside of gerrit's database after it lands to allow me to actually push things. Change-Id: I4728b7ec2c60024392c1c1fa6e0d4a59b3e266fa Reviewed-on: https://cl.tvl.fyi/c/depot/+/2933 Tested-by: BuildkiteCI Reviewed-by: tazjin <mail@tazj.in> Reviewed-by: lukegb <lukegb@tvl.fyi> Reviewed-by: glittershark <grfn@gws.fyi>
This commit is contained in:
Griffin Smith
glittershark
parent
968effb5dc
commit
6266c5d32f
362 changed files with 52 additions and 56 deletions
352
users/grfn/xanthous/src/Xanthous/Orphans.hs
Normal file
352
users/grfn/xanthous/src/Xanthous/Orphans.hs
Normal file
|
|
@ -0,0 +1,352 @@
|
|||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
--------------------------------------------------------------------------------
|
||||
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 Xanthous.Util.JSON
|
||||
import Xanthous.Util.QuickCheck
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
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
|
||||
|
||||
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 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)
|
||||
Loading…
Add table
Add a link
Reference in a new issue