{-|
Module     : Jaskell.Quote
Copyright  : (c) Owen Bechtel, 2023
License    : MIT
Maintainer : ombspring@gmail.com
Stability  : experimental

The 'jsl' quasiquoter converts Jaskell syntax into Haskell syntax.

A Jaskell expression is a sequence of commands. An command is one of the following:

* A Haskell identifier, optionally preceded by @$@, @#@, @?@, @!@, or @&@. 
  The identifier can be qualified or unqualified, and can be lowercase (function) or uppercase (data constructor).
  It cannot be an operator.

    * An identifier @x@ translates to @x@ if @x@ is a function, and @'Jaskell.push' x@ if @x@ is a data constructor.
    * @$x@ translates to @'Jaskell.liftS' x@. For example, @$reverse@ will reverse the list on top of the stack.
    * @#x@ translates to @'Jaskell.liftS2' x@. For example, @#gcd@ will pop the top two values and push their gcd.
    * @?x@ translates to @'Jaskell.pushM' x@. For example, @?getLine@ will execute 'getLine' and push the result.
    * @!x@ translates to @'Jaskell.popM' x@. For example, @!putStrLn@ will print the string on top of the stack.
    * @&x@ translates to @'Jaskell.liftSM' x@. For example, @&readFile@ will pop a file path and push the contents of that file.
  
* A Haskell operator. 
  This translates to 'Jaskell.liftS2' applied to the operator.

* A list of zero or more expressions, surrounded in square brackets and separated by commas.
  For example, @[ 1, 3, 4 1 + ]@ pushes the list @[ 1, 3, 5 ]@ onto the stack.

* A tuple of two expressions. 
  For example, @( 0, "a" "b" ++ )@ pushes the tuple @( 0, "ab" )@ onto the stack.

* An empty tuple. This translates to @'Jaskell.push' ()@.

* An integer, floating-point, character, or string literal.
  For example, @5@ translates to @'Jaskell.push' 5@.

* A (potentially empty) expression surrounded in curly brackets. 
  This pushes the translation of the expression onto the stack, allowing for higher-order programming.

Jaskell programs can be preceded by zero or more definitions, each of the form @DEF name = expr ;@. 
Definitions can be recursive and even mutually recursive.
-}

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
module Jaskell.Quote 
  ( -- * Quasiquoter
    jsl
    -- * Parser internals
  , NameMode(..), Name(..), Literal(..), Command(..), Expr(..), Program(..)
  , Parser, parseName, parseLiteral, parseCommand, parseExpr, parseProgram
  ) where

import Data.Void (Void)
import Control.Monad (void)
import Data.Char (isAsciiLower, isAsciiUpper, isDigit)
import Data.List.NonEmpty (NonEmpty((:|)))
import Control.Category ((>>>))
import qualified Control.Category as Cat

import qualified Text.Megaparsec as M
import qualified Text.Megaparsec.Char as C
import qualified Text.Megaparsec.Char.Lexer as L

import qualified Language.Haskell.TH as TH
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Language.Haskell.TH.Lib

import qualified Jaskell
import qualified Jaskell.Prelude as Pre

-- | Embed a Jaskell program into Haskell.
jsl :: QuasiQuoter
jsl :: QuasiQuoter
jsl = QuasiQuoter 
  { quoteExp :: [Char] -> Q Exp
quoteExp = [Char] -> Q Exp
quote 
  , quotePat :: [Char] -> Q Pat
quotePat = forall a. HasCallStack => a
undefined 
  , quoteType :: [Char] -> Q Type
quoteType = forall a. HasCallStack => a
undefined
  , quoteDec :: [Char] -> Q [Dec]
quoteDec = forall a. HasCallStack => a
undefined 
  }

data NameMode
  = Bare
  | LiftS  
  | LiftS2 
  | PushM  
  | PopM  
  | LiftSM 
  deriving (NameMode -> NameMode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NameMode -> NameMode -> Bool
$c/= :: NameMode -> NameMode -> Bool
== :: NameMode -> NameMode -> Bool
$c== :: NameMode -> NameMode -> Bool
Eq, Int -> NameMode -> ShowS
[NameMode] -> ShowS
NameMode -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [NameMode] -> ShowS
$cshowList :: [NameMode] -> ShowS
show :: NameMode -> [Char]
$cshow :: NameMode -> [Char]
showsPrec :: Int -> NameMode -> ShowS
$cshowsPrec :: Int -> NameMode -> ShowS
Show)

data Name
  = Fun [String] String
  | Ctor [String] String
  deriving (Name -> Name -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Name -> Name -> Bool
$c/= :: Name -> Name -> Bool
== :: Name -> Name -> Bool
$c== :: Name -> Name -> Bool
Eq, Int -> Name -> ShowS
[Name] -> ShowS
Name -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Name] -> ShowS
$cshowList :: [Name] -> ShowS
show :: Name -> [Char]
$cshow :: Name -> [Char]
showsPrec :: Int -> Name -> ShowS
$cshowsPrec :: Int -> Name -> ShowS
Show)

data Literal
  = Char Char
  | String String
  | Integer Integer
  | Double Double
  | Unit
  deriving (Literal -> Literal -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Literal -> Literal -> Bool
$c/= :: Literal -> Literal -> Bool
== :: Literal -> Literal -> Bool
$c== :: Literal -> Literal -> Bool
Eq, Int -> Literal -> ShowS
[Literal] -> ShowS
Literal -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Literal] -> ShowS
$cshowList :: [Literal] -> ShowS
show :: Literal -> [Char]
$cshow :: Literal -> [Char]
showsPrec :: Int -> Literal -> ShowS
$cshowsPrec :: Int -> Literal -> ShowS
Show)

data Command
  = Name NameMode Name
  | Op String
  | List [Expr]
  | Tup Expr Expr
  | Quote (Maybe Expr)
  | Lit Literal 
  deriving (Command -> Command -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Command -> Command -> Bool
$c/= :: Command -> Command -> Bool
== :: Command -> Command -> Bool
$c== :: Command -> Command -> Bool
Eq, Int -> Command -> ShowS
[Command] -> ShowS
Command -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Command] -> ShowS
$cshowList :: [Command] -> ShowS
show :: Command -> [Char]
$cshow :: Command -> [Char]
showsPrec :: Int -> Command -> ShowS
$cshowsPrec :: Int -> Command -> ShowS
Show)

newtype Expr = Expr (NonEmpty Command)
  deriving (Expr -> Expr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Expr -> Expr -> Bool
$c/= :: Expr -> Expr -> Bool
== :: Expr -> Expr -> Bool
$c== :: Expr -> Expr -> Bool
Eq, Int -> Expr -> ShowS
[Expr] -> ShowS
Expr -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Expr] -> ShowS
$cshowList :: [Expr] -> ShowS
show :: Expr -> [Char]
$cshow :: Expr -> [Char]
showsPrec :: Int -> Expr -> ShowS
$cshowsPrec :: Int -> Expr -> ShowS
Show)

data Program = Program [(String, Expr)] Expr
  deriving (Program -> Program -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Program -> Program -> Bool
$c/= :: Program -> Program -> Bool
== :: Program -> Program -> Bool
$c== :: Program -> Program -> Bool
Eq, Int -> Program -> ShowS
[Program] -> ShowS
Program -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Program] -> ShowS
$cshowList :: [Program] -> ShowS
show :: Program -> [Char]
$cshow :: Program -> [Char]
showsPrec :: Int -> Program -> ShowS
$cshowsPrec :: Int -> Program -> ShowS
Show)

type Parser = M.Parsec Void String

parseNameMode :: Parser NameMode
parseNameMode :: Parser NameMode
parseNameMode = forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
M.choice
  [ NameMode
LiftS forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
M.single Char
'$'
  , NameMode
LiftS2 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
M.single Char
'#'
  , NameMode
PushM forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
M.single Char
'?'
  , NameMode
PopM forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
M.single Char
'!'
  , NameMode
LiftSM forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
M.single Char
'&'
  , forall (m :: * -> *) a. Monad m => a -> m a
return NameMode
Bare
  ]

isNameChar :: Char -> Bool
isNameChar :: Char -> Bool
isNameChar Char
c = Char -> Bool
isAsciiLower Char
c Bool -> Bool -> Bool
|| Char -> Bool
isAsciiUpper Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
"'_"

lowerName :: Parser String
lowerName :: Parser [Char]
lowerName = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
M.satisfy Char -> Bool
isAsciiLower forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
M.takeWhileP (forall a. a -> Maybe a
Just [Char]
"identifier charachter") Char -> Bool
isNameChar

upperName :: Parser String
upperName :: Parser [Char]
upperName = do
  forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
M.notFollowedBy (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
M.chunk [Char]
"DEF" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
M.notFollowedBy (forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
M.satisfy Char -> Bool
isNameChar))
  (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
M.satisfy Char -> Bool
isAsciiUpper forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
M.takeWhileP (forall a. a -> Maybe a
Just [Char]
"identifier charachter") Char -> Bool
isNameChar

parseName :: Parser Name
parseName :: Parser Name
parseName = Name -> Name
reverseModules forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Char]] -> Parser Name
parseName' []
  where
    parseName' :: [[Char]] -> Parser Name
parseName' [[Char]]
modules = forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
M.choice
      [ [[Char]] -> [Char] -> Name
Fun [[Char]]
modules forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [Char]
lowerName
      , do [Char]
m <- Parser [Char]
upperName
           forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
M.choice 
             [ forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
M.single Char
'.' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [[Char]] -> Parser Name
parseName' ([Char]
m forall a. a -> [a] -> [a]
: [[Char]]
modules)
             , forall (m :: * -> *) a. Monad m => a -> m a
return ([[Char]] -> [Char] -> Name
Ctor [[Char]]
modules [Char]
m)
             ]
      ]
    
    reverseModules :: Name -> Name
reverseModules = \case
      Fun [[Char]]
ms [Char]
n -> [[Char]] -> [Char] -> Name
Fun (forall a. [a] -> [a]
reverse [[Char]]
ms) [Char]
n
      Ctor [[Char]]
ms [Char]
n -> [[Char]] -> [Char] -> Name
Ctor (forall a. [a] -> [a]
reverse [[Char]]
ms) [Char]
n

isOpChar :: Char -> Bool
isOpChar :: Char -> Bool
isOpChar Char
c = Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
"!#$%&*+./<=>?@\\^|-~:"

parseOp :: Parser String
parseOp :: Parser [Char]
parseOp = do
  forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
M.notFollowedBy forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
M.choice
    [ forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
M.single Char
'-' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
M.satisfy Char -> Bool
isDigit)
    , forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
M.single Char
'=' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
M.notFollowedBy (forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
M.satisfy Char -> Bool
isOpChar)
    ]
  forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
M.takeWhile1P (forall a. a -> Maybe a
Just [Char]
"operator character") Char -> Bool
isOpChar

parseLiteral :: Parser Literal
parseLiteral :: Parser Literal
parseLiteral = forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
M.choice
  [ Char -> Literal
Char forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
M.single Char
'\'' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Char
L.charLiteral forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
M.single Char
'\''
  , [Char] -> Literal
String forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
M.single Char
'"' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
M.manyTill forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Char
L.charLiteral (forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
M.single Char
'"')
  , forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
M.try (Double -> Literal
Double forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, RealFloat a) =>
m a
L.float)
  , Integer -> Literal
Integer forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal
  , Parser Literal
negative
  , Literal
Unit forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
M.chunk [Char]
"()"
  ]
  where
    negative :: Parser Literal
negative = do
      Token [Char]
_ <- forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
M.single Char
'-'
      forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
M.choice
        [ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
M.try (Double -> Literal
Double forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a
negate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, RealFloat a) =>
m a
L.float)
        , Integer -> Literal
Integer forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a
negate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal
        ]

spaces :: Parser ()
spaces :: ParsecT Void [Char] Identity ()
spaces = forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
C.space1
  (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> m ()
L.skipLineComment [Char]
"--")
  (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> Tokens s -> m ()
L.skipBlockCommentNested [Char]
"{-" [Char]
"-}")

symbol :: Char -> Parser ()
symbol :: Char -> ParsecT Void [Char] Identity ()
symbol Char
c = forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
M.single Char
c forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT Void [Char] Identity ()
spaces

parseList :: Parser Command
parseList :: Parser Command
parseList = [Expr] -> Command
List forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT Void [Char] Identity ()
symbol Char
'[' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
M.sepBy Parser Expr
parseExpr (Char -> ParsecT Void [Char] Identity ()
symbol Char
',') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ParsecT Void [Char] Identity ()
symbol Char
']'

parseTup :: Parser Command
parseTup :: Parser Command
parseTup = do
  forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
M.notFollowedBy (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
M.chunk [Char]
"()")
  Expr -> Expr -> Command
Tup forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT Void [Char] Identity ()
symbol Char
'(' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Expr
parseExpr forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ParsecT Void [Char] Identity ()
symbol Char
',' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Expr
parseExpr forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ParsecT Void [Char] Identity ()
symbol Char
')'

parseCommand :: Parser Command
parseCommand :: Parser Command
parseCommand = forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
M.choice
  [ NameMode -> Name -> Command
Name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser NameMode
parseNameMode forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Name
parseName forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void [Char] Identity ()
spaces
  , [Char] -> Command
Op forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [Char]
parseOp forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void [Char] Identity ()
spaces
  , Parser Command
parseList 
  , Parser Command
parseTup 
  , Maybe Expr -> Command
Quote forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT Void [Char] Identity ()
symbol Char
'{' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
M.optional Parser Expr
parseExpr forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ParsecT Void [Char] Identity ()
symbol Char
'}'
  , Literal -> Command
Lit forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Literal
parseLiteral forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void [Char] Identity ()
spaces
  ]

parseExpr :: Parser Expr
parseExpr :: Parser Expr
parseExpr = do
  NonEmpty Command
cmds <- forall a. a -> [a] -> NonEmpty a
(:|) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Command
parseCommand forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
M.many Parser Command
parseCommand
  forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty Command -> Expr
Expr NonEmpty Command
cmds)

parseDef :: Parser (String, Expr)
parseDef :: Parser ([Char], Expr)
parseDef = (,) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
M.chunk [Char]
"DEF" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void [Char] Identity ()
spaces forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [Char]
lowerName forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void [Char] Identity ()
spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ParsecT Void [Char] Identity ()
symbol Char
'=' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Expr
parseExpr forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ParsecT Void [Char] Identity ()
symbol Char
';'

parseProgram :: Parser Program
parseProgram :: Parser Program
parseProgram = [([Char], Expr)] -> Expr -> Program
Program forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
M.many Parser ([Char], Expr)
parseDef forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Expr
parseExpr

initialState :: s -> M.SourcePos -> M.State s Void 
initialState :: forall s. s -> SourcePos -> State s Void
initialState s
input SourcePos
pos = 
  M.State
    { stateInput :: s
M.stateInput = s
input
    , stateOffset :: Int
M.stateOffset = Int
0
    , statePosState :: PosState s
M.statePosState = 
        M.PosState
          { pstateInput :: s
M.pstateInput = s
input
          , pstateOffset :: Int
M.pstateOffset = Int
0
          , pstateSourcePos :: SourcePos
M.pstateSourcePos = SourcePos
pos
          , pstateTabWidth :: Pos
M.pstateTabWidth = Pos
M.defaultTabWidth
          , pstateLinePrefix :: [Char]
M.pstateLinePrefix = [Char]
""
          }
      , stateParseErrors :: [ParseError s Void]
M.stateParseErrors = []
    }

quote :: String -> ExpQ
quote :: [Char] -> Q Exp
quote [Char]
input = do
  Loc
loc <- Q Loc
TH.location
  let file :: [Char]
file = Loc -> [Char]
TH.loc_filename Loc
loc
      (Int
line, Int
col) = Loc -> (Int, Int)
TH.loc_start Loc
loc
      state :: State [Char] Void
state = forall s. s -> SourcePos -> State s Void
initialState [Char]
input ([Char] -> Pos -> Pos -> SourcePos
M.SourcePos [Char]
file (Int -> Pos
M.mkPos Int
line) (Int -> Pos
M.mkPos Int
col)) 
      parse :: Parser Program
parse = ParsecT Void [Char] Identity ()
spaces forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Parser Program
parseProgram forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
M.eof)

  case forall a b. (a, b) -> b
snd (forall e s a.
Parsec e s a
-> State s e -> (State s e, Either (ParseErrorBundle s e) a)
M.runParser' Parser Program
parse State [Char] Void
state) of 
    Left ParseErrorBundle [Char] Void
errors -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail (forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> [Char]
M.errorBundlePretty ParseErrorBundle [Char] Void
errors)
    Right Program
prog -> Program -> Q Exp
convertProgram Program
prog

comp :: Foldable t => t ExpQ -> ExpQ
comp :: forall (t :: * -> *). Foldable t => t (Q Exp) -> Q Exp
comp = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Q Exp
f Q Exp
g -> forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE (forall a. a -> Maybe a
Just Q Exp
f) (forall (m :: * -> *). Quote m => Name -> m Exp
varE '(>>>)) (forall a. a -> Maybe a
Just Q Exp
g))

convertName :: Name -> ExpQ
convertName :: Name -> Q Exp
convertName = \case
  Fun [[Char]]
ms [Char]
n -> forall (m :: * -> *). Quote m => Name -> m Exp
varE ([Char] -> Name
TH.mkName (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. [a] -> [a] -> [a]
++ [Char]
".") [[Char]]
ms forall a. [a] -> [a] -> [a]
++ [Char]
n))
  Ctor [[Char]]
ms [Char]
n -> forall (m :: * -> *). Quote m => Name -> m Exp
conE ([Char] -> Name
TH.mkName (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. [a] -> [a] -> [a]
++ [Char]
".") [[Char]]
ms forall a. [a] -> [a] -> [a]
++ [Char]
n))

convertLiteral :: Literal -> ExpQ
convertLiteral :: Literal -> Q Exp
convertLiteral = \case
  Char Char
c -> forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Char -> Lit
charL Char
c)
  String [Char]
s -> forall (m :: * -> *). Quote m => Lit -> m Exp
litE ([Char] -> Lit
stringL [Char]
s)
  Integer Integer
i -> forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Integer -> Lit
integerL Integer
i)
  Double Double
r -> forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Rational -> Lit
rationalL (forall a. Real a => a -> Rational
toRational Double
r))
  Literal
Unit -> forall (m :: * -> *). Quote m => [m Exp] -> m Exp
tupE []

convertCommand :: Command -> ExpQ
convertCommand :: Command -> Q Exp
convertCommand = \case
  Name NameMode
mode Name
n -> 
    let nexp :: Q Exp
nexp = Name -> Q Exp
convertName Name
n in
    case NameMode
mode of
      NameMode
Bare -> case Name
n of
        Fun [[Char]]
_ [Char]
_ -> Q Exp
nexp
        Ctor [[Char]]
_ [Char]
_ -> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'Jaskell.push) Q Exp
nexp
      NameMode
LiftS -> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'Jaskell.liftS) Q Exp
nexp
      NameMode
LiftS2 -> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'Jaskell.liftS2) Q Exp
nexp
      NameMode
PushM -> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'Jaskell.pushM) Q Exp
nexp
      NameMode
PopM -> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'Jaskell.popM) Q Exp
nexp
      NameMode
LiftSM -> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'Jaskell.liftSM) Q Exp
nexp
  
  Op [Char]
op -> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'Jaskell.liftS2) (forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE forall a. Maybe a
Nothing (forall (m :: * -> *). Quote m => Name -> m Exp
varE ([Char] -> Name
TH.mkName [Char]
op)) forall a. Maybe a
Nothing)
  
  List [Expr]
xs -> forall (t :: * -> *). Foldable t => t (Q Exp) -> Q Exp
comp forall a b. (a -> b) -> a -> b
$ 
    forall a b. (a -> b) -> [a] -> [b]
map Expr -> Q Exp
convertExpr [Expr]
xs
    forall a. [a] -> [a] -> [a]
++ [ forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'Jaskell.push) (forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE []) ]
    forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr]
xs) (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'Pre.cons)
  
  Tup Expr
x1 Expr
x2 -> forall (t :: * -> *). Foldable t => t (Q Exp) -> Q Exp
comp [ Expr -> Q Exp
convertExpr Expr
x1, Expr -> Q Exp
convertExpr Expr
x2, forall (m :: * -> *). Quote m => Name -> m Exp
varE 'Pre.pair ]
  
  Quote Maybe Expr
x -> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'Jaskell.push) (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'Cat.id) Expr -> Q Exp
convertExpr Maybe Expr
x)
  
  Lit Literal
lit -> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'Jaskell.push) (Literal -> Q Exp
convertLiteral Literal
lit)

convertExpr :: Expr -> ExpQ
convertExpr :: Expr -> Q Exp
convertExpr (Expr NonEmpty Command
xs) = forall (t :: * -> *). Foldable t => t (Q Exp) -> Q Exp
comp (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Command -> Q Exp
convertCommand NonEmpty Command
xs)

convertDef :: (String, Expr) -> DecQ
convertDef :: ([Char], Expr) -> DecQ
convertDef ([Char]
n, Expr
x) = forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ([Char] -> Name
TH.mkName [Char]
n) [ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Expr -> Q Exp
convertExpr Expr
x)) [] ]

convertProgram :: Program -> ExpQ
convertProgram :: Program -> Q Exp
convertProgram (Program [([Char], Expr)]
defs Expr
x) = 
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [([Char], Expr)]
defs 
    then Expr -> Q Exp
convertExpr Expr
x
    else forall (m :: * -> *). Quote m => [m Dec] -> m Exp -> m Exp
letE (forall a b. (a -> b) -> [a] -> [b]
map ([Char], Expr) -> DecQ
convertDef [([Char], Expr)]
defs) (Expr -> Q Exp
convertExpr Expr
x)