module Examples.Lang.Arith where

import UVMHS

syntax ∷ LexerBasicSyntax
syntax :: LexerBasicSyntax
syntax = LexerBasicSyntax
forall a. Null a => a
null
  { lexerBasicSyntaxPuns = pow ["(",")"]
  , lexerBasicSyntaxOprs = pow ["==","+","*","-","^","!"]
  }

lexer ∷ Lexer CharClass ℂ TokenClassBasic ℕ64 TokenBasic
lexer :: Lexer CharClass ℂ TokenClassBasic ℕ64 TokenBasic
lexer = LexerBasicSyntax
-> Lexer CharClass ℂ TokenClassBasic ℕ64 TokenBasic
lexerBasic LexerBasicSyntax
syntax

testTokenizerSuccess ∷ IO ()
testTokenizerSuccess :: IO ()
testTokenizerSuccess =
  Lexer CharClass ℂ TokenClassBasic ℕ64 TokenBasic
-> Text -> 𝕍 (ParserToken ℂ) -> IO ()
forall c t o u w.
(Show u, Ord c, Ord t, Pretty t, Classified c t, Eq o, Eq u,
 Plus u, Pretty w) =>
Lexer c t o u w -> Text -> 𝕍 (ParserToken t) -> IO ()
tokenizeIOMain Lexer CharClass ℂ TokenClassBasic ℕ64 TokenBasic
lexer Text
"" (𝕍 (ParserToken ℂ) -> IO ()) -> 𝕍 (ParserToken ℂ) -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> 𝕍 (ParserToken ℂ)
tokens Text
"1 + 2 - 3 * 4 ^ 5 ! == 1 \n -- blah blah \n {- ml {{- ml --}-} -- blah\nb"

data Lit =
    IntegerL ℤ
  | DoubleL 𝔻
  | StringL 𝕊
makePrettySum ''Lit

data Atom =
    LitA Lit
  | NameA 𝕊
makePrettySum ''Atom

type Exp = 𝐴 SrcCxt ExpPre
data ExpPre =
    AtomE Atom
  | PlusE Exp Exp
  | TimesE Exp Exp
  | ExpoE Exp Exp
  | FactE Exp
  | NegateE Exp
  | EqualE Exp Exp
makePrisms ''ExpPre
makePrettySum ''ExpPre

cpLit ∷ CParser TokenBasic Lit
cpLit :: CParser TokenBasic Lit
cpLit = [CParser TokenBasic Lit] -> CParser TokenBasic Lit
forall (m :: * -> *) a t.
(Monad m, MonadFail m, ToIter (m a) t) =>
t -> m a
tries
  [ ℤ -> Lit
IntegerL (ℤ -> Lit) -> CParser TokenBasic ℤ -> CParser TokenBasic Lit
forall (t :: * -> *) a b. Functor t => (a -> b) -> t a -> t b
^$ CParser TokenBasic ℤ
cpInt
  , 𝔻 -> Lit
DoubleL (𝔻 -> Lit) -> CParser TokenBasic 𝔻 -> CParser TokenBasic Lit
forall (t :: * -> *) a b. Functor t => (a -> b) -> t a -> t b
^$ CParser TokenBasic 𝔻
cpDouble
  , Text -> Lit
StringL (Text -> Lit) -> CParser TokenBasic Text -> CParser TokenBasic Lit
forall (t :: * -> *) a b. Functor t => (a -> b) -> t a -> t b
^$ CParser TokenBasic Text
cpString
  ]

cpAtom ∷ CParser TokenBasic Atom
cpAtom :: CParser TokenBasic Atom
cpAtom = Text -> CParser TokenBasic Atom -> CParser TokenBasic Atom
forall t a. Ord t => Text -> CParser t a -> CParser t a
cpNewContext Text
"atom" (CParser TokenBasic Atom -> CParser TokenBasic Atom)
-> CParser TokenBasic Atom -> CParser TokenBasic Atom
forall a b. (a -> b) -> a -> b
$ [CParser TokenBasic Atom] -> CParser TokenBasic Atom
forall (m :: * -> *) a t.
(Monad m, MonadFail m, ToIter (m a) t) =>
t -> m a
tries
  [ Lit -> Atom
LitA (Lit -> Atom) -> CParser TokenBasic Lit -> CParser TokenBasic Atom
forall (t :: * -> *) a b. Functor t => (a -> b) -> t a -> t b
^$ CParser TokenBasic Lit
cpLit
  , Text -> Atom
NameA (Text -> Atom)
-> CParser TokenBasic Text -> CParser TokenBasic Atom
forall (t :: * -> *) a b. Functor t => (a -> b) -> t a -> t b
^$ (TokenBasic -> 𝑂 Text) -> CParser TokenBasic Text
forall t a. (t -> 𝑂 a) -> CParser t a
cpShaped ((TokenBasic -> 𝑂 Text) -> CParser TokenBasic Text)
-> (TokenBasic -> 𝑂 Text) -> CParser TokenBasic Text
forall a b. (a -> b) -> a -> b
$ (TokenBasic ⌲ Text) -> TokenBasic -> 𝑂 Text
forall a b. (a ⌲ b) -> a -> 𝑂 b
view TokenBasic ⌲ Text
nameTBasicL
  ]

cpExp ∷ CParser TokenBasic Exp
cpExp :: CParser TokenBasic Exp
cpExp = Text
-> MixfixF TokenBasic (𝐴 SrcCxt) ExpPre -> CParser TokenBasic Exp
forall t a.
Ord t =>
Text -> MixfixF t (𝐴 SrcCxt) a -> CParser t (𝐴 SrcCxt a)
fmixfixWithContext Text
"exp" (MixfixF TokenBasic (𝐴 SrcCxt) ExpPre -> CParser TokenBasic Exp)
-> MixfixF TokenBasic (𝐴 SrcCxt) ExpPre -> CParser TokenBasic Exp
forall a b. (a -> b) -> a -> b
$ [MixfixF TokenBasic (𝐴 SrcCxt) ExpPre]
-> MixfixF TokenBasic (𝐴 SrcCxt) ExpPre
forall a t. (Monoid a, ToIter a t) => t -> a
concat
  [ CParser TokenBasic ExpPre -> MixfixF TokenBasic (𝐴 SrcCxt) ExpPre
forall t a (f :: * -> *). CParser t a -> MixfixF t f a
fmixTerminal (CParser TokenBasic ExpPre -> MixfixF TokenBasic (𝐴 SrcCxt) ExpPre)
-> CParser TokenBasic ExpPre
-> MixfixF TokenBasic (𝐴 SrcCxt) ExpPre
forall a b. (a -> b) -> a -> b
$ do
      CParser TokenBasic TokenBasic -> CParser TokenBasic ()
forall (m :: * -> *) a. Functor m => m a -> m ()
void (CParser TokenBasic TokenBasic -> CParser TokenBasic ())
-> CParser TokenBasic TokenBasic -> CParser TokenBasic ()
forall a b. (a -> b) -> a -> b
$ TokenBasic -> CParser TokenBasic TokenBasic
forall t. Ord t => t -> CParser t t
cpToken (TokenBasic -> CParser TokenBasic TokenBasic)
-> TokenBasic -> CParser TokenBasic TokenBasic
forall a b. (a -> b) -> a -> b
$ Text -> TokenBasic
SyntaxTBasic Text
"("
      Exp
e ← CParser TokenBasic Exp
cpExp
      CParser TokenBasic TokenBasic -> CParser TokenBasic ()
forall (m :: * -> *) a. Functor m => m a -> m ()
void (CParser TokenBasic TokenBasic -> CParser TokenBasic ())
-> CParser TokenBasic TokenBasic -> CParser TokenBasic ()
forall a b. (a -> b) -> a -> b
$ TokenBasic -> CParser TokenBasic TokenBasic
forall t. Ord t => t -> CParser t t
cpToken (TokenBasic -> CParser TokenBasic TokenBasic)
-> TokenBasic -> CParser TokenBasic TokenBasic
forall a b. (a -> b) -> a -> b
$ Text -> TokenBasic
SyntaxTBasic Text
")"
      ExpPre -> CParser TokenBasic ExpPre
forall a. a -> CParser TokenBasic a
forall (m :: * -> *) a. Return m => a -> m a
return (ExpPre -> CParser TokenBasic ExpPre)
-> ExpPre -> CParser TokenBasic ExpPre
forall a b. (a -> b) -> a -> b
$ Exp -> ExpPre
forall a. 𝐴 SrcCxt a -> a
forall (w :: * -> *) a. Extract w => w a -> a
extract Exp
e
  , CParser TokenBasic ExpPre -> MixfixF TokenBasic (𝐴 SrcCxt) ExpPre
forall t a (f :: * -> *). CParser t a -> MixfixF t f a
fmixTerminal       (CParser TokenBasic ExpPre -> MixfixF TokenBasic (𝐴 SrcCxt) ExpPre)
-> CParser TokenBasic ExpPre
-> MixfixF TokenBasic (𝐴 SrcCxt) ExpPre
forall a b. (a -> b) -> a -> b
$ Atom -> ExpPre
AtomE         (Atom -> ExpPre)
-> CParser TokenBasic Atom -> CParser TokenBasic ExpPre
forall (t :: * -> *) a b. Functor t => (a -> b) -> t a -> t b
^$ CParser TokenBasic Atom
cpAtom
  , ℕ64
-> CParser TokenBasic (Exp -> Exp -> ExpPre)
-> MixfixF TokenBasic (𝐴 SrcCxt) ExpPre
forall t (f :: * -> *) a.
ℕ64 -> CParser t (f a -> f a -> a) -> MixfixF t f a
fmixInfix   ℕ64
pCMP   (CParser TokenBasic (Exp -> Exp -> ExpPre)
 -> MixfixF TokenBasic (𝐴 SrcCxt) ExpPre)
-> CParser TokenBasic (Exp -> Exp -> ExpPre)
-> MixfixF TokenBasic (𝐴 SrcCxt) ExpPre
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp -> ExpPre) -> TokenBasic -> Exp -> Exp -> ExpPre
forall a b. a -> b -> a
const Exp -> Exp -> ExpPre
EqualE  (TokenBasic -> Exp -> Exp -> ExpPre)
-> CParser TokenBasic TokenBasic
-> CParser TokenBasic (Exp -> Exp -> ExpPre)
forall (t :: * -> *) a b. Functor t => (a -> b) -> t a -> t b
^$ Text -> CParser TokenBasic TokenBasic
cpSyntax Text
"=="
  , ℕ64
-> CParser TokenBasic (Exp -> Exp -> ExpPre)
-> MixfixF TokenBasic (𝐴 SrcCxt) ExpPre
forall t (f :: * -> *) a.
ℕ64 -> CParser t (f a -> f a -> a) -> MixfixF t f a
fmixInfixR  ℕ64
pPLUS  (CParser TokenBasic (Exp -> Exp -> ExpPre)
 -> MixfixF TokenBasic (𝐴 SrcCxt) ExpPre)
-> CParser TokenBasic (Exp -> Exp -> ExpPre)
-> MixfixF TokenBasic (𝐴 SrcCxt) ExpPre
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp -> ExpPre) -> TokenBasic -> Exp -> Exp -> ExpPre
forall a b. a -> b -> a
const Exp -> Exp -> ExpPre
PlusE   (TokenBasic -> Exp -> Exp -> ExpPre)
-> CParser TokenBasic TokenBasic
-> CParser TokenBasic (Exp -> Exp -> ExpPre)
forall (t :: * -> *) a b. Functor t => (a -> b) -> t a -> t b
^$ Text -> CParser TokenBasic TokenBasic
cpSyntax Text
"+"
  , ℕ64
-> CParser TokenBasic (Exp -> Exp -> ExpPre)
-> MixfixF TokenBasic (𝐴 SrcCxt) ExpPre
forall t (f :: * -> *) a.
ℕ64 -> CParser t (f a -> f a -> a) -> MixfixF t f a
fmixInfixR  ℕ64
pTIMES (CParser TokenBasic (Exp -> Exp -> ExpPre)
 -> MixfixF TokenBasic (𝐴 SrcCxt) ExpPre)
-> CParser TokenBasic (Exp -> Exp -> ExpPre)
-> MixfixF TokenBasic (𝐴 SrcCxt) ExpPre
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp -> ExpPre) -> TokenBasic -> Exp -> Exp -> ExpPre
forall a b. a -> b -> a
const Exp -> Exp -> ExpPre
TimesE  (TokenBasic -> Exp -> Exp -> ExpPre)
-> CParser TokenBasic TokenBasic
-> CParser TokenBasic (Exp -> Exp -> ExpPre)
forall (t :: * -> *) a b. Functor t => (a -> b) -> t a -> t b
^$ Text -> CParser TokenBasic TokenBasic
cpSyntax Text
"*"
  , ℕ64
-> CParser TokenBasic (Exp -> ExpPre)
-> MixfixF TokenBasic (𝐴 SrcCxt) ExpPre
forall t (f :: * -> *) a.
ℕ64 -> CParser t (f a -> a) -> MixfixF t f a
fmixPrefix  ℕ64
pNEG   (CParser TokenBasic (Exp -> ExpPre)
 -> MixfixF TokenBasic (𝐴 SrcCxt) ExpPre)
-> CParser TokenBasic (Exp -> ExpPre)
-> MixfixF TokenBasic (𝐴 SrcCxt) ExpPre
forall a b. (a -> b) -> a -> b
$ (Exp -> ExpPre) -> TokenBasic -> Exp -> ExpPre
forall a b. a -> b -> a
const Exp -> ExpPre
NegateE (TokenBasic -> Exp -> ExpPre)
-> CParser TokenBasic TokenBasic
-> CParser TokenBasic (Exp -> ExpPre)
forall (t :: * -> *) a b. Functor t => (a -> b) -> t a -> t b
^$ Text -> CParser TokenBasic TokenBasic
cpSyntax Text
"-"
  , ℕ64
-> CParser TokenBasic (Exp -> Exp -> ExpPre)
-> MixfixF TokenBasic (𝐴 SrcCxt) ExpPre
forall t (f :: * -> *) a.
ℕ64 -> CParser t (f a -> f a -> a) -> MixfixF t f a
fmixInfixL  ℕ64
pPOW   (CParser TokenBasic (Exp -> Exp -> ExpPre)
 -> MixfixF TokenBasic (𝐴 SrcCxt) ExpPre)
-> CParser TokenBasic (Exp -> Exp -> ExpPre)
-> MixfixF TokenBasic (𝐴 SrcCxt) ExpPre
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp -> ExpPre) -> TokenBasic -> Exp -> Exp -> ExpPre
forall a b. a -> b -> a
const Exp -> Exp -> ExpPre
ExpoE   (TokenBasic -> Exp -> Exp -> ExpPre)
-> CParser TokenBasic TokenBasic
-> CParser TokenBasic (Exp -> Exp -> ExpPre)
forall (t :: * -> *) a b. Functor t => (a -> b) -> t a -> t b
^$ Text -> CParser TokenBasic TokenBasic
cpSyntax Text
"^"
  , ℕ64
-> CParser TokenBasic (Exp -> ExpPre)
-> MixfixF TokenBasic (𝐴 SrcCxt) ExpPre
forall t (f :: * -> *) a.
ℕ64 -> CParser t (f a -> a) -> MixfixF t f a
fmixPostfix ℕ64
pFAC   (CParser TokenBasic (Exp -> ExpPre)
 -> MixfixF TokenBasic (𝐴 SrcCxt) ExpPre)
-> CParser TokenBasic (Exp -> ExpPre)
-> MixfixF TokenBasic (𝐴 SrcCxt) ExpPre
forall a b. (a -> b) -> a -> b
$ (Exp -> ExpPre) -> TokenBasic -> Exp -> ExpPre
forall a b. a -> b -> a
const Exp -> ExpPre
FactE   (TokenBasic -> Exp -> ExpPre)
-> CParser TokenBasic TokenBasic
-> CParser TokenBasic (Exp -> ExpPre)
forall (t :: * -> *) a b. Functor t => (a -> b) -> t a -> t b
^$ Text -> CParser TokenBasic TokenBasic
cpSyntax Text
"!"
  ]

testParserSuccess ∷ IO ()
testParserSuccess :: IO ()
testParserSuccess = do
  CParser TokenBasic Exp
-> Text -> 𝕍 (ParserToken TokenBasic) -> IO ()
forall a t ts.
(Pretty a, ToIter (ParserToken t) ts, Ord t) =>
CParser t a -> Text -> ts -> IO ()
parseIOMain CParser TokenBasic Exp
cpExp Text
"" (𝕍 (ParserToken TokenBasic) -> IO ())
-> IO (𝕍 (ParserToken TokenBasic)) -> IO ()
forall (m :: * -> *) a b. Bind m => (a -> m b) -> m a -> m b
*$ Lexer CharClass ℂ TokenClassBasic ℕ64 TokenBasic
-> Text -> 𝕍 (ParserToken ℂ) -> IO (𝕍 (ParserToken TokenBasic))
forall c t o u w.
(Show u, Ord c, Ord t, Pretty t, Classified c t, Eq o, Eq u,
 Plus u) =>
Lexer c t o u w
-> Text -> 𝕍 (ParserToken t) -> IO (𝕍 (ParserToken w))
tokenizeIO Lexer CharClass ℂ TokenClassBasic ℕ64 TokenBasic
lexer Text
"" (𝕍 (ParserToken ℂ) -> IO (𝕍 (ParserToken TokenBasic)))
-> 𝕍 (ParserToken ℂ) -> IO (𝕍 (ParserToken TokenBasic))
forall a b. (a -> b) -> a -> b
$ Text -> 𝕍 (ParserToken ℂ)
tokens Text
"(- 1) + - 2 + 3 * 4 ^ 5 ^ 6 !"

testParserFailure1 ∷ IO ()
testParserFailure1 :: IO ()
testParserFailure1 = CParser TokenBasic Exp
-> Text -> 𝕍 (ParserToken TokenBasic) -> IO ()
forall a t ts.
(Pretty a, ToIter (ParserToken t) ts, Ord t) =>
CParser t a -> Text -> ts -> IO ()
parseIOMain CParser TokenBasic Exp
cpExp Text
"" (𝕍 (ParserToken TokenBasic) -> IO ())
-> IO (𝕍 (ParserToken TokenBasic)) -> IO ()
forall (m :: * -> *) a b. Bind m => (a -> m b) -> m a -> m b
*$ Lexer CharClass ℂ TokenClassBasic ℕ64 TokenBasic
-> Text -> 𝕍 (ParserToken ℂ) -> IO (𝕍 (ParserToken TokenBasic))
forall c t o u w.
(Show u, Ord c, Ord t, Pretty t, Classified c t, Eq o, Eq u,
 Plus u) =>
Lexer c t o u w
-> Text -> 𝕍 (ParserToken t) -> IO (𝕍 (ParserToken w))
tokenizeIO Lexer CharClass ℂ TokenClassBasic ℕ64 TokenBasic
lexer Text
"" (𝕍 (ParserToken ℂ) -> IO (𝕍 (ParserToken TokenBasic)))
-> 𝕍 (ParserToken ℂ) -> IO (𝕍 (ParserToken TokenBasic))
forall a b. (a -> b) -> a -> b
$ Text -> 𝕍 (ParserToken ℂ)
tokens Text
"((9 == ((- 1))) + 2 + 3 * 4 ^ 5 ^ 6 !))"

testParserFailure2 ∷ IO ()
testParserFailure2 :: IO ()
testParserFailure2 = CParser TokenBasic Exp
-> Text -> 𝕍 (ParserToken TokenBasic) -> IO ()
forall a t ts.
(Pretty a, ToIter (ParserToken t) ts, Ord t) =>
CParser t a -> Text -> ts -> IO ()
parseIOMain CParser TokenBasic Exp
cpExp Text
"" (𝕍 (ParserToken TokenBasic) -> IO ())
-> IO (𝕍 (ParserToken TokenBasic)) -> IO ()
forall (m :: * -> *) a b. Bind m => (a -> m b) -> m a -> m b
*$ Lexer CharClass ℂ TokenClassBasic ℕ64 TokenBasic
-> Text -> 𝕍 (ParserToken ℂ) -> IO (𝕍 (ParserToken TokenBasic))
forall c t o u w.
(Show u, Ord c, Ord t, Pretty t, Classified c t, Eq o, Eq u,
 Plus u) =>
Lexer c t o u w
-> Text -> 𝕍 (ParserToken t) -> IO (𝕍 (ParserToken w))
tokenizeIO Lexer CharClass ℂ TokenClassBasic ℕ64 TokenBasic
lexer Text
"" (𝕍 (ParserToken ℂ) -> IO (𝕍 (ParserToken TokenBasic)))
-> 𝕍 (ParserToken ℂ) -> IO (𝕍 (ParserToken TokenBasic))
forall a b. (a -> b) -> a -> b
$ Text -> 𝕍 (ParserToken ℂ)
tokens Text
"(((((- 1))) + 2 + 3 * 4 ^ 5 ^ ! == 0))"