{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-matches -fno-warn-unused-imports #-}

module Technique.Diagnostics where

import Core.System.Pretty
import Core.Text.Rope
import Core.Text.Utilities
import Data.DList (toList)
import Data.Foldable (foldl')
import Data.Int (Int8)
import Technique.Formatter -- already have lots of useful definitions
import Technique.Internal
import Technique.Language

instance Render Function where
  type Token Function = TechniqueToken
  colourize :: Token Function -> AnsiColour
colourize = Token Function -> AnsiColour
TechniqueToken -> AnsiColour
colourizeTechnique
  highlight :: Function -> Doc (Token Function)
highlight Function
func =
    Int -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Int -> Doc ann -> Doc ann
nest
      Int
3
      ( Doc TechniqueToken
" ↘ "
          Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> ( case Function
func of
                 Unresolved Identifier
i ->
                   TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
ErrorToken Doc TechniqueToken
"Unresolved" Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
ProcedureToken (Rope -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty (Identifier -> Rope
unIdentifier Identifier
i)) Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
forall ann. Doc ann
line
                 Subroutine Procedure
proc Step
step ->
                   TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
StepToken Doc TechniqueToken
"Subroutine" Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
ProcedureToken (Identifier -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty (Procedure -> Identifier
procedureName Procedure
proc))
                     Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
forall ann. Doc ann
line
                     Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> (Int -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Int -> Doc ann -> Doc ann
nest Int
3 (Doc TechniqueToken
" ↘ " Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Step -> Doc (Token Step)
forall α. Render α => α -> Doc (Token α)
highlight Step
step))
                 Primitive Procedure
proc Step -> IO Value
action ->
                   TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
StepToken Doc TechniqueToken
"Primitive" Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
ProcedureToken (Identifier -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty (Procedure -> Identifier
procedureName Procedure
proc))
                     Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
forall ann. Doc ann
line
                     Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
" ↘ <primitive>"
             )
      )

instance Render Step where
  type Token Step = TechniqueToken
  colourize :: Token Step -> AnsiColour
colourize = Token Step -> AnsiColour
TechniqueToken -> AnsiColour
colourizeTechnique
  highlight :: Step -> Doc (Token Step)
highlight Step
step = case Step
step of
    Known Int
_ Value
value ->
      TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
StepToken Doc TechniqueToken
"Known" Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Value -> Doc (Token Value)
forall α. Render α => α -> Doc (Token α)
highlight Value
value
    Depends Int
_ Name
name ->
      TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
StepToken Doc TechniqueToken
"Depends" Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Name -> Doc (Token Name)
forall α. Render α => α -> Doc (Token α)
highlight Name
name
    Step
NoOp ->
      TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
ErrorToken Doc TechniqueToken
"NoOp"
    Tuple Int
_ [Step]
steps ->
      TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
StepToken Doc TechniqueToken
"Tuple"
        Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc TechniqueToken
forall ann. Doc ann
lparen
        Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc TechniqueToken] -> Doc TechniqueToken
forall ann. [Doc ann] -> Doc ann
hsep (Doc TechniqueToken -> [Doc TechniqueToken] -> [Doc TechniqueToken]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc TechniqueToken
forall ann. Doc ann
comma ((Step -> Doc TechniqueToken) -> [Step] -> [Doc TechniqueToken]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Step -> Doc TechniqueToken
forall α. Render α => α -> Doc (Token α)
highlight [Step]
steps))
        Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc TechniqueToken
forall ann. Doc ann
rparen
    Nested Int
_ DList Step
steps ->
      [Doc TechniqueToken] -> Doc TechniqueToken
forall ann. [Doc ann] -> Doc ann
vcat (DList (Doc TechniqueToken) -> [Doc TechniqueToken]
forall a. DList a -> [a]
toList ((Step -> Doc TechniqueToken)
-> DList Step -> DList (Doc TechniqueToken)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Step -> Doc TechniqueToken
forall α. Render α => α -> Doc (Token α)
highlight DList Step
steps))
    Asynchronous Int
_ [Name]
names Step
substep ->
      TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
StepToken Doc TechniqueToken
"Asynch" Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Name] -> Doc (Token Name)
forall a.
(Render a, Token a ~ TechniqueToken) =>
[a] -> Doc (Token a)
commaCat [Name]
names Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc TechniqueToken
"◀-" Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Step -> Doc (Token Step)
forall α. Render α => α -> Doc (Token α)
highlight Step
substep
    Invocation Int
_ Attribute
attr Function
func Step
substep ->
      let i :: Identifier
i = Function -> Identifier
functionName Function
func
       in TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
StepToken Doc TechniqueToken
"Invoke" Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Attribute -> Doc (Token Attribute)
forall α. Render α => α -> Doc (Token α)
highlight Attribute
attr Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
ApplicationToken (Identifier -> Doc (Token Identifier)
forall α. Render α => α -> Doc (Token α)
highlight Identifier
i)
            Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
forall ann. Doc ann
line
            Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Int -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Int -> Doc ann -> Doc ann
nest Int
3 (Doc TechniqueToken
" ↘ " Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Step -> Doc (Token Step)
forall α. Render α => α -> Doc (Token α)
highlight Step
substep)
    Bench Int
_ [(Label, Step)]
pairs ->
      -- [(Label,Step)]
      TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
StepToken Doc TechniqueToken
"Bench"
        Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
forall ann. Doc ann
line
        Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
"   "
        Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Int -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Int -> Doc ann -> Doc ann
hang
          Int
2
          ( Doc TechniqueToken
forall ann. Doc ann
lbracket
              Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc TechniqueToken] -> Doc TechniqueToken
forall ann. [Doc ann] -> Doc ann
vsep (Doc TechniqueToken -> [Doc TechniqueToken] -> [Doc TechniqueToken]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc TechniqueToken
forall ann. Doc ann
comma [Doc TechniqueToken]
bindings)
          )
          Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc TechniqueToken
forall ann. Doc ann
rbracket
      where
        bindings :: [Doc TechniqueToken]
bindings = ((Label, Step) -> Doc TechniqueToken)
-> [(Label, Step)] -> [Doc TechniqueToken]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Label, Step) -> Doc TechniqueToken
f [(Label, Step)]
pairs
        f :: (Label, Step) -> Doc TechniqueToken
        f :: (Label, Step) -> Doc TechniqueToken
f (Label
label, Step
substep) =
          Label -> Doc (Token Label)
forall α. Render α => α -> Doc (Token α)
highlight Label
label Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc TechniqueToken
"◀-" Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Step -> Doc (Token Step)
forall α. Render α => α -> Doc (Token α)
highlight Step
substep

instance Render Name where
  type Token Name = TechniqueToken
  colourize :: Token Name -> AnsiColour
colourize = Token Name -> AnsiColour
TechniqueToken -> AnsiColour
colourizeTechnique
  highlight :: Name -> Doc (Token Name)
highlight (Name Rope
name) = TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
VariableToken (Rope -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty Rope
name)

instance Render Value where
  type Token Value = TechniqueToken
  colourize :: Token Value -> AnsiColour
colourize = Token Value -> AnsiColour
TechniqueToken -> AnsiColour
colourizeTechnique
  highlight :: Value -> Doc (Token Value)
highlight Value
value = case Value
value of
    Value
Unitus ->
      TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
QuantityToken Doc TechniqueToken
"()"
    Literali Rope
text ->
      TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
SymbolToken Doc TechniqueToken
forall ann. Doc ann
dquote
        Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
StringToken (Rope -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty Rope
text)
        Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
SymbolToken Doc TechniqueToken
forall ann. Doc ann
dquote
    Quanticle Quantity
qty ->
      Quantity -> Doc (Token Quantity)
forall α. Render α => α -> Doc (Token α)
highlight Quantity
qty
    Value
_ ->
      Doc (Token Value)
forall a. HasCallStack => a
undefined