{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# OPTIONS_GHC -Wunused-imports #-}
{-# OPTIONS_GHC -Wunused-matches #-}
{-# OPTIONS_GHC -Wunused-binds #-}

------------------------------------------------------------------------
-- | The parser monad used by the operator parser
------------------------------------------------------------------------

{-# LANGUAGE CPP #-}

module Mikan.Syntax.Concrete.Operators.Parser.Monad
  ( MemoKey(..), PrecedenceKey
  , Parser
  , parse
  , sat'
  , sat
  , doc
  , memoise
  , memoiseIfPrinting
  , grammar
  , pattern LeftPK
  , pattern RightPK
  ) where

import Data.Hashable
import GHC.Generics (Generic)
#if ! (__GLASGOW_HASKELL__ <= 908)
import GHC.Exts
#endif
import GHC.Word (Word64(..))

import Mikan.Syntax.Common
import Mikan.Syntax.Common.Pretty

import Mikan.Utils.Parser.MemoisedCPS qualified as Parser
import Mikan.Utils.Hash

-- | Memoisation keys.

data MemoKey
  = NodeK      {-# UNPACK #-} !PrecedenceKey
  | PostLeftsK {-# UNPACK #-} !PrecedenceKey
  | PreRightsK {-# UNPACK #-} !PrecedenceKey
  | TopK
  | AppK
  | ArgsK
  | NonfixK
  deriving (MemoKey -> MemoKey -> Bool
(MemoKey -> MemoKey -> Bool)
-> (MemoKey -> MemoKey -> Bool) -> Eq MemoKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MemoKey -> MemoKey -> Bool
== :: MemoKey -> MemoKey -> Bool
$c/= :: MemoKey -> MemoKey -> Bool
/= :: MemoKey -> MemoKey -> Bool
Eq, Int -> MemoKey -> ShowS
[MemoKey] -> ShowS
MemoKey -> String
(Int -> MemoKey -> ShowS)
-> (MemoKey -> String) -> ([MemoKey] -> ShowS) -> Show MemoKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MemoKey -> ShowS
showsPrec :: Int -> MemoKey -> ShowS
$cshow :: MemoKey -> String
show :: MemoKey -> String
$cshowList :: [MemoKey] -> ShowS
showList :: [MemoKey] -> ShowS
Show, (forall x. MemoKey -> Rep MemoKey x)
-> (forall x. Rep MemoKey x -> MemoKey) -> Generic MemoKey
forall x. Rep MemoKey x -> MemoKey
forall x. MemoKey -> Rep MemoKey x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. MemoKey -> Rep MemoKey x
from :: forall x. MemoKey -> Rep MemoKey x
$cto :: forall x. Rep MemoKey x -> MemoKey
to :: forall x. Rep MemoKey x -> MemoKey
Generic)

data PrecedenceKey = PrecKey !Bool !PrecedenceLevel
  deriving (PrecedenceKey -> PrecedenceKey -> Bool
(PrecedenceKey -> PrecedenceKey -> Bool)
-> (PrecedenceKey -> PrecedenceKey -> Bool) -> Eq PrecedenceKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PrecedenceKey -> PrecedenceKey -> Bool
== :: PrecedenceKey -> PrecedenceKey -> Bool
$c/= :: PrecedenceKey -> PrecedenceKey -> Bool
/= :: PrecedenceKey -> PrecedenceKey -> Bool
Eq, Int -> PrecedenceKey -> ShowS
[PrecedenceKey] -> ShowS
PrecedenceKey -> String
(Int -> PrecedenceKey -> ShowS)
-> (PrecedenceKey -> String)
-> ([PrecedenceKey] -> ShowS)
-> Show PrecedenceKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PrecedenceKey -> ShowS
showsPrec :: Int -> PrecedenceKey -> ShowS
$cshow :: PrecedenceKey -> String
show :: PrecedenceKey -> String
$cshowList :: [PrecedenceKey] -> ShowS
showList :: [PrecedenceKey] -> ShowS
Show, Eq PrecedenceKey
Eq PrecedenceKey =>
(PrecedenceKey -> PrecedenceKey -> Ordering)
-> (PrecedenceKey -> PrecedenceKey -> Bool)
-> (PrecedenceKey -> PrecedenceKey -> Bool)
-> (PrecedenceKey -> PrecedenceKey -> Bool)
-> (PrecedenceKey -> PrecedenceKey -> Bool)
-> (PrecedenceKey -> PrecedenceKey -> PrecedenceKey)
-> (PrecedenceKey -> PrecedenceKey -> PrecedenceKey)
-> Ord PrecedenceKey
PrecedenceKey -> PrecedenceKey -> Bool
PrecedenceKey -> PrecedenceKey -> Ordering
PrecedenceKey -> PrecedenceKey -> PrecedenceKey
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 :: PrecedenceKey -> PrecedenceKey -> Ordering
compare :: PrecedenceKey -> PrecedenceKey -> Ordering
$c< :: PrecedenceKey -> PrecedenceKey -> Bool
< :: PrecedenceKey -> PrecedenceKey -> Bool
$c<= :: PrecedenceKey -> PrecedenceKey -> Bool
<= :: PrecedenceKey -> PrecedenceKey -> Bool
$c> :: PrecedenceKey -> PrecedenceKey -> Bool
> :: PrecedenceKey -> PrecedenceKey -> Bool
$c>= :: PrecedenceKey -> PrecedenceKey -> Bool
>= :: PrecedenceKey -> PrecedenceKey -> Bool
$cmax :: PrecedenceKey -> PrecedenceKey -> PrecedenceKey
max :: PrecedenceKey -> PrecedenceKey -> PrecedenceKey
$cmin :: PrecedenceKey -> PrecedenceKey -> PrecedenceKey
min :: PrecedenceKey -> PrecedenceKey -> PrecedenceKey
Ord)

-- | Sorts 'TopK', 'AppK', 'NonfixK', followed by 'NodeK', 'PostLeftsK'
-- and 'PreRightsK', but grouped by precedence key
-- (so @infix N < post N < pre N < infix (N + 1) < ...@).
instance Ord MemoKey where
  compare :: MemoKey -> MemoKey -> Ordering
compare = \case
    MemoKey
TopK -> \case
      MemoKey
TopK -> Ordering
EQ
      MemoKey
_    -> Ordering
LT
    MemoKey
AppK -> \case
      MemoKey
TopK -> Ordering
GT
      MemoKey
AppK -> Ordering
EQ
      MemoKey
_    -> Ordering
LT
    MemoKey
ArgsK -> \case
      MemoKey
TopK  -> Ordering
GT
      MemoKey
AppK  -> Ordering
GT
      MemoKey
ArgsK -> Ordering
EQ
      MemoKey
_     -> Ordering
LT
    MemoKey
NonfixK -> \case
      MemoKey
TopK    -> Ordering
GT
      MemoKey
AppK    -> Ordering
GT
      MemoKey
ArgsK   -> Ordering
GT
      MemoKey
NonfixK -> Ordering
EQ
      MemoKey
_       -> Ordering
LT
    NodeK PrecedenceKey
p1 -> \case
      NodeK      PrecedenceKey
p2 -> PrecedenceKey
p1 PrecedenceKey -> PrecedenceKey -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` PrecedenceKey
p2
      PreRightsK PrecedenceKey
p2 -> (PrecedenceKey
p1 PrecedenceKey -> PrecedenceKey -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` PrecedenceKey
p2) Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Ordering
LT
      PostLeftsK PrecedenceKey
p2 -> (PrecedenceKey
p1 PrecedenceKey -> PrecedenceKey -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` PrecedenceKey
p2) Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Ordering
LT
      MemoKey
_             -> Ordering
GT
    PreRightsK PrecedenceKey
p1 -> \case
      NodeK      PrecedenceKey
p2 -> (PrecedenceKey
p1 PrecedenceKey -> PrecedenceKey -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` PrecedenceKey
p2) Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Ordering
GT
      PreRightsK PrecedenceKey
p2 -> PrecedenceKey
p1 PrecedenceKey -> PrecedenceKey -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` PrecedenceKey
p2
      PostLeftsK PrecedenceKey
p2 -> (PrecedenceKey
p1 PrecedenceKey -> PrecedenceKey -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` PrecedenceKey
p2) Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Ordering
LT
      MemoKey
_             -> Ordering
GT
    PostLeftsK PrecedenceKey
p1 -> \case
      NodeK      PrecedenceKey
p2 -> (PrecedenceKey
p1 PrecedenceKey -> PrecedenceKey -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` PrecedenceKey
p2) Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Ordering
GT
      PreRightsK PrecedenceKey
p2 -> (PrecedenceKey
p1 PrecedenceKey -> PrecedenceKey -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` PrecedenceKey
p2) Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Ordering
GT
      PostLeftsK PrecedenceKey
p2 -> PrecedenceKey
p1 PrecedenceKey -> PrecedenceKey -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` PrecedenceKey
p2
      MemoKey
_             -> Ordering
GT

pattern RightPK :: PrecedenceLevel -> PrecedenceKey
pattern $bRightPK :: PrecedenceLevel -> PrecedenceKey
$mRightPK :: forall {r}.
PrecedenceKey -> (PrecedenceLevel -> r) -> ((# #) -> r) -> r
RightPK l = PrecKey False l

pattern LeftPK :: PrecedenceLevel -> PrecedenceKey
pattern $bLeftPK :: PrecedenceLevel -> PrecedenceKey
$mLeftPK :: forall {r}.
PrecedenceKey -> (PrecedenceLevel -> r) -> ((# #) -> r) -> r
LeftPK l = PrecKey True l

{-# COMPLETE RightPK, LeftPK #-}

instance Pretty PrecedenceKey where
  pretty :: PrecedenceKey -> Doc
pretty = \case
    RightPK PrecedenceLevel
key -> Doc -> Doc
hlNumber (PrecedenceLevel -> Doc
forall a. Pretty a => a -> Doc
pretty PrecedenceLevel
key)
    LeftPK  PrecedenceLevel
key -> Doc -> Doc
hlFunction Doc
"unrelated" Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Doc -> Doc
hlNumber (PrecedenceLevel -> Doc
forall a. Pretty a => a -> Doc
pretty PrecedenceLevel
key)

instance Pretty MemoKey where
  pretty :: MemoKey -> Doc
pretty = \case
    NodeK       PrecedenceKey
key -> Doc -> Doc
hlFunction Doc
"Operator" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens (PrecedenceKey -> Doc
forall a. Pretty a => a -> Doc
pretty PrecedenceKey
key)
    PostLeftsK PrecedenceKey
prec -> Doc -> Doc
hlFunction Doc
"PostLeft" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens (Doc -> Doc
hlNumber (PrecedenceKey -> Doc
forall a. Pretty a => a -> Doc
pretty PrecedenceKey
prec))
    PreRightsK PrecedenceKey
prec -> Doc -> Doc
hlFunction Doc
"PreRight" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens (Doc -> Doc
hlNumber (PrecedenceKey -> Doc
forall a. Pretty a => a -> Doc
pretty PrecedenceKey
prec))
    MemoKey
TopK            -> Doc -> Doc
hlFunction Doc
"Top"
    MemoKey
AppK            -> Doc -> Doc
hlFunction Doc
"App"
    MemoKey
NonfixK         -> Doc -> Doc
hlFunction Doc
"Non"
    MemoKey
ArgsK           -> Doc -> Doc
hlFunction Doc
"Args"


#if __GLASGOW_HASKELL__ <= 908
doubleToWord64 :: Double -> Word64
doubleToWord64 x = fromIntegral $ hash x
#else
doubleToWord64 :: Double -> Word64
doubleToWord64 :: PrecedenceLevel -> Word64
doubleToWord64 (D# Double#
x) = Word64# -> Word64
W64# (Double# -> Word64#
castDoubleToWord64# Double#
x)
#endif

instance Hashable PrecedenceKey where
  hashWithSalt :: Int -> PrecedenceKey -> Int
hashWithSalt Int
h (PrecKey Bool
b PrecedenceLevel
l) = Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int) -> Word -> Int
forall a b. (a -> b) -> a -> b
$
    Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Bool -> Int
forall a. Enum a => a -> Int
fromEnum Bool
b) Word -> Word -> Word
`combineWord` Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PrecedenceLevel -> Word64
doubleToWord64 PrecedenceLevel
l)

instance Hashable MemoKey where
  hashWithSalt :: Int -> MemoKey -> Int
hashWithSalt Int
h = \case
    NodeK PrecedenceKey
pk      -> Int -> PrecedenceKey -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt (Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) PrecedenceKey
pk
    PostLeftsK PrecedenceKey
pk -> Int -> PrecedenceKey -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt (Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) PrecedenceKey
pk
    PreRightsK PrecedenceKey
pk -> Int -> PrecedenceKey -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt (Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3) PrecedenceKey
pk
    MemoKey
TopK          -> Int -> Int -> Int
combineInt Int
h Int
4
    MemoKey
AppK          -> Int -> Int -> Int
combineInt Int
h Int
5
    MemoKey
NonfixK       -> Int -> Int -> Int
combineInt Int
h Int
6
    MemoKey
ArgsK         -> Int -> Int -> Int
combineInt Int
h Int
7

-- | The parser monad.
type Parser tok a =
#ifdef DEBUG_PARSING
  Parser.ParserWithGrammar
#else
  Parser.Parser
#endif
    MemoKey tok (MaybePlaceholder tok) a

-- | Runs the parser.

parse :: forall tok a. Parser tok a -> [MaybePlaceholder tok] -> [a]
parse :: forall tok a. Parser tok a -> [MaybePlaceholder tok] -> [a]
parse = Parser MemoKey tok (MaybePlaceholder tok) a
-> [MaybePlaceholder tok] -> [a]
forall a.
Parser MemoKey tok (MaybePlaceholder tok) a
-> [MaybePlaceholder tok] -> [a]
forall (p :: * -> *) k r tok a.
ParserClass p k r tok =>
p a -> [tok] -> [a]
Parser.parse

-- | Parses a token satisfying the given predicate. The computed value
-- is returned.

sat' :: (MaybePlaceholder tok -> Maybe a) -> Parser tok a
sat' :: forall tok a. (MaybePlaceholder tok -> Maybe a) -> Parser tok a
sat' = (MaybePlaceholder tok -> Maybe a)
-> Parser MemoKey tok (MaybePlaceholder tok) a
forall a.
(MaybePlaceholder tok -> Maybe a)
-> Parser MemoKey tok (MaybePlaceholder tok) a
forall (p :: * -> *) k r tok a.
ParserClass p k r tok =>
(tok -> Maybe a) -> p a
Parser.sat'

-- | Parses a token satisfying the given predicate.

sat :: (MaybePlaceholder tok -> Bool) ->
       Parser tok (MaybePlaceholder tok)
sat :: forall tok.
(MaybePlaceholder tok -> Bool) -> Parser tok (MaybePlaceholder tok)
sat = (MaybePlaceholder tok -> Bool)
-> Parser MemoKey tok (MaybePlaceholder tok) (MaybePlaceholder tok)
forall (p :: * -> *) k r tok.
ParserClass p k r tok =>
(tok -> Bool) -> p tok
Parser.sat

-- | Uses the given document as the printed representation of the
-- given parser. The document's precedence is taken to be 'atomP'.

doc :: Doc -> Parser tok a -> Parser tok a
doc :: forall tok a. Doc -> Parser tok a -> Parser tok a
doc = Doc
-> Parser MemoKey tok (MaybePlaceholder tok) a
-> Parser MemoKey tok (MaybePlaceholder tok) a
forall (p :: * -> *) k r tok a.
ParserClass p k r tok =>
Doc -> p a -> p a
Parser.doc

-- | Memoises the given parser.
--
-- Every memoised parser must be annotated with a /unique/ key.
-- (Parametrised parsers must use distinct keys for distinct inputs.)

memoise :: MemoKey -> Parser tok tok -> Parser tok tok
memoise :: forall tok. MemoKey -> Parser tok tok -> Parser tok tok
memoise = MemoKey
-> Parser MemoKey tok (MaybePlaceholder tok) tok
-> Parser MemoKey tok (MaybePlaceholder tok) tok
forall (p :: * -> *) k r tok.
(ParserClass p k r tok, Hashable k, Pretty k) =>
k -> p r -> p r
Parser.memoise

-- | Memoises the given parser, but only if printing, not if parsing.
--
-- Every memoised parser must be annotated with a /unique/ key.
-- (Parametrised parsers must use distinct keys for distinct inputs.)

memoiseIfPrinting :: MemoKey -> Parser tok tok -> Parser tok tok
memoiseIfPrinting :: forall tok. MemoKey -> Parser tok tok -> Parser tok tok
memoiseIfPrinting = MemoKey
-> Parser MemoKey tok (MaybePlaceholder tok) tok
-> Parser MemoKey tok (MaybePlaceholder tok) tok
forall (p :: * -> *) k r tok.
(ParserClass p k r tok, Hashable k, Pretty k) =>
k -> p r -> p r
Parser.memoiseIfPrinting

-- | Tries to print the parser, or returns 'empty', depending on the
-- implementation. This function might not terminate.

grammar :: Parser tok a -> Doc
grammar :: forall tok a. Parser tok a -> Doc
grammar = Parser MemoKey tok (MaybePlaceholder tok) a -> Doc
forall a.
(Ord MemoKey, Pretty MemoKey) =>
Parser MemoKey tok (MaybePlaceholder tok) a -> Doc
forall (p :: * -> *) k r tok a.
(ParserClass p k r tok, Ord k, Pretty k) =>
p a -> Doc
Parser.grammar