{-# LANGUAGE GADTs #-}
{-# 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.Formatter where

import Core.System.Pretty
import Core.Text.Rope
import Core.Text.Utilities
import Data.Foldable (foldl')
import Data.Int (Int8)
import Technique.Language
import Technique.Quantity

data TechniqueToken
  = MagicToken
  | ProcedureToken
  | TypeToken
  | SymbolToken
  | OperatorToken
  | VariableToken
  | ApplicationToken
  | LabelToken
  | StringToken
  | QuantityToken
  | RoleToken
  | ErrorToken
  | FilenameToken
  | StepToken

instance Pretty Procedure where
  pretty :: Procedure -> Doc ann
pretty = Doc TechniqueToken -> Doc ann
forall ann xxx. Doc ann -> Doc xxx
unAnnotate (Doc TechniqueToken -> Doc ann)
-> (Procedure -> Doc TechniqueToken) -> Procedure -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Procedure -> Doc TechniqueToken
forall α. Render α => α -> Doc (Token α)
highlight

colourizeTechnique :: TechniqueToken -> AnsiColour
colourizeTechnique :: TechniqueToken -> AnsiColour
colourizeTechnique TechniqueToken
token = case TechniqueToken
token of
  TechniqueToken
MagicToken -> AnsiColour
brightGrey
  TechniqueToken
ProcedureToken -> AnsiColour -> AnsiColour
bold AnsiColour
dullBlue
  TechniqueToken
TypeToken -> AnsiColour
dullYellow
  TechniqueToken
SymbolToken -> AnsiColour -> AnsiColour
bold AnsiColour
dullCyan
  TechniqueToken
OperatorToken -> AnsiColour -> AnsiColour
bold AnsiColour
dullYellow
  TechniqueToken
VariableToken -> AnsiColour
brightCyan
  TechniqueToken
ApplicationToken -> AnsiColour -> AnsiColour
bold AnsiColour
brightBlue
  TechniqueToken
LabelToken -> AnsiColour
brightGreen
  TechniqueToken
StringToken -> AnsiColour -> AnsiColour
bold AnsiColour
brightGreen
  TechniqueToken
QuantityToken -> AnsiColour -> AnsiColour
bold AnsiColour
brightMagenta
  TechniqueToken
RoleToken -> AnsiColour
dullYellow
  TechniqueToken
ErrorToken -> AnsiColour -> AnsiColour
bold AnsiColour
pureRed
  TechniqueToken
FilenameToken -> AnsiColour -> AnsiColour
bold AnsiColour
brightWhite
  TechniqueToken
StepToken -> AnsiColour -> AnsiColour
bold AnsiColour
brightGrey -- for diagnostics in evalutator

instance Render Procedure where
  type Token Procedure = TechniqueToken
  colourize :: Token Procedure -> AnsiColour
colourize = Token Procedure -> AnsiColour
TechniqueToken -> AnsiColour
colourizeTechnique
  highlight :: Procedure -> Doc (Token Procedure)
highlight Procedure
proc =
    let name :: Doc TechniqueToken
name = Identifier -> Doc TechniqueToken
forall α. Render α => α -> Doc (Token α)
highlight (Identifier -> Doc TechniqueToken)
-> (Procedure -> Identifier) -> Procedure -> Doc TechniqueToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Procedure -> Identifier
procedureName (Procedure -> Doc TechniqueToken)
-> Procedure -> Doc TechniqueToken
forall a b. (a -> b) -> a -> b
$ Procedure
proc
        params :: Doc TechniqueToken
params = case Procedure -> [Identifier]
procedureParams Procedure
proc of
          [] -> Doc TechniqueToken
forall ann. Doc ann
emptyDoc
          [Identifier]
xs -> [Identifier] -> Doc (Token Identifier)
forall a.
(Render a, Token a ~ TechniqueToken) =>
[a] -> Doc (Token a)
commaCat [Identifier]
xs Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
" "
        from :: Doc TechniqueToken
from = [Type] -> Doc TechniqueToken
forall a.
(Render a, Token a ~ TechniqueToken) =>
[a] -> Doc (Token a)
commaCat ([Type] -> Doc TechniqueToken)
-> (Procedure -> [Type]) -> Procedure -> Doc TechniqueToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Procedure -> [Type]
procedureInput (Procedure -> Doc TechniqueToken)
-> Procedure -> Doc TechniqueToken
forall a b. (a -> b) -> a -> b
$ Procedure
proc
        into :: Doc TechniqueToken
into = [Type] -> Doc TechniqueToken
forall α. Render α => α -> Doc (Token α)
highlight ([Type] -> Doc TechniqueToken)
-> (Procedure -> [Type]) -> Procedure -> Doc TechniqueToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Procedure -> [Type]
procedureOutput (Procedure -> Doc TechniqueToken)
-> Procedure -> Doc TechniqueToken
forall a b. (a -> b) -> a -> b
$ Procedure
proc
        block :: Doc TechniqueToken
block = Block -> Doc TechniqueToken
forall α. Render α => α -> Doc (Token α)
highlight (Block -> Doc TechniqueToken)
-> (Procedure -> Block) -> Procedure -> Doc TechniqueToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Procedure -> Block
procedureBlock (Procedure -> Doc TechniqueToken)
-> Procedure -> Doc TechniqueToken
forall a b. (a -> b) -> a -> b
$ Procedure
proc
        description :: Doc TechniqueToken
description = case Procedure -> Maybe Markdown
procedureDescription Procedure
proc of
          Maybe Markdown
Nothing -> Doc TechniqueToken
forall ann. Doc ann
emptyDoc
          Just Markdown
text -> Markdown -> Doc (Token Markdown)
forall α. Render α => α -> Doc (Token α)
highlight Markdown
text
     in Doc TechniqueToken
description
          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
indent
                 Int
4
                 ( TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
ProcedureToken Doc TechniqueToken
name
                     Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc TechniqueToken
params
                     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
":"
                     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
TypeToken Doc TechniqueToken
from
                     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
SymbolToken Doc TechniqueToken
"->"
                     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
TypeToken Doc TechniqueToken
into
                     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
block
                 )
             )

-- |
-- Punctuate a list with commas annotated with Symbol highlighting.
commaCat :: (Render a, Token a ~ TechniqueToken) => [a] -> Doc (Token a)
commaCat :: [a] -> Doc (Token a)
commaCat = [Doc TechniqueToken] -> Doc TechniqueToken
forall ann. [Doc ann] -> Doc ann
hcat ([Doc TechniqueToken] -> Doc TechniqueToken)
-> ([a] -> [Doc TechniqueToken]) -> [a] -> Doc TechniqueToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc TechniqueToken -> [Doc TechniqueToken] -> [Doc TechniqueToken]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate (TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
SymbolToken Doc TechniqueToken
forall ann. Doc ann
comma) ([Doc TechniqueToken] -> [Doc TechniqueToken])
-> ([a] -> [Doc TechniqueToken]) -> [a] -> [Doc TechniqueToken]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Doc TechniqueToken) -> [a] -> [Doc TechniqueToken]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
VariableToken (Doc TechniqueToken -> Doc TechniqueToken)
-> (a -> Doc TechniqueToken) -> a -> Doc TechniqueToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc TechniqueToken
forall α. Render α => α -> Doc (Token α)
highlight)

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

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

instance Render Block where
  type Token Block = TechniqueToken
  colourize :: Token Block -> AnsiColour
colourize = Token Block -> AnsiColour
TechniqueToken -> AnsiColour
colourizeTechnique
  highlight :: Block -> Doc (Token Block)
highlight (Block [Statement]
statements) =
    Int -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Int -> Doc ann -> Doc ann
nest
      Int
4
      ( TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
SymbolToken Doc TechniqueToken
forall ann. Doc ann
lbrace
          Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> [Statement] -> Doc TechniqueToken
go [Statement]
statements
      )
      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
<> TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
SymbolToken Doc TechniqueToken
forall ann. Doc ann
rbrace
    where
      go :: [Statement] -> Doc TechniqueToken
      go :: [Statement] -> Doc TechniqueToken
go [] = Doc TechniqueToken
forall ann. Doc ann
emptyDoc
      go (x :: Statement
x@(Series Int
_) : Statement
x1 : [Statement]
xs) = Statement -> Doc (Token Statement)
forall α. Render α => α -> Doc (Token α)
highlight Statement
x Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Statement -> Doc (Token Statement)
forall α. Render α => α -> Doc (Token α)
highlight Statement
x1 Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> [Statement] -> Doc TechniqueToken
go [Statement]
xs
      go (Statement
x : [Statement]
xs) = Doc TechniqueToken
forall ann. Doc ann
line Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Statement -> Doc (Token Statement)
forall α. Render α => α -> Doc (Token α)
highlight Statement
x Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> [Statement] -> Doc TechniqueToken
go [Statement]
xs

instance Render Statement where
  type Token Statement = TechniqueToken
  colourize :: Token Statement -> AnsiColour
colourize = Token Statement -> AnsiColour
TechniqueToken -> AnsiColour
colourizeTechnique
  highlight :: Statement -> Doc (Token Statement)
highlight Statement
statement = case Statement
statement of
    Assignment Int
_ [Identifier]
vars Expression
expr ->
      [Identifier] -> Doc (Token Identifier)
forall a.
(Render a, Token a ~ TechniqueToken) =>
[a] -> Doc (Token a)
commaCat [Identifier]
vars 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
SymbolToken Doc TechniqueToken
"=" Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Expression -> Doc (Token Expression)
forall α. Render α => α -> Doc (Token α)
highlight Expression
expr
    Execute Int
_ Expression
expr ->
      Expression -> Doc (Token Expression)
forall α. Render α => α -> Doc (Token α)
highlight Expression
expr
    Comment Int
_ Rope
text ->
      Doc TechniqueToken
"-- " Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Rope -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty Rope
text -- TODO what about multiple lines?
    Declaration Int
_ Procedure
proc ->
      Procedure -> Doc (Token Procedure)
forall α. Render α => α -> Doc (Token α)
highlight Procedure
proc
    Blank Int
_ ->
      Doc (Token Statement)
forall ann. Doc ann
emptyDoc
    Series Int
_ ->
      TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
SymbolToken Doc TechniqueToken
" ; "

instance Render Attribute where
  type Token Attribute = TechniqueToken
  colourize :: Token Attribute -> AnsiColour
colourize = Token Attribute -> AnsiColour
TechniqueToken -> AnsiColour
colourizeTechnique
  highlight :: Attribute -> Doc (Token Attribute)
highlight Attribute
role = case Attribute
role of
    Role Identifier
name -> TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
RoleToken (Doc TechniqueToken
"@" Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Identifier -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty Identifier
name)
    Place Identifier
name -> TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
RoleToken (Doc TechniqueToken
"#" Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Identifier -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty Identifier
name)
    Attribute
Inherit -> TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
ErrorToken Doc TechniqueToken
"Inherit"

instance Render Expression where
  type Token Expression = TechniqueToken
  colourize :: Token Expression -> AnsiColour
colourize = Token Expression -> AnsiColour
TechniqueToken -> AnsiColour
colourizeTechnique
  highlight :: Expression -> Doc (Token Expression)
highlight Expression
expr = case Expression
expr of
    Application Int
_ Identifier
name Expression
subexpr ->
      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
name) Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Expression -> Doc (Token Expression)
forall α. Render α => α -> Doc (Token α)
highlight Expression
subexpr
    None Int
_ ->
      TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
SymbolToken (Doc TechniqueToken
"()")
    Undefined Int
_ ->
      TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
ErrorToken Doc TechniqueToken
"?"
    Amount Int
_ Quantity
qty ->
      Quantity -> Doc (Token Quantity)
forall α. Render α => α -> Doc (Token α)
highlight Quantity
qty
    Text Int
_ 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
    Object Int
_ Tablet
tablet ->
      Tablet -> Doc (Token Tablet)
forall α. Render α => α -> Doc (Token α)
highlight Tablet
tablet
    Variable Int
_ [Identifier]
vars ->
      [Identifier] -> Doc (Token Identifier)
forall a.
(Render a, Token a ~ TechniqueToken) =>
[a] -> Doc (Token a)
commaCat [Identifier]
vars
    Operation Int
_ Operator
operator Expression
subexpr1 Expression
subexpr2 ->
      Expression -> Doc (Token Expression)
forall α. Render α => α -> Doc (Token α)
highlight Expression
subexpr1 Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Operator -> Doc (Token Operator)
forall α. Render α => α -> Doc (Token α)
highlight Operator
operator Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Expression -> Doc (Token Expression)
forall α. Render α => α -> Doc (Token α)
highlight Expression
subexpr2
    Grouping Int
_ Expression
subexpr ->
      TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
SymbolToken Doc TechniqueToken
forall ann. Doc ann
lparen
        Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Expression -> Doc (Token Expression)
forall α. Render α => α -> Doc (Token α)
highlight Expression
subexpr
        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
rparen
    Restriction Int
_ Attribute
attribute Block
block ->
      Attribute -> Doc (Token Attribute)
forall α. Render α => α -> Doc (Token α)
highlight Attribute
attribute
        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
<> Block -> Doc (Token Block)
forall α. Render α => α -> Doc (Token α)
highlight Block
block -- TODO some nesting?

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

instance Pretty Identifier where
  pretty :: Identifier -> Doc ann
pretty = Doc TechniqueToken -> Doc ann
forall ann xxx. Doc ann -> Doc xxx
unAnnotate (Doc TechniqueToken -> Doc ann)
-> (Identifier -> Doc TechniqueToken) -> Identifier -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> Doc TechniqueToken
forall α. Render α => α -> Doc (Token α)
highlight

instance Render Decimal where
  type Token Decimal = TechniqueToken
  colourize :: Token Decimal -> AnsiColour
colourize = Token Decimal -> AnsiColour
TechniqueToken -> AnsiColour
colourizeTechnique
  highlight :: Decimal -> Doc (Token Decimal)
highlight = Rope -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty (Rope -> Doc TechniqueToken)
-> (Decimal -> Rope) -> Decimal -> Doc TechniqueToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Decimal -> Rope
decimalToRope

instance Render Quantity where
  type Token Quantity = TechniqueToken
  colourize :: Token Quantity -> AnsiColour
colourize = Token Quantity -> AnsiColour
TechniqueToken -> AnsiColour
colourizeTechnique
  highlight :: Quantity -> Doc (Token Quantity)
highlight Quantity
qty = case Quantity
qty of
    Number Int64
i ->
      TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
QuantityToken (Int64 -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty Int64
i)
    Quantity Decimal
i Decimal
u Magnitude
m Rope
unit ->
      let measurement :: Doc TechniqueToken
measurement =
            Decimal -> Doc (Token Decimal)
forall α. Render α => α -> Doc (Token α)
highlight Decimal
i Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
" "
          uncertainty :: Doc TechniqueToken
uncertainty =
            if Decimal -> Bool
isZeroDecimal Decimal
u
              then Doc TechniqueToken
forall ann. Doc ann
emptyDoc
              else Doc TechniqueToken
"± " Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Decimal -> Doc (Token Decimal)
forall α. Render α => α -> Doc (Token α)
highlight Decimal
u Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
" "
          magnitude :: Doc TechniqueToken
magnitude =
            if Magnitude
m Magnitude -> Magnitude -> Bool
forall a. Eq a => a -> a -> Bool
== Magnitude
0
              then Doc TechniqueToken
forall ann. Doc ann
emptyDoc
              else Doc TechniqueToken
"× 10" Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Magnitude -> Doc TechniqueToken
forall ann. Magnitude -> Doc ann
numberToSuperscript Magnitude
m Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
" "
       in TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
QuantityToken (Doc TechniqueToken
measurement Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
uncertainty Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
magnitude Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Rope -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty Rope
unit)

numberToSuperscript :: Int8 -> Doc ann
numberToSuperscript :: Magnitude -> Doc ann
numberToSuperscript Magnitude
number =
  let digits :: String
digits = Magnitude -> String
forall a. Show a => a -> String
show Magnitude
number
      digits' :: String
digits' = (Char -> Char) -> String -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
toSuperscript String
digits
   in String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
digits'

toSuperscript :: Char -> Char
toSuperscript :: Char -> Char
toSuperscript Char
c = case Char
c of
  Char
'0' -> Char
'⁰' -- U+2070
  Char
'1' -> Char
'¹' -- U+00B9
  Char
'2' -> Char
'²' -- U+00B2
  Char
'3' -> Char
'³' -- U+00B3
  Char
'4' -> Char
'⁴' -- U+2074
  Char
'5' -> Char
'⁵' -- U+2075
  Char
'6' -> Char
'⁶' -- U+2076
  Char
'7' -> Char
'⁷' -- U+2077
  Char
'8' -> Char
'⁸' -- U+2078
  Char
'9' -> Char
'⁹' -- U+2079
  Char
'-' -> Char
'⁻' -- U+207B
  Char
_ -> String -> Char
forall a. HasCallStack => String -> a
error String
"Invalid, digit expected"

instance Pretty Quantity where
  pretty :: Quantity -> Doc ann
pretty = Doc TechniqueToken -> Doc ann
forall ann xxx. Doc ann -> Doc xxx
unAnnotate (Doc TechniqueToken -> Doc ann)
-> (Quantity -> Doc TechniqueToken) -> Quantity -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Quantity -> Doc TechniqueToken
forall α. Render α => α -> Doc (Token α)
highlight

instance Render Tablet where
  type Token Tablet = TechniqueToken
  colourize :: Token Tablet -> AnsiColour
colourize = Token Tablet -> AnsiColour
TechniqueToken -> AnsiColour
colourizeTechnique
  highlight :: Tablet -> Doc (Token Tablet)
highlight (Tablet [Binding]
bindings) =
    Int -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Int -> Doc ann -> Doc ann
nest
      Int
4
      ( TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
SymbolToken Doc TechniqueToken
forall ann. Doc ann
lbracket
          Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> (Doc TechniqueToken -> Binding -> Doc TechniqueToken)
-> Doc TechniqueToken -> [Binding] -> Doc TechniqueToken
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Doc TechniqueToken -> Binding -> Doc TechniqueToken
g Doc TechniqueToken
forall ann. Doc ann
emptyDoc [Binding]
bindings
      )
      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
<> TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
SymbolToken Doc TechniqueToken
forall ann. Doc ann
rbracket
    where
      g :: Doc TechniqueToken -> Binding -> Doc TechniqueToken
      g :: Doc TechniqueToken -> Binding -> Doc TechniqueToken
g Doc TechniqueToken
built Binding
binding = Doc TechniqueToken
built 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
<> Binding -> Doc (Token Binding)
forall α. Render α => α -> Doc (Token α)
highlight Binding
binding

instance Render Label where
  type Token Label = TechniqueToken
  colourize :: Token Label -> AnsiColour
colourize = Token Label -> AnsiColour
TechniqueToken -> AnsiColour
colourizeTechnique
  highlight :: Label -> Doc (Token Label)
highlight (Label 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
LabelToken (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

instance Pretty Label where
  pretty :: Label -> Doc ann
pretty = Doc TechniqueToken -> Doc ann
forall ann xxx. Doc ann -> Doc xxx
unAnnotate (Doc TechniqueToken -> Doc ann)
-> (Label -> Doc TechniqueToken) -> Label -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> Doc TechniqueToken
forall α. Render α => α -> Doc (Token α)
highlight

-- the annotation for the label duplicates the code Quantity's Text
-- constructor, but for the LabelToken token. This distinction may not be
-- necessary (at present we have the same colouring for both).
instance Render Binding where
  type Token Binding = TechniqueToken
  colourize :: Token Binding -> AnsiColour
colourize = Token Binding -> AnsiColour
TechniqueToken -> AnsiColour
colourizeTechnique
  highlight :: Binding -> Doc (Token Binding)
highlight (Binding Label
label Expression
subexpr) =
    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
<+> TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
SymbolToken Doc TechniqueToken
"~"
      Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Expression -> Doc (Token Expression)
forall α. Render α => α -> Doc (Token α)
highlight Expression
subexpr

instance Render Operator where
  type Token Operator = TechniqueToken
  colourize :: Token Operator -> AnsiColour
colourize = Token Operator -> AnsiColour
TechniqueToken -> AnsiColour
colourizeTechnique
  highlight :: Operator -> Doc (Token Operator)
highlight Operator
operator =
    TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
OperatorToken (Doc TechniqueToken -> Doc TechniqueToken)
-> Doc TechniqueToken -> Doc TechniqueToken
forall a b. (a -> b) -> a -> b
$ case Operator
operator of
      Operator
WaitBoth -> Char -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty Char
'&'
      Operator
WaitEither -> Char -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty Char
'|'
      Operator
Combine -> Char -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty Char
'+'

instance Render Technique where
  type Token Technique = TechniqueToken
  colourize :: Token Technique -> AnsiColour
colourize = Token Technique -> AnsiColour
TechniqueToken -> AnsiColour
colourizeTechnique
  highlight :: Technique -> Doc (Token Technique)
highlight Technique
technique =
    let version :: Doc TechniqueToken
version = Int -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> Doc TechniqueToken)
-> (Technique -> Int) -> Technique -> Doc TechniqueToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Technique -> Int
techniqueVersion (Technique -> Doc TechniqueToken)
-> Technique -> Doc TechniqueToken
forall a b. (a -> b) -> a -> b
$ Technique
technique
        license :: Doc TechniqueToken
license = Rope -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty (Rope -> Doc TechniqueToken)
-> (Technique -> Rope) -> Technique -> Doc TechniqueToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Technique -> Rope
techniqueLicense (Technique -> Doc TechniqueToken)
-> Technique -> Doc TechniqueToken
forall a b. (a -> b) -> a -> b
$ Technique
technique
        copyright :: Doc TechniqueToken
copyright = case Technique -> Maybe Rope
techniqueCopyright Technique
technique of
          Just Rope
owner -> Doc TechniqueToken
"; ©" Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Rope -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty Rope
owner
          Maybe Rope
Nothing -> Doc TechniqueToken
forall ann. Doc ann
emptyDoc
        body :: [Doc TechniqueToken]
body = (Procedure -> Doc TechniqueToken)
-> [Procedure] -> [Doc TechniqueToken]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Procedure -> Doc TechniqueToken
forall α. Render α => α -> Doc (Token α)
highlight ([Procedure] -> [Doc TechniqueToken])
-> (Technique -> [Procedure]) -> Technique -> [Doc TechniqueToken]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Technique -> [Procedure]
techniqueBody (Technique -> [Doc TechniqueToken])
-> Technique -> [Doc TechniqueToken]
forall a b. (a -> b) -> a -> b
$ Technique
technique
     in TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
MagicToken (Doc TechniqueToken
"%" Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc TechniqueToken
"technique" Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc TechniqueToken
"v" Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
version) 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
<> TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
MagicToken (Doc TechniqueToken
"!" Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc TechniqueToken
license Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
copyright)
          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
forall ann. Doc ann
line
          Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> [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
line [Doc TechniqueToken]
body)