{-# LANGUAGE CPP #-}
-- | Types and functions for describing the movements of a cursor around the
-- 'Waargonaut.Types.Json.Json' structure.
module Waargonaut.Decode.ZipperMove
  ( ZipperMove (..)
  , AsZipperMove (..)
  , ppZipperMove
  ) where

import           Control.Lens                  (Prism')
import qualified Control.Lens                  as L

import           Data.Text                     (Text)
import qualified Data.Text                     as Text

#if !MIN_VERSION_base(4,11,0)
import           Data.Semigroup                ((<>))
#endif

import           Natural                       (Natural)

import           Text.PrettyPrint.Annotated.WL (Doc, (<+>))
import qualified Text.PrettyPrint.Annotated.WL as WL

-- |
-- Set of moves that may be executed on a zipper.
--
data ZipperMove
  = U
  | D
  | DAt Text
  | Item Text
  | L Natural
  | R Natural
  | BranchFail Text
  deriving (Int -> ZipperMove -> ShowS
[ZipperMove] -> ShowS
ZipperMove -> String
(Int -> ZipperMove -> ShowS)
-> (ZipperMove -> String)
-> ([ZipperMove] -> ShowS)
-> Show ZipperMove
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ZipperMove] -> ShowS
$cshowList :: [ZipperMove] -> ShowS
show :: ZipperMove -> String
$cshow :: ZipperMove -> String
showsPrec :: Int -> ZipperMove -> ShowS
$cshowsPrec :: Int -> ZipperMove -> ShowS
Show, ZipperMove -> ZipperMove -> Bool
(ZipperMove -> ZipperMove -> Bool)
-> (ZipperMove -> ZipperMove -> Bool) -> Eq ZipperMove
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ZipperMove -> ZipperMove -> Bool
$c/= :: ZipperMove -> ZipperMove -> Bool
== :: ZipperMove -> ZipperMove -> Bool
$c== :: ZipperMove -> ZipperMove -> Bool
Eq)

-- | Pretty print a given zipper movement, used when printing
-- 'Waargonaut.Decode.Internal.CursorHistory'' to improve the readability of the errors.
ppZipperMove :: ZipperMove -> Doc a
ppZipperMove :: ZipperMove -> Doc a
ppZipperMove ZipperMove
m = case ZipperMove
m of
  ZipperMove
U            -> String -> Doc a
forall a. String -> Doc a
WL.text String
"up/" Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Doc a
forall a. Doc a
WL.linebreak
  ZipperMove
D            -> String -> Doc a
forall a. String -> Doc a
WL.text String
"down\\" Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Doc a
forall a. Doc a
WL.linebreak

  L Natural
n          -> String -> Doc a
forall a. String -> Doc a
WL.text String
"-<-" Doc a -> Doc a -> Doc a
forall a. Doc a -> Doc a -> Doc a
<+> Natural -> Doc a
forall a a. Show a => a -> Doc a
ntxt Natural
n
  R Natural
n          -> String -> Doc a
forall a. String -> Doc a
WL.text String
" ->-" Doc a -> Doc a -> Doc a
forall a. Doc a -> Doc a -> Doc a
<+> Natural -> Doc a
forall a a. Show a => a -> Doc a
ntxt Natural
n

  DAt Text
k        -> String -> Doc a
forall a. String -> Doc a
WL.text String
"into\\" Doc a -> Doc a -> Doc a
forall a. Doc a -> Doc a -> Doc a
<+> String -> Text -> Doc a
forall a. String -> Text -> Doc a
itxt String
"key" Text
k Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Doc a
forall a. Doc a
WL.linebreak
  Item Text
t       -> String -> Doc a
forall a. String -> Doc a
WL.text String
"-::" Doc a -> Doc a -> Doc a
forall a. Doc a -> Doc a -> Doc a
<+> String -> Text -> Doc a
forall a. String -> Text -> Doc a
itxt String
"item" Text
t Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Doc a
forall a. Doc a
WL.linebreak
  BranchFail Text
t -> String -> Doc a
forall a. String -> Doc a
WL.text String
"(attempted: " Doc a -> Doc a -> Doc a
forall a. Doc a -> Doc a -> Doc a
<+> Text -> Doc a
forall a a. Show a => a -> Doc a
ntxt Text
t Doc a -> Doc a -> Doc a
forall a. Doc a -> Doc a -> Doc a
<+> String -> Doc a
forall a. String -> Doc a
WL.text String
")" Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Doc a
forall a. Doc a
WL.linebreak
  where
    itxt :: String -> Text -> Doc a
itxt String
t Text
k' = Doc a -> Doc a
forall a. Doc a -> Doc a
WL.parens (String -> Doc a
forall a. String -> Doc a
WL.text String
t Doc a -> Doc a -> Doc a
forall a. Doc a -> Doc a -> Doc a
<+> Doc a
forall a. Doc a
WL.colon Doc a -> Doc a -> Doc a
forall a. Doc a -> Doc a -> Doc a
<+> String -> Doc a
forall a. String -> Doc a
WL.text (Text -> String
Text.unpack Text
k'))
    ntxt :: a -> Doc a
ntxt a
n'   = Doc a -> Doc a
forall a. Doc a -> Doc a
WL.parens (Char -> Doc a
forall a. Char -> Doc a
WL.char Char
'i' Doc a -> Doc a -> Doc a
forall a. Doc a -> Doc a -> Doc a
<+> Char -> Doc a
forall a. Char -> Doc a
WL.char Char
'+' Doc a -> Doc a -> Doc a
forall a. Doc a -> Doc a -> Doc a
<+> String -> Doc a
forall a. String -> Doc a
WL.text (a -> String
forall a. Show a => a -> String
show a
n'))

-- | Classy 'Control.Lens.Prism''s for things that may be treated as a 'ZipperMove'.
class AsZipperMove r where
  _ZipperMove :: Prism' r ZipperMove
  _U          :: Prism' r ()
  _D          :: Prism' r ()
  _DAt        :: Prism' r Text
  _Item       :: Prism' r Text
  _L          :: Prism' r Natural
  _R          :: Prism' r Natural

  _U    = p ZipperMove (f ZipperMove) -> p r (f r)
forall r. AsZipperMove r => Prism' r ZipperMove
_ZipperMove (p ZipperMove (f ZipperMove) -> p r (f r))
-> (p () (f ()) -> p ZipperMove (f ZipperMove))
-> p () (f ())
-> p r (f r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p () (f ()) -> p ZipperMove (f ZipperMove)
forall r. AsZipperMove r => Prism' r ()
_U
  _D    = p ZipperMove (f ZipperMove) -> p r (f r)
forall r. AsZipperMove r => Prism' r ZipperMove
_ZipperMove (p ZipperMove (f ZipperMove) -> p r (f r))
-> (p () (f ()) -> p ZipperMove (f ZipperMove))
-> p () (f ())
-> p r (f r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p () (f ()) -> p ZipperMove (f ZipperMove)
forall r. AsZipperMove r => Prism' r ()
_D
  _DAt  = p ZipperMove (f ZipperMove) -> p r (f r)
forall r. AsZipperMove r => Prism' r ZipperMove
_ZipperMove (p ZipperMove (f ZipperMove) -> p r (f r))
-> (p Text (f Text) -> p ZipperMove (f ZipperMove))
-> p Text (f Text)
-> p r (f r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p Text (f Text) -> p ZipperMove (f ZipperMove)
forall r. AsZipperMove r => Prism' r Text
_DAt
  _Item = p ZipperMove (f ZipperMove) -> p r (f r)
forall r. AsZipperMove r => Prism' r ZipperMove
_ZipperMove (p ZipperMove (f ZipperMove) -> p r (f r))
-> (p Text (f Text) -> p ZipperMove (f ZipperMove))
-> p Text (f Text)
-> p r (f r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p Text (f Text) -> p ZipperMove (f ZipperMove)
forall r. AsZipperMove r => Prism' r Text
_Item
  _L    = p ZipperMove (f ZipperMove) -> p r (f r)
forall r. AsZipperMove r => Prism' r ZipperMove
_ZipperMove (p ZipperMove (f ZipperMove) -> p r (f r))
-> (p Natural (f Natural) -> p ZipperMove (f ZipperMove))
-> p Natural (f Natural)
-> p r (f r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p Natural (f Natural) -> p ZipperMove (f ZipperMove)
forall r. AsZipperMove r => Prism' r Natural
_L
  _R    = p ZipperMove (f ZipperMove) -> p r (f r)
forall r. AsZipperMove r => Prism' r ZipperMove
_ZipperMove (p ZipperMove (f ZipperMove) -> p r (f r))
-> (p Natural (f Natural) -> p ZipperMove (f ZipperMove))
-> p Natural (f Natural)
-> p r (f r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p Natural (f Natural) -> p ZipperMove (f ZipperMove)
forall r. AsZipperMove r => Prism' r Natural
_R

instance AsZipperMove ZipperMove where
  _ZipperMove :: p ZipperMove (f ZipperMove) -> p ZipperMove (f ZipperMove)
_ZipperMove = p ZipperMove (f ZipperMove) -> p ZipperMove (f ZipperMove)
forall a. a -> a
id

  _U :: p () (f ()) -> p ZipperMove (f ZipperMove)
_U = (() -> ZipperMove)
-> (ZipperMove -> Either ZipperMove ()) -> Prism' ZipperMove ()
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
L.prism (ZipperMove -> () -> ZipperMove
forall a b. a -> b -> a
const ZipperMove
U)
       (\ZipperMove
x -> case ZipperMove
x of
           ZipperMove
U -> () -> Either ZipperMove ()
forall a b. b -> Either a b
Right ()
           ZipperMove
_ -> ZipperMove -> Either ZipperMove ()
forall a b. a -> Either a b
Left ZipperMove
x
       )

  _D :: p () (f ()) -> p ZipperMove (f ZipperMove)
_D = (() -> ZipperMove)
-> (ZipperMove -> Either ZipperMove ()) -> Prism' ZipperMove ()
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
L.prism (ZipperMove -> () -> ZipperMove
forall a b. a -> b -> a
const ZipperMove
D)
       (\ZipperMove
x -> case ZipperMove
x of
           ZipperMove
D -> () -> Either ZipperMove ()
forall a b. b -> Either a b
Right ()
           ZipperMove
_ -> ZipperMove -> Either ZipperMove ()
forall a b. a -> Either a b
Left ZipperMove
x
       )

  _DAt :: p Text (f Text) -> p ZipperMove (f ZipperMove)
_DAt = (Text -> ZipperMove)
-> (ZipperMove -> Either ZipperMove Text) -> Prism' ZipperMove Text
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
L.prism Text -> ZipperMove
DAt
         (\ZipperMove
x -> case ZipperMove
x of
             DAt Text
y -> Text -> Either ZipperMove Text
forall a b. b -> Either a b
Right Text
y
             ZipperMove
_     -> ZipperMove -> Either ZipperMove Text
forall a b. a -> Either a b
Left ZipperMove
x
         )

  _Item :: p Text (f Text) -> p ZipperMove (f ZipperMove)
_Item = (Text -> ZipperMove)
-> (ZipperMove -> Either ZipperMove Text) -> Prism' ZipperMove Text
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
L.prism Text -> ZipperMove
Item
          (\ZipperMove
x -> case ZipperMove
x of
              Item Text
y -> Text -> Either ZipperMove Text
forall a b. b -> Either a b
Right Text
y
              ZipperMove
_      -> ZipperMove -> Either ZipperMove Text
forall a b. a -> Either a b
Left ZipperMove
x
          )

  _L :: p Natural (f Natural) -> p ZipperMove (f ZipperMove)
_L = (Natural -> ZipperMove)
-> (ZipperMove -> Either ZipperMove Natural)
-> Prism' ZipperMove Natural
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
L.prism Natural -> ZipperMove
L
       (\ZipperMove
x -> case ZipperMove
x of
           L Natural
y -> Natural -> Either ZipperMove Natural
forall a b. b -> Either a b
Right Natural
y
           ZipperMove
_   -> ZipperMove -> Either ZipperMove Natural
forall a b. a -> Either a b
Left ZipperMove
x
       )

  _R :: p Natural (f Natural) -> p ZipperMove (f ZipperMove)
_R = (Natural -> ZipperMove)
-> (ZipperMove -> Either ZipperMove Natural)
-> Prism' ZipperMove Natural
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
L.prism Natural -> ZipperMove
R
       (\ZipperMove
x -> case ZipperMove
x of
           R Natural
y -> Natural -> Either ZipperMove Natural
forall a b. b -> Either a b
Right Natural
y
           ZipperMove
_   -> ZipperMove -> Either ZipperMove Natural
forall a b. a -> Either a b
Left ZipperMove
x
       )