{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
module Jaskell.Quote
(
jsl
, 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
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)