{-# OPTIONS_GHC -Wno-orphans #-}

-- | Duplicate of the Unison.Util.SyntaxText module, but we expect these to
-- evolve separately. This is the version which is outward facing
-- to the server frontend.
module Unison.Server.Syntax where

import Data.Aeson
import Data.List qualified as List
import Data.List.Extra
import Data.List.NonEmpty qualified as List.NonEmpty
import Data.OpenApi (ToSchema (..))
import Data.Proxy (Proxy (..))
import Data.Text qualified as Text
import Lucid
import Lucid qualified as L
import Unison.Name (Name)
import Unison.Name qualified as Name
import Unison.Pattern (SeqOp (..))
import Unison.Prelude
import Unison.Reference (Reference)
import Unison.Reference qualified as Reference
import Unison.Referent qualified as Referent
import Unison.Syntax.HashQualified qualified as HashQualified (toText)
import Unison.Syntax.Name qualified as Name (unsafeParseText)
import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText)
import Unison.Util.AnnotatedText
  ( AnnotatedText (..),
    Segment (..),
    annotate,
    segment,
  )
import Unison.Util.SyntaxText qualified as SyntaxText

type SyntaxText = AnnotatedText Element

type SyntaxSegment = Segment Element

instance (ToJSON a) => ToJSON (Segment a) where
  toJSON :: Segment a -> Value
toJSON (Segment {String
segment :: forall a. Segment a -> String
segment :: String
segment, Maybe a
annotation :: Maybe a
annotation :: forall a. Segment a -> Maybe a
annotation}) = [Pair] -> Value
object [Key
"segment" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= String
segment, Key
"annotation" Key -> Maybe a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Maybe a
annotation]

instance (FromJSON a) => FromJSON (Segment a) where
  parseJSON :: Value -> Parser (Segment a)
parseJSON = String
-> (Object -> Parser (Segment a)) -> Value -> Parser (Segment a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Segment" ((Object -> Parser (Segment a)) -> Value -> Parser (Segment a))
-> (Object -> Parser (Segment a)) -> Value -> Parser (Segment a)
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    String -> Maybe a -> Segment a
forall a. String -> Maybe a -> Segment a
Segment (String -> Maybe a -> Segment a)
-> Parser String -> Parser (Maybe a -> Segment a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"segment" Parser (Maybe a -> Segment a)
-> Parser (Maybe a) -> Parser (Segment a)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe a)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"annotation"

deriving instance (ToSchema a) => ToSchema (Segment a)

instance ToJSON SeqOp where
  toJSON :: SeqOp -> Value
toJSON = \case
    SeqOp
Cons -> Text -> Value
String Text
"Cons"
    SeqOp
Snoc -> Text -> Value
String Text
"Snoc"
    SeqOp
Concat -> Text -> Value
String Text
"Concat"

instance FromJSON SeqOp where
  parseJSON :: Value -> Parser SeqOp
parseJSON = String -> (Text -> Parser SeqOp) -> Value -> Parser SeqOp
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"SeqOp" ((Text -> Parser SeqOp) -> Value -> Parser SeqOp)
-> (Text -> Parser SeqOp) -> Value -> Parser SeqOp
forall a b. (a -> b) -> a -> b
$ \case
    Text
"Cons" -> SeqOp -> Parser SeqOp
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SeqOp
Cons
    Text
"Snoc" -> SeqOp -> Parser SeqOp
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SeqOp
Snoc
    Text
"Concat" -> SeqOp -> Parser SeqOp
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SeqOp
Concat
    Text
_ -> String -> Parser SeqOp
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected one of Cons, Snoc, Concat"

deriving instance ToSchema SeqOp

deriving newtype instance ToJSON (AnnotatedText Element)

deriving newtype instance FromJSON (AnnotatedText Element)

deriving anyclass instance ToSchema SyntaxText

instance (ToSchema r) => ToSchema (Seq r) where
  declareNamedSchema :: Proxy (Seq r) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (Seq r)
_ = Proxy [r] -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @[r])

convertElement :: SyntaxText.Element Reference -> Element
convertElement :: Element Reference -> Element
convertElement = \case
  Element Reference
SyntaxText.NumericLiteral -> Element
NumericLiteral
  Element Reference
SyntaxText.TextLiteral -> Element
TextLiteral
  Element Reference
SyntaxText.BytesLiteral -> Element
BytesLiteral
  Element Reference
SyntaxText.CharLiteral -> Element
CharLiteral
  Element Reference
SyntaxText.BooleanLiteral -> Element
BooleanLiteral
  Element Reference
SyntaxText.Blank -> Element
Blank
  Element Reference
SyntaxText.Var -> Element
Var
  SyntaxText.TermReference Referent' Reference
r -> Text -> Element
TermReference (Text -> Element) -> Text -> Element
forall a b. (a -> b) -> a -> b
$ Referent' Reference -> Text
Referent.toText Referent' Reference
r
  SyntaxText.TypeReference Reference
r -> Text -> Element
TypeReference (Text -> Element) -> Text -> Element
forall a b. (a -> b) -> a -> b
$ Reference -> Text
Reference.toText Reference
r
  SyntaxText.Op SeqOp
s -> SeqOp -> Element
Op SeqOp
s
  Element Reference
SyntaxText.AbilityBraces -> Element
AbilityBraces
  Element Reference
SyntaxText.ControlKeyword -> Element
ControlKeyword
  Element Reference
SyntaxText.TypeOperator -> Element
TypeOperator
  Element Reference
SyntaxText.BindingEquals -> Element
BindingEquals
  Element Reference
SyntaxText.TypeAscriptionColon -> Element
TypeAscriptionColon
  Element Reference
SyntaxText.DataTypeKeyword -> Element
DataTypeKeyword
  Element Reference
SyntaxText.DataTypeParams -> Element
DataTypeParams
  Element Reference
SyntaxText.Unit -> Element
Unit
  Element Reference
SyntaxText.DataTypeModifier -> Element
DataTypeModifier
  Element Reference
SyntaxText.UseKeyword -> Element
UseKeyword
  Element Reference
SyntaxText.UsePrefix -> Element
UsePrefix
  Element Reference
SyntaxText.UseSuffix -> Element
UseSuffix
  SyntaxText.HashQualifier HashQualified Name
n -> Text -> Element
HashQualifier (HashQualified Name -> Text
HashQualified.toText HashQualified Name
n)
  Element Reference
SyntaxText.DelayForceChar -> Element
DelayForceChar
  Element Reference
SyntaxText.DelimiterChar -> Element
DelimiterChar
  Element Reference
SyntaxText.Parenthesis -> Element
Parenthesis
  Element Reference
SyntaxText.LinkKeyword -> Element
LinkKeyword
  Element Reference
SyntaxText.DocDelimiter -> Element
DocDelimiter
  Element Reference
SyntaxText.DocKeyword -> Element
DocKeyword

type UnisonHash = Text

type HashQualifiedName = Text

-- | The elements of the Unison grammar, for syntax highlighting purposes
data Element
  = NumericLiteral
  | TextLiteral
  | BytesLiteral
  | CharLiteral
  | BooleanLiteral
  | Blank
  | Var
  | TypeReference UnisonHash
  | DataConstructorReference UnisonHash
  | AbilityConstructorReference UnisonHash
  | TermReference UnisonHash
  | Op SeqOp
  | -- | Constructor Are these even used?
    -- | Request
    AbilityBraces
  | -- let|handle|in|where|match|with|cases|->|if|then|else|and|or
    ControlKeyword
  | -- forall|->
    TypeOperator
  | BindingEquals
  | TypeAscriptionColon
  | -- type|ability
    DataTypeKeyword
  | DataTypeParams
  | Unit
  | -- unique
    DataTypeModifier
  | -- `use Foo bar` is keyword, prefix, suffix
    UseKeyword
  | UsePrefix
  | UseSuffix
  | HashQualifier HashQualifiedName
  | DelayForceChar
  | -- ? , ` [ ] @ |
    -- Currently not all commas in the pretty-print output are marked up as DelimiterChar - we miss
    -- out characters emitted by Pretty.hs helpers like Pretty.commas.
    DelimiterChar
  | -- ! '
    Parenthesis
  | LinkKeyword -- `typeLink` and `termLink`
  -- [: :] @[]
  | DocDelimiter
  | -- the 'include' in @[include], etc
    DocKeyword
  deriving (Element -> Element -> Bool
(Element -> Element -> Bool)
-> (Element -> Element -> Bool) -> Eq Element
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Element -> Element -> Bool
== :: Element -> Element -> Bool
$c/= :: Element -> Element -> Bool
/= :: Element -> Element -> Bool
Eq, Eq Element
Eq Element =>
(Element -> Element -> Ordering)
-> (Element -> Element -> Bool)
-> (Element -> Element -> Bool)
-> (Element -> Element -> Bool)
-> (Element -> Element -> Bool)
-> (Element -> Element -> Element)
-> (Element -> Element -> Element)
-> Ord Element
Element -> Element -> Bool
Element -> Element -> Ordering
Element -> Element -> Element
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Element -> Element -> Ordering
compare :: Element -> Element -> Ordering
$c< :: Element -> Element -> Bool
< :: Element -> Element -> Bool
$c<= :: Element -> Element -> Bool
<= :: Element -> Element -> Bool
$c> :: Element -> Element -> Bool
> :: Element -> Element -> Bool
$c>= :: Element -> Element -> Bool
>= :: Element -> Element -> Bool
$cmax :: Element -> Element -> Element
max :: Element -> Element -> Element
$cmin :: Element -> Element -> Element
min :: Element -> Element -> Element
Ord, Int -> Element -> ShowS
[Element] -> ShowS
Element -> String
(Int -> Element -> ShowS)
-> (Element -> String) -> ([Element] -> ShowS) -> Show Element
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Element -> ShowS
showsPrec :: Int -> Element -> ShowS
$cshow :: Element -> String
show :: Element -> String
$cshowList :: [Element] -> ShowS
showList :: [Element] -> ShowS
Show, (forall x. Element -> Rep Element x)
-> (forall x. Rep Element x -> Element) -> Generic Element
forall x. Rep Element x -> Element
forall x. Element -> Rep Element x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Element -> Rep Element x
from :: forall x. Element -> Rep Element x
$cto :: forall x. Rep Element x -> Element
to :: forall x. Rep Element x -> Element
Generic)

instance ToJSON Element where
  toJSON :: Element -> Value
toJSON = \case
    Element
NumericLiteral -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"NumericLiteral"]
    Element
TextLiteral -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"TextLiteral"]
    Element
BytesLiteral -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"BytesLiteral"]
    Element
CharLiteral -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"CharLiteral"]
    Element
BooleanLiteral -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"BooleanLiteral"]
    Element
Blank -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"Blank"]
    Element
Var -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"Var"]
    TypeReference Text
r -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"TypeReference", Key
"contents" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text
r]
    DataConstructorReference Text
r ->
      [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"DataConstructorReference", Key
"contents" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text
r]
    AbilityConstructorReference Text
r -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"AbilityConstructorReference", Key
"contents" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text
r]
    TermReference Text
r -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"TermReference", Key
"contents" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text
r]
    Op SeqOp
s -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"Op", Key
"contents" Key -> SeqOp -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= SeqOp
s]
    Element
AbilityBraces -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"AbilityBraces"]
    Element
ControlKeyword -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"ControlKeyword"]
    Element
TypeOperator -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"TypeOperator"]
    Element
BindingEquals -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"BindingEquals"]
    Element
TypeAscriptionColon -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"TypeAscriptionColon"]
    Element
DataTypeKeyword -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"DataTypeKeyword"]
    Element
DataTypeParams -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"DataTypeParams"]
    Element
Unit -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"Unit"]
    Element
DataTypeModifier -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"DataTypeModifier"]
    Element
UseKeyword -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"UseKeyword"]
    Element
UsePrefix -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"UsePrefix"]
    Element
UseSuffix -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"UseSuffix"]
    HashQualifier Text
n -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"HashQualifier", Key
"contents" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text
n]
    Element
DelayForceChar -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"DelayForceChar"]
    Element
DelimiterChar -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"DelimiterChar"]
    Element
Parenthesis -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"Parenthesis"]
    Element
LinkKeyword -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"LinkKeyword"]
    Element
DocDelimiter -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"DocDelimiter"]
    Element
DocKeyword -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"DocKeyword"]

instance FromJSON Element where
  parseJSON :: Value -> Parser Element
parseJSON = String -> (Object -> Parser Element) -> Value -> Parser Element
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Element" ((Object -> Parser Element) -> Value -> Parser Element)
-> (Object -> Parser Element) -> Value -> Parser Element
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
    String
tag <- Object
obj Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"tag"
    case String
tag of
      String
"NumericLiteral" -> Element -> Parser Element
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
NumericLiteral
      String
"TextLiteral" -> Element -> Parser Element
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
TextLiteral
      String
"BytesLiteral" -> Element -> Parser Element
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
BytesLiteral
      String
"CharLiteral" -> Element -> Parser Element
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
CharLiteral
      String
"BooleanLiteral" -> Element -> Parser Element
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
BooleanLiteral
      String
"Blank" -> Element -> Parser Element
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
Blank
      String
"Var" -> Element -> Parser Element
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
Var
      String
"TypeReference" -> Text -> Element
TypeReference (Text -> Element) -> Parser Text -> Parser Element
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"contents"
      String
"DataConstructorReference" -> Text -> Element
DataConstructorReference (Text -> Element) -> Parser Text -> Parser Element
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"contents"
      String
"AbilityConstructorReference" -> Text -> Element
AbilityConstructorReference (Text -> Element) -> Parser Text -> Parser Element
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"contents"
      String
"TermReference" -> Text -> Element
TermReference (Text -> Element) -> Parser Text -> Parser Element
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"contents"
      String
"Op" -> SeqOp -> Element
Op (SeqOp -> Element) -> Parser SeqOp -> Parser Element
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj Object -> Key -> Parser SeqOp
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"contents"
      String
"AbilityBraces" -> Element -> Parser Element
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
AbilityBraces
      String
"ControlKeyword" -> Element -> Parser Element
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
ControlKeyword
      String
"TypeOperator" -> Element -> Parser Element
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
TypeOperator
      String
"BindingEquals" -> Element -> Parser Element
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
BindingEquals
      String
"TypeAscriptionColon" -> Element -> Parser Element
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
TypeAscriptionColon
      String
"DataTypeKeyword" -> Element -> Parser Element
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
DataTypeKeyword
      String
"DataTypeParams" -> Element -> Parser Element
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
DataTypeParams
      String
"Unit" -> Element -> Parser Element
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
Unit
      String
"DataTypeModifier" -> Element -> Parser Element
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
DataTypeModifier
      String
"UseKeyword" -> Element -> Parser Element
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
UseKeyword
      String
"UsePrefix" -> Element -> Parser Element
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
UsePrefix
      String
"UseSuffix" -> Element -> Parser Element
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
UseSuffix
      String
"HashQualifier" -> Text -> Element
HashQualifier (Text -> Element) -> Parser Text -> Parser Element
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"contents"
      String
"DelayForceChar" -> Element -> Parser Element
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
DelayForceChar
      String
"DelimiterChar" -> Element -> Parser Element
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
DelimiterChar
      String
"Parenthesis" -> Element -> Parser Element
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
Parenthesis
      String
"LinkKeyword" -> Element -> Parser Element
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
LinkKeyword
      String
"DocDelimiter" -> Element -> Parser Element
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
DocDelimiter
      String
"DocKeyword" -> Element -> Parser Element
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
DocKeyword
      String
_ -> String -> Parser Element
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Element) -> String -> Parser Element
forall a b. (a -> b) -> a -> b
$ String
"Unknown tag: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
tag

deriving instance ToSchema Element

syntax :: Element -> SyntaxText -> SyntaxText
syntax :: Element -> AnnotatedText Element -> AnnotatedText Element
syntax = Element -> AnnotatedText Element -> AnnotatedText Element
forall a. a -> AnnotatedText a -> AnnotatedText a
annotate

firstReference :: SyntaxText -> Maybe UnisonHash
firstReference :: AnnotatedText Element -> Maybe Text
firstReference (AnnotatedText Seq (Segment Element)
segments) =
  (Segment Element -> Maybe Text) -> [Segment Element] -> Maybe Text
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstJust Segment Element -> Maybe Text
reference (Seq (Segment Element) -> [Segment Element]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (Segment Element)
segments)

reference :: SyntaxSegment -> Maybe UnisonHash
reference :: Segment Element -> Maybe Text
reference (Segment String
_ Maybe Element
el) =
  let reference' :: Element -> Maybe Text
reference' Element
el' =
        case Element
el' of
          TermReference Text
r -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
r
          TypeReference Text
r -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
r
          HashQualifier Text
r -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
r
          Element
_ -> Maybe Text
forall a. Maybe a
Nothing
   in Maybe Element
el Maybe Element -> (Element -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Element -> Maybe Text
reference'

-- | Convert a `SyntaxText` to a `String`, ignoring syntax markup
toPlain :: SyntaxText -> String
toPlain :: AnnotatedText Element -> String
toPlain (AnnotatedText Seq (Segment Element)
at) = [String] -> String
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Seq String -> [String]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq String -> [String]) -> Seq String -> [String]
forall a b. (a -> b) -> a -> b
$ Segment Element -> String
forall a. Segment a -> String
segment (Segment Element -> String) -> Seq (Segment Element) -> Seq String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq (Segment Element)
at)

toPlainText :: SyntaxText -> Text
toPlainText :: AnnotatedText Element -> Text
toPlainText = String -> Text
Text.pack (String -> Text)
-> (AnnotatedText Element -> String)
-> AnnotatedText Element
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnnotatedText Element -> String
toPlain

-- HTML -----------------------------------------------------------------------

toHtml :: SyntaxText -> Html ()
toHtml :: AnnotatedText Element -> HtmlT Identity ()
toHtml (AnnotatedText Seq (Segment Element)
segments) =
  let renderedSegments :: Seq (HtmlT Identity ())
renderedSegments =
        (Segment Element -> HtmlT Identity ())
-> Seq (Segment Element) -> Seq (HtmlT Identity ())
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Segment Element -> HtmlT Identity ()
segmentToHtml Seq (Segment Element)
segments
   in [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
span_ [Text -> Attribute
class_ Text
"syntax"] (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ [HtmlT Identity ()] -> HtmlT Identity ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ (Seq (HtmlT Identity ()) -> [HtmlT Identity ()]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (HtmlT Identity ())
renderedSegments)

nameToHtml :: Name -> Html ()
nameToHtml :: Name -> HtmlT Identity ()
nameToHtml Name
name =
  [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
span_ [Text -> Attribute
class_ Text
"fqn"] (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ [HtmlT Identity ()] -> HtmlT Identity ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [HtmlT Identity ()]
parts
  where
    segments :: [HtmlT Identity ()]
segments =
      (NameSegment -> HtmlT Identity ())
-> [NameSegment] -> [HtmlT Identity ()]
forall a b. (a -> b) -> [a] -> [b]
map (HtmlT Identity () -> HtmlT Identity ()
segment (HtmlT Identity () -> HtmlT Identity ())
-> (NameSegment -> HtmlT Identity ())
-> NameSegment
-> HtmlT Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
L.toHtml (Text -> HtmlT Identity ())
-> (NameSegment -> Text) -> NameSegment -> HtmlT Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSegment -> Text
NameSegment.toEscapedText) ([NameSegment] -> [HtmlT Identity ()])
-> [NameSegment] -> [HtmlT Identity ()]
forall a b. (a -> b) -> a -> b
$ NonEmpty NameSegment -> [NameSegment]
forall a. NonEmpty a -> [a]
List.NonEmpty.toList (NonEmpty NameSegment -> [NameSegment])
-> NonEmpty NameSegment -> [NameSegment]
forall a b. (a -> b) -> a -> b
$ Name -> NonEmpty NameSegment
Name.segments Name
name

    segment :: HtmlT Identity () -> HtmlT Identity ()
segment =
      [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
span_ [Text -> Attribute
class_ Text
"segment"]

    sep :: HtmlT Identity ()
sep =
      [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
span_ [Text -> Attribute
class_ Text
"sep "] HtmlT Identity ()
"."

    parts :: [HtmlT Identity ()]
parts =
      HtmlT Identity () -> [HtmlT Identity ()] -> [HtmlT Identity ()]
forall a. a -> [a] -> [a]
List.intersperse HtmlT Identity ()
sep [HtmlT Identity ()]
segments

segmentToHtml :: SyntaxSegment -> Html ()
segmentToHtml :: Segment Element -> HtmlT Identity ()
segmentToHtml (Segment String
segmentText Maybe Element
element) =
  let sText :: Text
sText = String -> Text
Text.pack String
segmentText

      el :: Element
el = Element -> Maybe Element -> Element
forall a. a -> Maybe a -> a
fromMaybe Element
Blank Maybe Element
element

      ref :: Maybe (Text, Text)
ref =
        case Element
el of
          TypeReference Text
h ->
            (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
h, Text
"type")
          TermReference Text
h ->
            (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
h, Text
"term")
          AbilityConstructorReference Text
h ->
            (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
h, Text
"ability-constructor")
          DataConstructorReference Text
h ->
            (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
h, Text
"data-constructor")
          Element
_ ->
            Maybe (Text, Text)
forall a. Maybe a
Nothing

      isFQN :: Bool
isFQN =
        let isFQN_ :: Bool
isFQN_ =
              Text -> Text -> Bool
Text.isInfixOf Text
"." Text
sText Bool -> Bool -> Bool
&& Bool -> Bool
not (Text -> Text -> Bool
Text.isInfixOf Text
"#" Text
sText)
         in case Element
el of
              TypeReference {} ->
                Bool
isFQN_
              TermReference {} ->
                Bool
isFQN_
              HashQualifier {} ->
                Bool
isFQN_
              DataConstructorReference {} ->
                Bool
isFQN_
              AbilityConstructorReference {} ->
                Bool
isFQN_
              Element
_ ->
                Bool
False

      className :: Text
className =
        Element -> Text
elementToClassName Element
el

      content :: HtmlT Identity ()
content
        | Text -> Text -> Bool
Text.isInfixOf Text
"->" Text
sText = [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
span_ [Text -> Attribute
class_ Text
"arrow"] (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
L.toHtml Text
sText
        | Bool
isFQN = Name -> HtmlT Identity ()
nameToHtml (HasCallStack => Text -> Name
Text -> Name
Name.unsafeParseText Text
sText)
        | Bool
otherwise = Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
L.toHtml Text
sText
   in case Maybe (Text, Text)
ref of
        Just (Text
r, Text
refType) ->
          [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
span_ [Text -> Attribute
class_ Text
className, Text -> Text -> Attribute
data_ Text
"ref" Text
r, Text -> Text -> Attribute
data_ Text
"ref-type" Text
refType] HtmlT Identity ()
content
        Maybe (Text, Text)
_ ->
          [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
span_ [Text -> Attribute
class_ Text
className] HtmlT Identity ()
content

elementToClassName :: Element -> Text
elementToClassName :: Element -> Text
elementToClassName Element
el =
  case Element
el of
    Element
NumericLiteral ->
      Text
"numeric-literal"
    Element
TextLiteral ->
      Text
"text-literal"
    Element
BytesLiteral ->
      Text
"bytes-literal"
    Element
CharLiteral ->
      Text
"char-literal"
    Element
BooleanLiteral ->
      Text
"boolean-literal"
    Element
Blank ->
      Text
"blank"
    Element
Var ->
      Text
"var"
    TypeReference {} ->
      Text
"type-reference"
    TermReference {} ->
      Text
"term-reference"
    DataConstructorReference {} ->
      Text
"data-constructor-reference"
    AbilityConstructorReference {} ->
      Text
"ability-constructor-reference"
    Op SeqOp
seqOp ->
      case SeqOp
seqOp of
        SeqOp
Cons ->
          Text
"op cons"
        SeqOp
Snoc ->
          Text
"op snoc"
        SeqOp
Concat ->
          Text
"op concat"
    Element
AbilityBraces ->
      Text
"ability-braces"
    Element
ControlKeyword ->
      Text
"control-keyword"
    Element
TypeOperator ->
      Text
"type-operator"
    Element
BindingEquals ->
      Text
"binding-equals"
    Element
TypeAscriptionColon ->
      Text
"type-ascription-colon"
    Element
DataTypeKeyword -> Text
"data-type-keyword"
    Element
DataTypeParams ->
      Text
"data-type-params"
    Element
Unit ->
      Text
"unit"
    Element
DataTypeModifier ->
      Text
"data-type-modifier"
    Element
UseKeyword ->
      Text
"use-keyword"
    Element
UsePrefix ->
      Text
"use-prefix"
    Element
UseSuffix ->
      Text
"use-suffix"
    HashQualifier {} ->
      Text
"hash-qualifier"
    Element
DelayForceChar ->
      Text
"delay-force-char"
    Element
DelimiterChar ->
      Text
"delimeter-char"
    Element
Parenthesis ->
      Text
"parenthesis"
    Element
LinkKeyword ->
      Text
"link-keyword"
    Element
DocDelimiter ->
      Text
"doc-delimeter"
    Element
DocKeyword ->
      Text
"doc-keyword"