module Language.Egison.Parser.Pattern.Mode.Haskell.TH
(
Expr
, ExprL
, ParseMode(..)
, parseExpr
, parseExprL
, makeParseMode
, makeFixity
, makeParseFixity
)
where
import Control.Monad.Except ( MonadError )
import qualified Text.PrettyPrint as PP
( render )
import qualified Language.Haskell.TH.Syntax as TH
( Name
, Exp(..)
, NameIs(..)
)
import qualified Language.Haskell.TH.PprLib as TH
( to_HPJ_Doc
, pprName'
)
import qualified Language.Haskell.Meta.Syntax.Translate
as TH
( toExp
, toName
)
import qualified Language.Haskell.Exts.Fixity as Haskell
( Fixity(..) )
import qualified Language.Haskell.Exts.Syntax as Haskell
( Assoc(..) )
import qualified Language.Haskell.Exts.Parser as Haskell
( ParseMode(..)
, ParseResult(..)
, parseExpWithMode
)
import qualified Language.Egison.Syntax.Pattern
as Egison
( Expr )
import qualified Language.Egison.Parser.Pattern
as Egison
( ExprL
, Fixity(..)
, Associativity(..)
, ParseFixity(..)
, ParseMode(..)
)
import Language.Egison.Parser.Pattern ( Precedence(..)
, Parsable(..)
, Errors
)
type Expr = Egison.Expr TH.Name TH.Name TH.Exp
type ExprL = Egison.ExprL TH.Name TH.Name TH.Exp
data ParseMode
= ParseMode {
ParseMode -> ParseMode
haskellMode :: Haskell.ParseMode
, ParseMode -> Maybe [ParseFixity Name String]
fixities :: Maybe [Egison.ParseFixity TH.Name String]
}
resultToEither :: Haskell.ParseResult a -> Either String a
resultToEither :: ParseResult a -> Either String a
resultToEither (Haskell.ParseOk a
a ) = a -> Either String a
forall a b. b -> Either a b
Right a
a
resultToEither (Haskell.ParseFailed SrcLoc
_ String
e) = String -> Either String a
forall a b. a -> Either a b
Left String
e
parseNameWithMode :: Haskell.ParseMode -> String -> Either String TH.Name
parseNameWithMode :: ParseMode -> String -> Either String Name
parseNameWithMode ParseMode
mode String
content =
case ParseResult Exp -> Either String Exp
forall a. ParseResult a -> Either String a
resultToEither (ParseResult Exp -> Either String Exp)
-> (ParseResult (Exp SrcSpanInfo) -> ParseResult Exp)
-> ParseResult (Exp SrcSpanInfo)
-> Either String Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp SrcSpanInfo -> Exp)
-> ParseResult (Exp SrcSpanInfo) -> ParseResult Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp SrcSpanInfo -> Exp
forall a. ToExp a => a -> Exp
TH.toExp (ParseResult (Exp SrcSpanInfo) -> Either String Exp)
-> ParseResult (Exp SrcSpanInfo) -> Either String Exp
forall a b. (a -> b) -> a -> b
$ ParseMode -> String -> ParseResult (Exp SrcSpanInfo)
Haskell.parseExpWithMode ParseMode
mode String
content of
Right (TH.VarE Name
name) -> Name -> Either String Name
forall a b. b -> Either a b
Right Name
name
Right (TH.ConE Name
name) -> Name -> Either String Name
forall a b. b -> Either a b
Right Name
name
Right Exp
e -> String -> Either String Name
forall a b. a -> Either a b
Left (Exp -> String
forall a. Show a => a -> String
show Exp
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not a variable")
Left String
err -> String -> Either String Name
forall a b. a -> Either a b
Left String
err
makeFixity :: Haskell.Fixity -> Egison.Fixity TH.Name
makeFixity :: Fixity -> Fixity Name
makeFixity (Haskell.Fixity Assoc ()
assoc Int
prec QName ()
name) = Fixity Name
fixity
where
fixity :: Fixity Name
fixity = Associativity -> Precedence -> Name -> Fixity Name
forall n. Associativity -> Precedence -> n -> Fixity n
Egison.Fixity (Assoc () -> Associativity
makeAssoc Assoc ()
assoc) (Int -> Precedence
Precedence Int
prec) (Name -> Fixity Name) -> Name -> Fixity Name
forall a b. (a -> b) -> a -> b
$ QName () -> Name
forall a. ToName a => a -> Name
TH.toName QName ()
name
makeAssoc :: Assoc () -> Associativity
makeAssoc (Haskell.AssocRight ()) = Associativity
Egison.AssocRight
makeAssoc (Haskell.AssocLeft ()) = Associativity
Egison.AssocLeft
makeAssoc (Haskell.AssocNone ()) = Associativity
Egison.AssocNone
makeParseFixity :: Egison.Fixity TH.Name -> Egison.ParseFixity TH.Name String
makeParseFixity :: Fixity Name -> ParseFixity Name String
makeParseFixity Fixity Name
fixity = Fixity Name -> ExtParser String () -> ParseFixity Name String
forall n s. Fixity n -> ExtParser s () -> ParseFixity n s
Egison.ParseFixity Fixity Name
fixity (ExtParser String () -> ParseFixity Name String)
-> ExtParser String () -> ParseFixity Name String
forall a b. (a -> b) -> a -> b
$ Name -> String -> Either String ()
makeNameParser Name
symbol
where
Egison.Fixity { Name
$sel:symbol:Fixity :: forall n. Fixity n -> n
symbol :: Name
Egison.symbol } = Fixity Name
fixity
printSym :: Name -> String
printSym = Doc -> String
PP.render (Doc -> String) -> (Name -> Doc) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
TH.to_HPJ_Doc (Doc -> Doc) -> (Name -> Doc) -> Name -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameIs -> Name -> Doc
TH.pprName' NameIs
TH.Infix
makeNameParser :: Name -> String -> Either String ()
makeNameParser Name
s String
input | String
input String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> String
printSym Name
s = () -> Either String ()
forall a b. b -> Either a b
Right ()
| Bool
otherwise = String -> Either String ()
forall a b. a -> Either a b
Left String
"not an operator name"
makeParseMode
:: Haskell.ParseMode -> Egison.ParseMode TH.Name TH.Name TH.Exp String
makeParseMode :: ParseMode -> ParseMode Name Name Exp String
makeParseMode mode :: ParseMode
mode@Haskell.ParseMode { String
parseFilename :: ParseMode -> String
parseFilename :: String
Haskell.parseFilename, Maybe [Fixity]
fixities :: ParseMode -> Maybe [Fixity]
fixities :: Maybe [Fixity]
Haskell.fixities }
= ParseMode :: forall n v e s.
String
-> [ParseFixity n s]
-> Maybe (Tokens s, Tokens s)
-> Maybe (Tokens s)
-> ExtParser s v
-> ExtParser s n
-> ExtParser s e
-> ParseMode n v e s
Egison.ParseMode
{ $sel:filename:ParseMode :: String
Egison.filename = String
parseFilename
, $sel:fixities:ParseMode :: [ParseFixity Name String]
Egison.fixities = [ParseFixity Name String]
-> ([Fixity] -> [ParseFixity Name String])
-> Maybe [Fixity]
-> [ParseFixity Name String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [Fixity] -> [ParseFixity Name String]
makeParseFixities Maybe [Fixity]
fixities
, $sel:blockComment:ParseMode :: Maybe (Tokens String, Tokens String)
Egison.blockComment = (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String
"{-", String
"-}")
, $sel:lineComment:ParseMode :: Maybe (Tokens String)
Egison.lineComment = String -> Maybe String
forall a. a -> Maybe a
Just String
"--"
, $sel:varNameParser:ParseMode :: ExtParser String Name
Egison.varNameParser = ParseMode -> String -> Either String Name
parseNameWithMode ParseMode
mode
, $sel:nameParser:ParseMode :: ExtParser String Name
Egison.nameParser = ParseMode -> String -> Either String Name
parseNameWithMode ParseMode
mode
, $sel:valueExprParser:ParseMode :: ExtParser String Exp
Egison.valueExprParser = ParseResult Exp -> Either String Exp
forall a. ParseResult a -> Either String a
resultToEither
(ParseResult Exp -> Either String Exp)
-> (String -> ParseResult Exp) -> String -> Either String Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp SrcSpanInfo -> Exp)
-> ParseResult (Exp SrcSpanInfo) -> ParseResult Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp SrcSpanInfo -> Exp
forall a. ToExp a => a -> Exp
TH.toExp
(ParseResult (Exp SrcSpanInfo) -> ParseResult Exp)
-> (String -> ParseResult (Exp SrcSpanInfo))
-> String
-> ParseResult Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseMode -> String -> ParseResult (Exp SrcSpanInfo)
Haskell.parseExpWithMode ParseMode
mode
}
where
makeParseFixities :: [Haskell.Fixity] -> [Egison.ParseFixity TH.Name String]
makeParseFixities :: [Fixity] -> [ParseFixity Name String]
makeParseFixities = (Fixity -> ParseFixity Name String)
-> [Fixity] -> [ParseFixity Name String]
forall a b. (a -> b) -> [a] -> [b]
map ((Fixity -> ParseFixity Name String)
-> [Fixity] -> [ParseFixity Name String])
-> (Fixity -> ParseFixity Name String)
-> [Fixity]
-> [ParseFixity Name String]
forall a b. (a -> b) -> a -> b
$ Fixity Name -> ParseFixity Name String
makeParseFixity (Fixity Name -> ParseFixity Name String)
-> (Fixity -> Fixity Name) -> Fixity -> ParseFixity Name String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fixity -> Fixity Name
makeFixity
instance Parsable Expr String ParseMode where
parseNonGreedyWithLocation :: ParseMode -> String -> m (Cofree (Base Expr) Location, String)
parseNonGreedyWithLocation ParseMode { ParseMode
haskellMode :: ParseMode
haskellMode :: ParseMode -> ParseMode
haskellMode, Maybe [ParseFixity Name String]
fixities :: Maybe [ParseFixity Name String]
fixities :: ParseMode -> Maybe [ParseFixity Name String]
fixities } =
ParseMode Name Name Exp String
-> String -> m (Cofree (Base Expr) Location, String)
forall a s mode (m :: * -> *).
(Parsable a s mode, MonadError (Errors s) m) =>
mode -> s -> m (Cofree (Base a) Location, s)
parseNonGreedyWithLocation @Expr ParseMode Name Name Exp String
mode'
where
mode :: ParseMode Name Name Exp String
mode = ParseMode -> ParseMode Name Name Exp String
makeParseMode ParseMode
haskellMode
mode' :: ParseMode Name Name Exp String
mode' = case Maybe [ParseFixity Name String]
fixities of
Just [ParseFixity Name String]
xs -> ParseMode Name Name Exp String
mode { $sel:fixities:ParseMode :: [ParseFixity Name String]
Egison.fixities = [ParseFixity Name String]
xs }
Maybe [ParseFixity Name String]
Nothing -> ParseMode Name Name Exp String
mode
parseExpr :: MonadError (Errors String) m => ParseMode -> String -> m Expr
parseExpr :: ParseMode -> String -> m Expr
parseExpr = forall s mode (m :: * -> *).
(Parsable Expr s mode, MonadError (Errors s) m) =>
mode -> s -> m Expr
forall a s mode (m :: * -> *).
(Parsable a s mode, MonadError (Errors s) m) =>
mode -> s -> m a
parse @Expr
parseExprL :: MonadError (Errors String) m => ParseMode -> String -> m ExprL
parseExprL :: ParseMode -> String -> m ExprL
parseExprL = forall s mode (m :: * -> *).
(Parsable Expr s mode, MonadError (Errors s) m) =>
mode -> s -> m (Cofree (Base Expr) Location)
forall a s mode (m :: * -> *).
(Parsable a s mode, MonadError (Errors s) m) =>
mode -> s -> m (Cofree (Base a) Location)
parseWithLocation @Expr