{-|
Copyright        : (c) Galois, Inc. 2025
Maintainer       : Langston Barrett <langston@galois.com>
-}

{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}

module Lang.Crucible.Debug.Style
  ( StyleEnv(..)
  , StyleT(..)
  , runStyle
  , runStyleM
  , Style(..)
  , Valid(..)
  , Styled(..)
  , style
  , highlighter
  ) where

import Control.Lens qualified as Lens
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Reader (MonadReader, ReaderT)
import Control.Monad.Reader qualified as Reader
import Control.Monad.Trans (MonadTrans)
import Data.Foldable (foldl', toList)
import Data.Functor.Identity (Identity, runIdentity)
import Data.List qualified as List
import Data.Parameterized.Some (Some(Some), viewSome)
import Data.Sequence qualified as Seq
import Data.Set qualified as Set
import Data.Set (Set)
import Data.Text qualified as Text
import Data.Text (Text)
import Lang.Crucible.Debug.Arg (Arg)
import Lang.Crucible.Debug.Arg qualified as Arg
import Lang.Crucible.Debug.Arg.Type (ArgTypeRepr)
import Lang.Crucible.Debug.Breakpoint (Breakpoint)
import Lang.Crucible.Debug.Command (CommandExt)
import Lang.Crucible.Debug.Command qualified as Cmd
import Lang.Crucible.Debug.Regex qualified as Rgx
import Lang.Crucible.FunctionHandle qualified as C
import Lang.Crucible.Simulator.ExecutionTree qualified as C
import Prettyprinter qualified as PP
import System.Console.Isocline qualified as Isocline

data StyleEnv cExt
  = forall p sym ext r.
    StyleEnv
  { forall cExt. StyleEnv cExt -> Set Breakpoint
envBreakpoints :: Set Breakpoint
  , forall cExt. StyleEnv cExt -> CommandExt cExt
envCommandExt :: CommandExt cExt
  , ()
envState :: C.ExecState p sym ext r
  }

newtype StyleT cExt m a
  = StyleT
    { forall cExt (m :: * -> *) a.
StyleT cExt m a -> ReaderT (StyleEnv cExt) m a
runStyleT :: ReaderT (StyleEnv cExt) m a }
  deriving (Functor (StyleT cExt m)
Functor (StyleT cExt m) =>
(forall a. a -> StyleT cExt m a)
-> (forall a b.
    StyleT cExt m (a -> b) -> StyleT cExt m a -> StyleT cExt m b)
-> (forall a b c.
    (a -> b -> c)
    -> StyleT cExt m a -> StyleT cExt m b -> StyleT cExt m c)
-> (forall a b.
    StyleT cExt m a -> StyleT cExt m b -> StyleT cExt m b)
-> (forall a b.
    StyleT cExt m a -> StyleT cExt m b -> StyleT cExt m a)
-> Applicative (StyleT cExt m)
forall a. a -> StyleT cExt m a
forall a b. StyleT cExt m a -> StyleT cExt m b -> StyleT cExt m a
forall a b. StyleT cExt m a -> StyleT cExt m b -> StyleT cExt m b
forall a b.
StyleT cExt m (a -> b) -> StyleT cExt m a -> StyleT cExt m b
forall a b c.
(a -> b -> c)
-> StyleT cExt m a -> StyleT cExt m b -> StyleT cExt m c
forall cExt (m :: * -> *). Applicative m => Functor (StyleT cExt m)
forall cExt (m :: * -> *) a. Applicative m => a -> StyleT cExt m a
forall cExt (m :: * -> *) a b.
Applicative m =>
StyleT cExt m a -> StyleT cExt m b -> StyleT cExt m a
forall cExt (m :: * -> *) a b.
Applicative m =>
StyleT cExt m a -> StyleT cExt m b -> StyleT cExt m b
forall cExt (m :: * -> *) a b.
Applicative m =>
StyleT cExt m (a -> b) -> StyleT cExt m a -> StyleT cExt m b
forall cExt (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> StyleT cExt m a -> StyleT cExt m b -> StyleT cExt m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall cExt (m :: * -> *) a. Applicative m => a -> StyleT cExt m a
pure :: forall a. a -> StyleT cExt m a
$c<*> :: forall cExt (m :: * -> *) a b.
Applicative m =>
StyleT cExt m (a -> b) -> StyleT cExt m a -> StyleT cExt m b
<*> :: forall a b.
StyleT cExt m (a -> b) -> StyleT cExt m a -> StyleT cExt m b
$cliftA2 :: forall cExt (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> StyleT cExt m a -> StyleT cExt m b -> StyleT cExt m c
liftA2 :: forall a b c.
(a -> b -> c)
-> StyleT cExt m a -> StyleT cExt m b -> StyleT cExt m c
$c*> :: forall cExt (m :: * -> *) a b.
Applicative m =>
StyleT cExt m a -> StyleT cExt m b -> StyleT cExt m b
*> :: forall a b. StyleT cExt m a -> StyleT cExt m b -> StyleT cExt m b
$c<* :: forall cExt (m :: * -> *) a b.
Applicative m =>
StyleT cExt m a -> StyleT cExt m b -> StyleT cExt m a
<* :: forall a b. StyleT cExt m a -> StyleT cExt m b -> StyleT cExt m a
Applicative, (forall a b. (a -> b) -> StyleT cExt m a -> StyleT cExt m b)
-> (forall a b. a -> StyleT cExt m b -> StyleT cExt m a)
-> Functor (StyleT cExt m)
forall a b. a -> StyleT cExt m b -> StyleT cExt m a
forall a b. (a -> b) -> StyleT cExt m a -> StyleT cExt m b
forall cExt (m :: * -> *) a b.
Functor m =>
a -> StyleT cExt m b -> StyleT cExt m a
forall cExt (m :: * -> *) a b.
Functor m =>
(a -> b) -> StyleT cExt m a -> StyleT cExt m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall cExt (m :: * -> *) a b.
Functor m =>
(a -> b) -> StyleT cExt m a -> StyleT cExt m b
fmap :: forall a b. (a -> b) -> StyleT cExt m a -> StyleT cExt m b
$c<$ :: forall cExt (m :: * -> *) a b.
Functor m =>
a -> StyleT cExt m b -> StyleT cExt m a
<$ :: forall a b. a -> StyleT cExt m b -> StyleT cExt m a
Functor, Applicative (StyleT cExt m)
Applicative (StyleT cExt m) =>
(forall a b.
 StyleT cExt m a -> (a -> StyleT cExt m b) -> StyleT cExt m b)
-> (forall a b.
    StyleT cExt m a -> StyleT cExt m b -> StyleT cExt m b)
-> (forall a. a -> StyleT cExt m a)
-> Monad (StyleT cExt m)
forall a. a -> StyleT cExt m a
forall a b. StyleT cExt m a -> StyleT cExt m b -> StyleT cExt m b
forall a b.
StyleT cExt m a -> (a -> StyleT cExt m b) -> StyleT cExt m b
forall cExt (m :: * -> *). Monad m => Applicative (StyleT cExt m)
forall cExt (m :: * -> *) a. Monad m => a -> StyleT cExt m a
forall cExt (m :: * -> *) a b.
Monad m =>
StyleT cExt m a -> StyleT cExt m b -> StyleT cExt m b
forall cExt (m :: * -> *) a b.
Monad m =>
StyleT cExt m a -> (a -> StyleT cExt m b) -> StyleT cExt m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall cExt (m :: * -> *) a b.
Monad m =>
StyleT cExt m a -> (a -> StyleT cExt m b) -> StyleT cExt m b
>>= :: forall a b.
StyleT cExt m a -> (a -> StyleT cExt m b) -> StyleT cExt m b
$c>> :: forall cExt (m :: * -> *) a b.
Monad m =>
StyleT cExt m a -> StyleT cExt m b -> StyleT cExt m b
>> :: forall a b. StyleT cExt m a -> StyleT cExt m b -> StyleT cExt m b
$creturn :: forall cExt (m :: * -> *) a. Monad m => a -> StyleT cExt m a
return :: forall a. a -> StyleT cExt m a
Monad, Monad (StyleT cExt m)
Monad (StyleT cExt m) =>
(forall a. String -> StyleT cExt m a) -> MonadFail (StyleT cExt m)
forall a. String -> StyleT cExt m a
forall cExt (m :: * -> *). MonadFail m => Monad (StyleT cExt m)
forall cExt (m :: * -> *) a.
MonadFail m =>
String -> StyleT cExt m a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
$cfail :: forall cExt (m :: * -> *) a.
MonadFail m =>
String -> StyleT cExt m a
fail :: forall a. String -> StyleT cExt m a
MonadFail, Monad (StyleT cExt m)
Monad (StyleT cExt m) =>
(forall a. IO a -> StyleT cExt m a) -> MonadIO (StyleT cExt m)
forall a. IO a -> StyleT cExt m a
forall cExt (m :: * -> *). MonadIO m => Monad (StyleT cExt m)
forall cExt (m :: * -> *) a. MonadIO m => IO a -> StyleT cExt m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall cExt (m :: * -> *) a. MonadIO m => IO a -> StyleT cExt m a
liftIO :: forall a. IO a -> StyleT cExt m a
MonadIO, MonadReader (StyleEnv cExt), (forall (m :: * -> *). Monad m => Monad (StyleT cExt m)) =>
(forall (m :: * -> *) a. Monad m => m a -> StyleT cExt m a)
-> MonadTrans (StyleT cExt)
forall cExt (m :: * -> *). Monad m => Monad (StyleT cExt m)
forall cExt (m :: * -> *) a. Monad m => m a -> StyleT cExt m a
forall (m :: * -> *). Monad m => Monad (StyleT cExt m)
forall (m :: * -> *) a. Monad m => m a -> StyleT cExt m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *). Monad m => Monad (t m)) =>
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
$clift :: forall cExt (m :: * -> *) a. Monad m => m a -> StyleT cExt m a
lift :: forall (m :: * -> *) a. Monad m => m a -> StyleT cExt m a
MonadTrans)

-- | Run 'StyleT' over 'Identity'
runStyle :: StyleEnv cExt -> StyleT cExt Identity a -> a
runStyle :: forall cExt a. StyleEnv cExt -> StyleT cExt Identity a -> a
runStyle StyleEnv cExt
env StyleT cExt Identity a
s = Identity a -> a
forall a. Identity a -> a
runIdentity (ReaderT (StyleEnv cExt) Identity a -> StyleEnv cExt -> Identity a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
Reader.runReaderT (StyleT cExt Identity a -> ReaderT (StyleEnv cExt) Identity a
forall cExt (m :: * -> *) a.
StyleT cExt m a -> ReaderT (StyleEnv cExt) m a
runStyleT StyleT cExt Identity a
s) StyleEnv cExt
env)

-- | Run 'StyleT' over another monad
--
-- This is kind of poorly named, but I can\'t think of a better name...
runStyleM :: StyleEnv cExt -> StyleT cExt m a -> m a
runStyleM :: forall cExt (m :: * -> *) a.
StyleEnv cExt -> StyleT cExt m a -> m a
runStyleM StyleEnv cExt
env StyleT cExt m a
s = ReaderT (StyleEnv cExt) m a -> StyleEnv cExt -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
Reader.runReaderT (StyleT cExt m a -> ReaderT (StyleEnv cExt) m a
forall cExt (m :: * -> *) a.
StyleT cExt m a -> ReaderT (StyleEnv cExt) m a
runStyleT StyleT cExt m a
s) StyleEnv cExt
env

data Style
  = SBreakpoint
  | SCommand
  | SExactly
  | SFunction
  | SNumber
  | SPath
  | SText
  | SUnknown
  deriving (Style -> Style -> Bool
(Style -> Style -> Bool) -> (Style -> Style -> Bool) -> Eq Style
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Style -> Style -> Bool
== :: Style -> Style -> Bool
$c/= :: Style -> Style -> Bool
/= :: Style -> Style -> Bool
Eq, Int -> Style -> ShowS
[Style] -> ShowS
Style -> String
(Int -> Style -> ShowS)
-> (Style -> String) -> ([Style] -> ShowS) -> Show Style
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Style -> ShowS
showsPrec :: Int -> Style -> ShowS
$cshow :: Style -> String
show :: Style -> String
$cshowList :: [Style] -> ShowS
showList :: [Style] -> ShowS
Show)

instance PP.Pretty Style where
  pretty :: forall ann. Style -> Doc ann
pretty =
    \case
      Style
SBreakpoint -> Doc ann
"breakpoint"
      Style
SCommand -> Doc ann
"command"
      Style
SExactly -> Doc ann
"exactly"
      Style
SFunction -> Doc ann
"function"
      Style
SNumber -> Doc ann
"number"
      Style
SPath -> Doc ann
"path"
      Style
SText -> Doc ann
"text"
      Style
SUnknown -> Doc ann
"unknown"

styleFor :: Arg cExt t -> Style
styleFor :: forall cExt (t :: ArgType). Arg cExt t -> Style
styleFor =
  \case
    Arg.ABreakpoint {} -> Style
SBreakpoint
    Arg.ACommand {} -> Style
SCommand
    Arg.AExactly {} -> Style
SExactly
    Arg.AFunction {} -> Style
SFunction
    Arg.AInt {} -> Style
SNumber
    Arg.APath {} -> Style
SPath
    Arg.AText {} -> Style
SText

data Valid
  = Invalid
  | Valid
  | Unknown
  deriving (Valid -> Valid -> Bool
(Valid -> Valid -> Bool) -> (Valid -> Valid -> Bool) -> Eq Valid
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Valid -> Valid -> Bool
== :: Valid -> Valid -> Bool
$c/= :: Valid -> Valid -> Bool
/= :: Valid -> Valid -> Bool
Eq, Int -> Valid -> ShowS
[Valid] -> ShowS
Valid -> String
(Int -> Valid -> ShowS)
-> (Valid -> String) -> ([Valid] -> ShowS) -> Show Valid
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Valid -> ShowS
showsPrec :: Int -> Valid -> ShowS
$cshow :: Valid -> String
show :: Valid -> String
$cshowList :: [Valid] -> ShowS
showList :: [Valid] -> ShowS
Show)

instance PP.Pretty Valid where
  pretty :: forall ann. Valid -> Doc ann
pretty =
    \case
      Valid
Invalid -> Doc ann
"invalid"
      Valid
Valid -> Doc ann
"valid"
      Valid
Unknown -> Doc ann
"unknown"

boolToValid :: Bool -> Valid
boolToValid :: Bool -> Valid
boolToValid Bool
False = Valid
Invalid
boolToValid Bool
True = Valid
Valid

validate ::
  Monad m =>
  Arg cExt t ->
  StyleT cExt m Valid
validate :: forall (m :: * -> *) cExt (t :: ArgType).
Monad m =>
Arg cExt t -> StyleT cExt m Valid
validate =
  \case
    Arg.ACommand {} -> Valid -> StyleT cExt m Valid
forall a. a -> StyleT cExt m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Valid
Valid
    Arg.ABreakpoint Breakpoint
b ->
      Bool -> Valid
boolToValid (Bool -> Valid) -> StyleT cExt m Bool -> StyleT cExt m Valid
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StyleEnv cExt -> Bool) -> StyleT cExt m Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
Reader.asks (Breakpoint -> Set Breakpoint -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Breakpoint
b (Set Breakpoint -> Bool)
-> (StyleEnv cExt -> Set Breakpoint) -> StyleEnv cExt -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StyleEnv cExt -> Set Breakpoint
forall cExt. StyleEnv cExt -> Set Breakpoint
envBreakpoints)
    Arg.AExactly {} -> Valid -> StyleT cExt m Valid
forall a. a -> StyleT cExt m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Valid
Valid
    Arg.AFunction FunctionName
fNm -> do
      StyleEnv { envState :: ()
envState = ExecState p sym ext r
execState } <- StyleT cExt m (StyleEnv cExt)
forall r (m :: * -> *). MonadReader r m => m r
Reader.ask
      let binds :: FunctionBindings p sym ext
binds = ExecState p sym ext r
execState ExecState p sym ext r
-> Getting
     (FunctionBindings p sym ext)
     (ExecState p sym ext r)
     (FunctionBindings p sym ext)
-> FunctionBindings p sym ext
forall s a. s -> Getting a s a -> a
Lens.^. (ExecState p sym ext r -> SimContext p sym ext)
-> (SimContext p sym ext
    -> Const (FunctionBindings p sym ext) (SimContext p sym ext))
-> ExecState p sym ext r
-> Const (FunctionBindings p sym ext) (ExecState p sym ext r)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
Lens.to ExecState p sym ext r -> SimContext p sym ext
forall p sym ext r. ExecState p sym ext r -> SimContext p sym ext
C.execStateContext ((SimContext p sym ext
  -> Const (FunctionBindings p sym ext) (SimContext p sym ext))
 -> ExecState p sym ext r
 -> Const (FunctionBindings p sym ext) (ExecState p sym ext r))
-> ((FunctionBindings p sym ext
     -> Const (FunctionBindings p sym ext) (FunctionBindings p sym ext))
    -> SimContext p sym ext
    -> Const (FunctionBindings p sym ext) (SimContext p sym ext))
-> Getting
     (FunctionBindings p sym ext)
     (ExecState p sym ext r)
     (FunctionBindings p sym ext)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FunctionBindings p sym ext
 -> Const (FunctionBindings p sym ext) (FunctionBindings p sym ext))
-> SimContext p sym ext
-> Const (FunctionBindings p sym ext) (SimContext p sym ext)
forall p sym ext (f :: * -> *).
Functor f =>
(FunctionBindings p sym ext -> f (FunctionBindings p sym ext))
-> SimContext p sym ext -> f (SimContext p sym ext)
C.functionBindings
      let hdls :: [SomeHandle]
hdls = FnHandleMap (FnState p sym ext) -> [SomeHandle]
forall (f :: Ctx CrucibleType -> CrucibleType -> *).
FnHandleMap f -> [SomeHandle]
C.handleMapToHandles (FunctionBindings p sym ext -> FnHandleMap (FnState p sym ext)
forall p sym ext.
FunctionBindings p sym ext -> FnHandleMap (FnState p sym ext)
C.fnBindings FunctionBindings p sym ext
binds)
      case (SomeHandle -> Bool) -> [SomeHandle] -> Maybe SomeHandle
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (\(C.SomeHandle FnHandle args ret
hdl) -> FnHandle args ret -> FunctionName
forall (args :: Ctx CrucibleType) (ret :: CrucibleType).
FnHandle args ret -> FunctionName
C.handleName FnHandle args ret
hdl FunctionName -> FunctionName -> Bool
forall a. Eq a => a -> a -> Bool
== FunctionName
fNm) [SomeHandle]
hdls of
        Maybe SomeHandle
Nothing ->
          -- May just not yet be loaded/discovered
          Valid -> StyleT cExt m Valid
forall a. a -> StyleT cExt m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Valid
Unknown
        Just {} -> Valid -> StyleT cExt m Valid
forall a. a -> StyleT cExt m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Valid
Valid
    Arg.AInt {} -> Valid -> StyleT cExt m Valid
forall a. a -> StyleT cExt m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Valid
Valid
    Arg.APath {} -> Valid -> StyleT cExt m Valid
forall a. a -> StyleT cExt m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Valid
Valid
    Arg.AText {} -> Valid -> StyleT cExt m Valid
forall a. a -> StyleT cExt m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Valid
Valid

data Styled
  = Styled
    { Styled -> Style
styledStyle :: Style
    , Styled -> Valid
styledValid :: Valid
    }
  deriving (Styled -> Styled -> Bool
(Styled -> Styled -> Bool)
-> (Styled -> Styled -> Bool) -> Eq Styled
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Styled -> Styled -> Bool
== :: Styled -> Styled -> Bool
$c/= :: Styled -> Styled -> Bool
/= :: Styled -> Styled -> Bool
Eq, Int -> Styled -> ShowS
[Styled] -> ShowS
Styled -> String
(Int -> Styled -> ShowS)
-> (Styled -> String) -> ([Styled] -> ShowS) -> Show Styled
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Styled -> ShowS
showsPrec :: Int -> Styled -> ShowS
$cshow :: Styled -> String
show :: Styled -> String
$cshowList :: [Styled] -> ShowS
showList :: [Styled] -> ShowS
Show)

instance PP.Pretty Styled where
  pretty :: forall ann. Styled -> Doc ann
pretty Styled
s =
    Style -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Style -> Doc ann
PP.pretty (Styled -> Style
styledStyle Styled
s) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
PP.<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
PP.parens (Valid -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Valid -> Doc ann
PP.pretty (Styled -> Valid
styledValid Styled
s))

styled ::
  Monad m =>
  Arg cExt t ->
  StyleT cExt m Styled
styled :: forall (m :: * -> *) cExt (t :: ArgType).
Monad m =>
Arg cExt t -> StyleT cExt m Styled
styled Arg cExt t
a = Style -> Valid -> Styled
Styled (Arg cExt t -> Style
forall cExt (t :: ArgType). Arg cExt t -> Style
styleFor Arg cExt t
a) (Valid -> Styled) -> StyleT cExt m Valid -> StyleT cExt m Styled
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Arg cExt t -> StyleT cExt m Valid
forall (m :: * -> *) cExt (t :: ArgType).
Monad m =>
Arg cExt t -> StyleT cExt m Valid
validate Arg cExt t
a

style ::
  Monad m =>
  Rgx.RegexRepr ArgTypeRepr r ->
  [Text] ->
  StyleT cExt m [Styled]
style :: forall (m :: * -> *) (r :: Regex ArgType) cExt.
Monad m =>
RegexRepr ArgTypeRepr r -> [Text] -> StyleT cExt m [Styled]
style RegexRepr ArgTypeRepr r
r =
  \case
    [] -> [Styled] -> StyleT cExt m [Styled]
forall a. a -> StyleT cExt m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    (Text
word : [Text]
ws) -> do
      CommandExt cExt
cExt <- (StyleEnv cExt -> CommandExt cExt)
-> StyleT cExt m (CommandExt cExt)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
Reader.asks StyleEnv cExt -> CommandExt cExt
forall cExt. StyleEnv cExt -> CommandExt cExt
envCommandExt
      let bad :: [Styled]
bad = Int -> Styled -> [Styled]
forall a. Int -> a -> [a]
List.replicate (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
ws) (Style -> Valid -> Styled
Styled Style
SUnknown Valid
Invalid)
      case CommandExt cExt
-> Text
-> RegexRepr ArgTypeRepr r
-> DerivativeResult ArgTypeRepr (Arg cExt)
forall cExt (r :: Regex ArgType).
CommandExt cExt
-> Text
-> RegexRepr ArgTypeRepr r
-> DerivativeResult ArgTypeRepr (Arg cExt)
Arg.derivative CommandExt cExt
cExt Text
word RegexRepr ArgTypeRepr r
r of
        Rgx.DerivativeResult (Some RegexRepr ArgTypeRepr x
Rgx.Fail) Seq (Some (Arg cExt))
_ -> [Styled] -> StyleT cExt m [Styled]
forall a. a -> StyleT cExt m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Styled]
bad
        Rgx.DerivativeResult (Some RegexRepr ArgTypeRepr x
_) Seq (Some (Arg cExt))
Seq.Empty -> [Styled] -> StyleT cExt m [Styled]
forall a. a -> StyleT cExt m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Styled]
bad
        Rgx.DerivativeResult (Some RegexRepr ArgTypeRepr x
r') (Some Arg cExt x
m Seq.:<| Seq (Some (Arg cExt))
Seq.Empty) -> do
          Styled
s <- Arg cExt x -> StyleT cExt m Styled
forall (m :: * -> *) cExt (t :: ArgType).
Monad m =>
Arg cExt t -> StyleT cExt m Styled
styled Arg cExt x
m
          [Styled]
ss <- RegexRepr ArgTypeRepr x -> [Text] -> StyleT cExt m [Styled]
forall (m :: * -> *) (r :: Regex ArgType) cExt.
Monad m =>
RegexRepr ArgTypeRepr r -> [Text] -> StyleT cExt m [Styled]
style RegexRepr ArgTypeRepr x
r' [Text]
ws
          [Styled] -> StyleT cExt m [Styled]
forall a. a -> StyleT cExt m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Styled
s Styled -> [Styled] -> [Styled]
forall a. a -> [a] -> [a]
: [Styled]
ss)
        Rgx.DerivativeResult (Some RegexRepr ArgTypeRepr x
r') (Some Arg cExt x
m Seq.:<| Seq (Some (Arg cExt))
ms) -> do
          Styled
s <- Arg cExt x -> StyleT cExt m Styled
forall (m :: * -> *) cExt (t :: ArgType).
Monad m =>
Arg cExt t -> StyleT cExt m Styled
styled Arg cExt x
m
          [Styled]
ss <- (Some (Arg cExt) -> StyleT cExt m Styled)
-> [Some (Arg cExt)] -> StyleT cExt m [Styled]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((forall (tp :: ArgType). Arg cExt tp -> StyleT cExt m Styled)
-> Some (Arg cExt) -> StyleT cExt m Styled
forall {k} (f :: k -> *) r.
(forall (tp :: k). f tp -> r) -> Some f -> r
viewSome Arg cExt tp -> StyleT cExt m Styled
forall (tp :: ArgType). Arg cExt tp -> StyleT cExt m Styled
forall (m :: * -> *) cExt (t :: ArgType).
Monad m =>
Arg cExt t -> StyleT cExt m Styled
styled) (Seq (Some (Arg cExt)) -> [Some (Arg cExt)]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (Some (Arg cExt))
ms)
          let combined :: Styled
combined = (Styled -> Styled -> Styled) -> Styled -> [Styled] -> Styled
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Styled -> Styled -> Styled
combineStyled Styled
s [Styled]
ss
          [Styled]
rest <- RegexRepr ArgTypeRepr x -> [Text] -> StyleT cExt m [Styled]
forall (m :: * -> *) (r :: Regex ArgType) cExt.
Monad m =>
RegexRepr ArgTypeRepr r -> [Text] -> StyleT cExt m [Styled]
style RegexRepr ArgTypeRepr x
r' [Text]
ws
          [Styled] -> StyleT cExt m [Styled]
forall a. a -> StyleT cExt m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Styled
combined Styled -> [Styled] -> [Styled]
forall a. a -> [a] -> [a]
: [Styled]
rest)
  where
    combineStyles :: Style -> Style -> Style
    combineStyles :: Style -> Style -> Style
combineStyles Style
s0 Style
s = if Style
s Style -> Style -> Bool
forall a. Eq a => a -> a -> Bool
== Style
s0 then Style
s0 else Style
SUnknown

    combineValid :: Valid -> Valid -> Valid
    combineValid :: Valid -> Valid -> Valid
combineValid Valid
v0 Valid
v = if Valid
v Valid -> Valid -> Bool
forall a. Eq a => a -> a -> Bool
== Valid
v0 then Valid
v0 else Valid
Unknown

    combineStyled :: Styled -> Styled -> Styled
    combineStyled :: Styled -> Styled -> Styled
combineStyled Styled
s0 Styled
s =
      Style -> Valid -> Styled
Styled
      (Style -> Style -> Style
combineStyles (Styled -> Style
styledStyle Styled
s0) (Styled -> Style
styledStyle Styled
s))
      (Valid -> Valid -> Valid
combineValid (Styled -> Valid
styledValid Styled
s0) (Styled -> Valid
styledValid Styled
s))

-- | Helper, not exported
badStyle :: String -> Isocline.Fmt
badStyle :: ShowS
badStyle = String -> ShowS
Isocline.style String
"red"

-- | Helper, not exported
cmdStyle :: String -> Isocline.Fmt
cmdStyle :: ShowS
cmdStyle = String -> ShowS
Isocline.style String
"bold"

highlightWithRegex ::
  Monad m =>
  Rgx.RegexRepr ArgTypeRepr r ->
  String ->
  StyleT cExt m Isocline.Fmt
highlightWithRegex :: forall (m :: * -> *) (r :: Regex ArgType) cExt.
Monad m =>
RegexRepr ArgTypeRepr r -> String -> StyleT cExt m String
highlightWithRegex RegexRepr ArgTypeRepr r
r String
line = do
  let (String
initSpaces, [(String, String)]
rest) = String -> (String, [(String, String)])
splitOnSpaces String
line
  let wds :: [String]
wds = ((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
List.map (String, String) -> String
forall a b. (a, b) -> a
fst [(String, String)]
rest
  [Styled]
styles <- RegexRepr ArgTypeRepr r -> [Text] -> StyleT cExt m [Styled]
forall (m :: * -> *) (r :: Regex ArgType) cExt.
Monad m =>
RegexRepr ArgTypeRepr r -> [Text] -> StyleT cExt m [Styled]
style RegexRepr ArgTypeRepr r
r ((String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
List.map String -> Text
Text.pack [String]
wds)
  let styledWords :: [String]
styledWords = (ShowS -> ShowS) -> [ShowS] -> [String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ShowS -> ShowS
forall a b. (a -> b) -> a -> b
($) ((Styled -> ShowS) -> [Styled] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map Styled -> ShowS
doStyle [Styled]
styles) [String]
wds
  let wordsWithSpaces :: String
wordsWithSpaces =
        ((String, String) -> String) -> [(String, String)] -> String
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((String -> ShowS) -> (String, String) -> String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> ShowS
forall a. [a] -> [a] -> [a]
(++)) ([String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
styledWords (((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
List.map (String, String) -> String
forall a b. (a, b) -> b
snd [(String, String)]
rest))
  String -> StyleT cExt m String
forall a. a -> StyleT cExt m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
initSpaces String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
wordsWithSpaces)
  where
    splitOnSpaces :: String -> (String, [(String, String)])
    splitOnSpaces :: String -> (String, [(String, String)])
splitOnSpaces String
s =
      let (String
initSpaces, String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') String
s in
      (String
initSpaces, String -> [(String, String)]
go String
rest)
      where
        go :: String -> [(String, String)]
go String
"" = []
        go String
x =
          let (String
word, String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ') String
x in
          let (String
spaces, String
rest') = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') String
rest in
          (String
word, String
spaces) (String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
: String -> [(String, String)]
go String
rest'

    -- Fairly arbitrary choices
    doStyle :: Styled -> String -> Isocline.Fmt
    doStyle :: Styled -> ShowS
doStyle Styled
s =
      case Styled -> Valid
styledValid Styled
s of
        Valid
Invalid -> ShowS
badStyle
        Valid
_ ->
          case Styled -> Style
styledStyle Styled
s of
            Style
SBreakpoint -> String -> ShowS
Isocline.style String
"green"
            Style
SCommand -> ShowS
cmdStyle
            Style
SExactly -> String -> ShowS
Isocline.style String
"keyword"
            Style
SFunction -> String -> ShowS
Isocline.style String
"blue"
            Style
SNumber -> String -> ShowS
Isocline.style String
"number"
            Style
SPath -> String -> ShowS
Isocline.style String
"italic"
            Style
SText -> ShowS
forall a. a -> a
id
            Style
SUnknown -> ShowS
forall a. a -> a
id

highlighter :: Monad m => String -> StyleT cExt m Isocline.Fmt
highlighter :: forall (m :: * -> *) cExt.
Monad m =>
String -> StyleT cExt m String
highlighter String
input = do
  CommandExt cExt
cExt <- (StyleEnv cExt -> CommandExt cExt)
-> StyleT cExt m (CommandExt cExt)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
Reader.asks StyleEnv cExt -> CommandExt cExt
forall cExt. StyleEnv cExt -> CommandExt cExt
envCommandExt
  let (String
initSpaces, String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') String
input
  let (String
cmdStr, String
rest') = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ') String
rest
  case CommandExt cExt -> Text -> Maybe (Command cExt)
forall cExt. CommandExt cExt -> Text -> Maybe (Command cExt)
Cmd.parse CommandExt cExt
cExt (String -> Text
Text.pack String
cmdStr) of
    Just Command cExt
cmd ->
      case CommandExt cExt -> Command cExt -> Some (RegexRepr ArgTypeRepr)
forall cExt.
CommandExt cExt -> Command cExt -> Some (RegexRepr ArgTypeRepr)
Cmd.regex CommandExt cExt
cExt Command cExt
cmd of
        Some RegexRepr ArgTypeRepr x
rx -> do
          String
styledRest <- RegexRepr ArgTypeRepr x -> String -> StyleT cExt m String
forall (m :: * -> *) (r :: Regex ArgType) cExt.
Monad m =>
RegexRepr ArgTypeRepr r -> String -> StyleT cExt m String
highlightWithRegex RegexRepr ArgTypeRepr x
rx String
rest'
          String -> StyleT cExt m String
forall a. a -> StyleT cExt m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> StyleT cExt m String) -> String -> StyleT cExt m String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
List.concat [String
initSpaces , ShowS
cmdStyle String
cmdStr, String
styledRest]
    Maybe (Command cExt)
Nothing -> String -> StyleT cExt m String
forall a. a -> StyleT cExt m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> StyleT cExt m String) -> String -> StyleT cExt m String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
List.concat [String
initSpaces, ShowS
badStyle String
cmdStr, String
rest']