{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE OverloadedStrings #-}

module PlutusCore.Lexer.Type
    ( Keyword (..)
    , Special (..)
    , Token (..)
    , allKeywords
    , IdentifierState
    , newIdentifier
    , emptyIdentifierState
    , identifierStateFrom
    ) where

import PlutusPrelude

import PlutusCore.Name

import Control.Monad.State
import Data.Map qualified as M
import Data.Text qualified as T

-- | A keyword in Plutus Core. Some of these are only for UPLC or TPLC, but it's simplest to share
-- the lexer, so we have a joint enumeration of them.
data Keyword
    = KwLam
    | KwProgram
    | KwCon
    | KwBuiltin
    | KwError
    -- TPLC only
    | KwAbs
    | KwFun
    | KwAll
    | KwType
    | KwIFix
    | KwIWrap
    | KwUnwrap
    -- UPLC only
    | KwForce
    | KwDelay
    deriving (Int -> Keyword -> ShowS
[Keyword] -> ShowS
Keyword -> String
(Int -> Keyword -> ShowS)
-> (Keyword -> String) -> ([Keyword] -> ShowS) -> Show Keyword
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Keyword] -> ShowS
$cshowList :: [Keyword] -> ShowS
show :: Keyword -> String
$cshow :: Keyword -> String
showsPrec :: Int -> Keyword -> ShowS
$cshowsPrec :: Int -> Keyword -> ShowS
Show, Keyword -> Keyword -> Bool
(Keyword -> Keyword -> Bool)
-> (Keyword -> Keyword -> Bool) -> Eq Keyword
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Keyword -> Keyword -> Bool
$c/= :: Keyword -> Keyword -> Bool
== :: Keyword -> Keyword -> Bool
$c== :: Keyword -> Keyword -> Bool
Eq, Eq Keyword
Eq Keyword
-> (Keyword -> Keyword -> Ordering)
-> (Keyword -> Keyword -> Bool)
-> (Keyword -> Keyword -> Bool)
-> (Keyword -> Keyword -> Bool)
-> (Keyword -> Keyword -> Bool)
-> (Keyword -> Keyword -> Keyword)
-> (Keyword -> Keyword -> Keyword)
-> Ord Keyword
Keyword -> Keyword -> Bool
Keyword -> Keyword -> Ordering
Keyword -> Keyword -> Keyword
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
min :: Keyword -> Keyword -> Keyword
$cmin :: Keyword -> Keyword -> Keyword
max :: Keyword -> Keyword -> Keyword
$cmax :: Keyword -> Keyword -> Keyword
>= :: Keyword -> Keyword -> Bool
$c>= :: Keyword -> Keyword -> Bool
> :: Keyword -> Keyword -> Bool
$c> :: Keyword -> Keyword -> Bool
<= :: Keyword -> Keyword -> Bool
$c<= :: Keyword -> Keyword -> Bool
< :: Keyword -> Keyword -> Bool
$c< :: Keyword -> Keyword -> Bool
compare :: Keyword -> Keyword -> Ordering
$ccompare :: Keyword -> Keyword -> Ordering
$cp1Ord :: Eq Keyword
Ord, Int -> Keyword
Keyword -> Int
Keyword -> [Keyword]
Keyword -> Keyword
Keyword -> Keyword -> [Keyword]
Keyword -> Keyword -> Keyword -> [Keyword]
(Keyword -> Keyword)
-> (Keyword -> Keyword)
-> (Int -> Keyword)
-> (Keyword -> Int)
-> (Keyword -> [Keyword])
-> (Keyword -> Keyword -> [Keyword])
-> (Keyword -> Keyword -> [Keyword])
-> (Keyword -> Keyword -> Keyword -> [Keyword])
-> Enum Keyword
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Keyword -> Keyword -> Keyword -> [Keyword]
$cenumFromThenTo :: Keyword -> Keyword -> Keyword -> [Keyword]
enumFromTo :: Keyword -> Keyword -> [Keyword]
$cenumFromTo :: Keyword -> Keyword -> [Keyword]
enumFromThen :: Keyword -> Keyword -> [Keyword]
$cenumFromThen :: Keyword -> Keyword -> [Keyword]
enumFrom :: Keyword -> [Keyword]
$cenumFrom :: Keyword -> [Keyword]
fromEnum :: Keyword -> Int
$cfromEnum :: Keyword -> Int
toEnum :: Int -> Keyword
$ctoEnum :: Int -> Keyword
pred :: Keyword -> Keyword
$cpred :: Keyword -> Keyword
succ :: Keyword -> Keyword
$csucc :: Keyword -> Keyword
Enum, Keyword
Keyword -> Keyword -> Bounded Keyword
forall a. a -> a -> Bounded a
maxBound :: Keyword
$cmaxBound :: Keyword
minBound :: Keyword
$cminBound :: Keyword
Bounded, (forall x. Keyword -> Rep Keyword x)
-> (forall x. Rep Keyword x -> Keyword) -> Generic Keyword
forall x. Rep Keyword x -> Keyword
forall x. Keyword -> Rep Keyword x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Keyword x -> Keyword
$cfrom :: forall x. Keyword -> Rep Keyword x
Generic, Keyword -> ()
(Keyword -> ()) -> NFData Keyword
forall a. (a -> ()) -> NFData a
rnf :: Keyword -> ()
$crnf :: Keyword -> ()
NFData)

-- | A special character. This type is only used internally between the lexer
-- and the parser.
data Special
    = OpenParen
    | CloseParen
    | OpenBracket
    | CloseBracket
    | Dot
    | OpenBrace
    | CloseBrace
    deriving (Int -> Special -> ShowS
[Special] -> ShowS
Special -> String
(Int -> Special -> ShowS)
-> (Special -> String) -> ([Special] -> ShowS) -> Show Special
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Special] -> ShowS
$cshowList :: [Special] -> ShowS
show :: Special -> String
$cshow :: Special -> String
showsPrec :: Int -> Special -> ShowS
$cshowsPrec :: Int -> Special -> ShowS
Show, Special -> Special -> Bool
(Special -> Special -> Bool)
-> (Special -> Special -> Bool) -> Eq Special
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Special -> Special -> Bool
$c/= :: Special -> Special -> Bool
== :: Special -> Special -> Bool
$c== :: Special -> Special -> Bool
Eq, Eq Special
Eq Special
-> (Special -> Special -> Ordering)
-> (Special -> Special -> Bool)
-> (Special -> Special -> Bool)
-> (Special -> Special -> Bool)
-> (Special -> Special -> Bool)
-> (Special -> Special -> Special)
-> (Special -> Special -> Special)
-> Ord Special
Special -> Special -> Bool
Special -> Special -> Ordering
Special -> Special -> Special
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
min :: Special -> Special -> Special
$cmin :: Special -> Special -> Special
max :: Special -> Special -> Special
$cmax :: Special -> Special -> Special
>= :: Special -> Special -> Bool
$c>= :: Special -> Special -> Bool
> :: Special -> Special -> Bool
$c> :: Special -> Special -> Bool
<= :: Special -> Special -> Bool
$c<= :: Special -> Special -> Bool
< :: Special -> Special -> Bool
$c< :: Special -> Special -> Bool
compare :: Special -> Special -> Ordering
$ccompare :: Special -> Special -> Ordering
$cp1Ord :: Eq Special
Ord, (forall x. Special -> Rep Special x)
-> (forall x. Rep Special x -> Special) -> Generic Special
forall x. Rep Special x -> Special
forall x. Special -> Rep Special x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Special x -> Special
$cfrom :: forall x. Special -> Rep Special x
Generic, Special -> ()
(Special -> ()) -> NFData Special
forall a. (a -> ()) -> NFData a
rnf :: Special -> ()
$crnf :: Special -> ()
NFData)

-- | A token generated by the tker.
data Token ann
    = TkName  { Token ann -> ann
tkLoc        :: ann
              , Token ann -> Text
tkName       :: T.Text  -- String??
              , Token ann -> Unique
tkIdentifier :: Unique -- ^ A 'Unique' assigned to the identifier during lexing.
              }
    | TkBuiltinFnId    { tkLoc :: ann, Token ann -> Text
tkBuiltinFnId   :: T.Text }
    | TkBuiltinTypeId  { tkLoc :: ann, Token ann -> Text
tkBuiltinTypeId :: T.Text }
    | TkLiteralConst   { tkLoc :: ann, Token ann -> Text
tkLiteralConst  :: T.Text }
    | TkNat            { tkLoc :: ann, Token ann -> Natural
tkNat           :: Natural }
    | TkKeyword        { tkLoc :: ann, Token ann -> Keyword
tkKeyword       :: Keyword }
    | TkSpecial        { tkLoc :: ann, Token ann -> Special
tkSpecial       :: Special }
    | EOF              { tkLoc :: ann }
    deriving (Int -> Token ann -> ShowS
[Token ann] -> ShowS
Token ann -> String
(Int -> Token ann -> ShowS)
-> (Token ann -> String)
-> ([Token ann] -> ShowS)
-> Show (Token ann)
forall ann. Show ann => Int -> Token ann -> ShowS
forall ann. Show ann => [Token ann] -> ShowS
forall ann. Show ann => Token ann -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Token ann] -> ShowS
$cshowList :: forall ann. Show ann => [Token ann] -> ShowS
show :: Token ann -> String
$cshow :: forall ann. Show ann => Token ann -> String
showsPrec :: Int -> Token ann -> ShowS
$cshowsPrec :: forall ann. Show ann => Int -> Token ann -> ShowS
Show, Token ann -> Token ann -> Bool
(Token ann -> Token ann -> Bool)
-> (Token ann -> Token ann -> Bool) -> Eq (Token ann)
forall ann. Eq ann => Token ann -> Token ann -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Token ann -> Token ann -> Bool
$c/= :: forall ann. Eq ann => Token ann -> Token ann -> Bool
== :: Token ann -> Token ann -> Bool
$c== :: forall ann. Eq ann => Token ann -> Token ann -> Bool
Eq, Eq (Token ann)
Eq (Token ann)
-> (Token ann -> Token ann -> Ordering)
-> (Token ann -> Token ann -> Bool)
-> (Token ann -> Token ann -> Bool)
-> (Token ann -> Token ann -> Bool)
-> (Token ann -> Token ann -> Bool)
-> (Token ann -> Token ann -> Token ann)
-> (Token ann -> Token ann -> Token ann)
-> Ord (Token ann)
Token ann -> Token ann -> Bool
Token ann -> Token ann -> Ordering
Token ann -> Token ann -> Token ann
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
forall ann. Ord ann => Eq (Token ann)
forall ann. Ord ann => Token ann -> Token ann -> Bool
forall ann. Ord ann => Token ann -> Token ann -> Ordering
forall ann. Ord ann => Token ann -> Token ann -> Token ann
min :: Token ann -> Token ann -> Token ann
$cmin :: forall ann. Ord ann => Token ann -> Token ann -> Token ann
max :: Token ann -> Token ann -> Token ann
$cmax :: forall ann. Ord ann => Token ann -> Token ann -> Token ann
>= :: Token ann -> Token ann -> Bool
$c>= :: forall ann. Ord ann => Token ann -> Token ann -> Bool
> :: Token ann -> Token ann -> Bool
$c> :: forall ann. Ord ann => Token ann -> Token ann -> Bool
<= :: Token ann -> Token ann -> Bool
$c<= :: forall ann. Ord ann => Token ann -> Token ann -> Bool
< :: Token ann -> Token ann -> Bool
$c< :: forall ann. Ord ann => Token ann -> Token ann -> Bool
compare :: Token ann -> Token ann -> Ordering
$ccompare :: forall ann. Ord ann => Token ann -> Token ann -> Ordering
$cp1Ord :: forall ann. Ord ann => Eq (Token ann)
Ord, (forall x. Token ann -> Rep (Token ann) x)
-> (forall x. Rep (Token ann) x -> Token ann)
-> Generic (Token ann)
forall x. Rep (Token ann) x -> Token ann
forall x. Token ann -> Rep (Token ann) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall ann x. Rep (Token ann) x -> Token ann
forall ann x. Token ann -> Rep (Token ann) x
$cto :: forall ann x. Rep (Token ann) x -> Token ann
$cfrom :: forall ann x. Token ann -> Rep (Token ann) x
Generic, Token ann -> ()
(Token ann -> ()) -> NFData (Token ann)
forall ann. NFData ann => Token ann -> ()
forall a. (a -> ()) -> NFData a
rnf :: Token ann -> ()
$crnf :: forall ann. NFData ann => Token ann -> ()
NFData, a -> Token b -> Token a
(a -> b) -> Token a -> Token b
(forall a b. (a -> b) -> Token a -> Token b)
-> (forall a b. a -> Token b -> Token a) -> Functor Token
forall a b. a -> Token b -> Token a
forall a b. (a -> b) -> Token a -> Token b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Token b -> Token a
$c<$ :: forall a b. a -> Token b -> Token a
fmap :: (a -> b) -> Token a -> Token b
$cfmap :: forall a b. (a -> b) -> Token a -> Token b
Functor)

instance Pretty Special where
    pretty :: Special -> Doc ann
pretty Special
OpenParen    = Doc ann
"("
    pretty Special
CloseParen   = Doc ann
")"
    pretty Special
OpenBracket  = Doc ann
"["
    pretty Special
CloseBracket = Doc ann
"]"
    pretty Special
Dot          = Doc ann
"."
    pretty Special
OpenBrace    = Doc ann
"{"
    pretty Special
CloseBrace   = Doc ann
"}"

instance Pretty Keyword where
    pretty :: Keyword -> Doc ann
pretty Keyword
KwAbs     = Doc ann
"abs"
    pretty Keyword
KwLam     = Doc ann
"lam"
    pretty Keyword
KwIFix    = Doc ann
"ifix"
    pretty Keyword
KwFun     = Doc ann
"fun"
    pretty Keyword
KwAll     = Doc ann
"all"
    pretty Keyword
KwType    = Doc ann
"type"
    pretty Keyword
KwProgram = Doc ann
"program"
    pretty Keyword
KwCon     = Doc ann
"con"
    pretty Keyword
KwIWrap   = Doc ann
"iwrap"
    pretty Keyword
KwBuiltin = Doc ann
"builtin"
    pretty Keyword
KwUnwrap  = Doc ann
"unwrap"
    pretty Keyword
KwError   = Doc ann
"error"
    pretty Keyword
KwForce   = Doc ann
"force"
    pretty Keyword
KwDelay   = Doc ann
"delay"

instance Pretty (Token ann) where
    pretty :: Token ann -> Doc ann
pretty (TkName ann
_ Text
n Unique
_)            = Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
n
    pretty (TkNat ann
_ Natural
n)               = Natural -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Natural
n
    pretty (TkBuiltinFnId ann
_ Text
ident)   = Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
ident
    pretty (TkBuiltinTypeId ann
_ Text
ident) = Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
ident
    pretty (TkLiteralConst ann
_ Text
lit)    = Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
lit
    pretty (TkKeyword ann
_ Keyword
kw)          = Keyword -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Keyword
kw
    pretty (TkSpecial ann
_ Special
s)           = Special -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Special
s
    pretty EOF{}                     = Doc ann
forall a. Monoid a => a
mempty

-- | The list of all 'Keyword's.
allKeywords :: [Keyword]
allKeywords :: [Keyword]
allKeywords = [Keyword
forall a. Bounded a => a
minBound .. Keyword
forall a. Bounded a => a
maxBound]

-- | An 'IdentifierState' includes a map indexed by 'Int's as well as a map
-- indexed by 'ByteString's. It is used during parsing.
type IdentifierState = (M.Map T.Text Unique, Unique)

emptyIdentifierState :: IdentifierState
emptyIdentifierState :: IdentifierState
emptyIdentifierState = (Map Text Unique
forall a. Monoid a => a
mempty, Int -> Unique
Unique Int
0)

identifierStateFrom :: Unique -> IdentifierState
identifierStateFrom :: Unique -> IdentifierState
identifierStateFrom Unique
u = (Map Text Unique
forall a. Monoid a => a
mempty, Unique
u)

newIdentifier :: (MonadState IdentifierState m) => T.Text -> m Unique
newIdentifier :: Text -> m Unique
newIdentifier Text
str = do
    (Map Text Unique
ss, Unique
nextU) <- m IdentifierState
forall s (m :: * -> *). MonadState s m => m s
get
    case Text -> Map Text Unique -> Maybe Unique
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
str Map Text Unique
ss of
        Just Unique
k -> Unique -> m Unique
forall (f :: * -> *) a. Applicative f => a -> f a
pure Unique
k
        Maybe Unique
Nothing -> do
            let nextU' :: Unique
nextU' = Int -> Unique
Unique (Int -> Unique) -> Int -> Unique
forall a b. (a -> b) -> a -> b
$ Unique -> Int
unUnique Unique
nextU Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
            IdentifierState -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Text -> Unique -> Map Text Unique -> Map Text Unique
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
str Unique
nextU Map Text Unique
ss, Unique
nextU')
            Unique -> m Unique
forall (f :: * -> *) a. Applicative f => a -> f a
pure Unique
nextU