path: root/users/grfn/xanthous/src/Xanthous/Orphans.hs

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