module Language.Egison.Parser.Pattern.Mode.Haskell
(
Expr
, ExprL
, ParseMode(..)
, parseExpr
, parseExprL
, makeParseMode
, makeFixity
, makeParseFixity
)
where
import Data.Char ( isUpper )
import Data.Maybe ( mapMaybe )
import Data.Functor ( void )
import Control.Monad.Except ( MonadError )
import Language.Haskell.Exts.Syntax ( QName(..)
, QOp(..)
, Exp(..)
, Name(..)
, Exp
)
import Language.Haskell.Exts.SrcLoc ( SrcSpanInfo )
import qualified Language.Haskell.Exts.Fixity as Haskell
( Fixity(..) )
import qualified Language.Haskell.Exts.Syntax as Haskell
( Assoc(..) )
import qualified Language.Haskell.Exts.Pretty as Haskell
( prettyPrint )
import qualified Language.Haskell.Exts.Parser as Haskell
( parseExpWithMode
, ParseMode(..)
, ParseResult(..)
)
import qualified Language.Egison.Syntax.Pattern
as Egison
( Expr )
import qualified Language.Egison.Parser.Pattern
as Egison
( ExprL
, ParseMode(..)
, ParseFixity(..)
, Fixity(..)
, Associativity(..)
)
import Language.Egison.Parser.Pattern ( Precedence(..)
, Parsable(..)
, Errors
)
type Expr = Egison.Expr (QName ()) (Name ()) (Exp SrcSpanInfo)
type ExprL = Egison.ExprL (QName ()) (Name ()) (Exp SrcSpanInfo)
data ParseMode
= ParseMode {
ParseMode -> ParseMode
haskellMode :: Haskell.ParseMode
, ParseMode -> Maybe [ParseFixity (QName ()) String]
fixities :: Maybe [Egison.ParseFixity (QName ()) 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
parseVarNameWithMode :: Haskell.ParseMode -> String -> Either String (Name ())
parseVarNameWithMode :: ParseMode -> String -> Either String (Name ())
parseVarNameWithMode ParseMode
mode String
content =
case ParseResult (Exp SrcSpanInfo) -> Either String (Exp SrcSpanInfo)
forall a. ParseResult a -> Either String a
resultToEither (ParseResult (Exp SrcSpanInfo) -> Either String (Exp SrcSpanInfo))
-> ParseResult (Exp SrcSpanInfo) -> Either String (Exp SrcSpanInfo)
forall a b. (a -> b) -> a -> b
$ ParseMode -> String -> ParseResult (Exp SrcSpanInfo)
Haskell.parseExpWithMode ParseMode
mode String
content of
Right (Var SrcSpanInfo
_ (UnQual SrcSpanInfo
_ Name SrcSpanInfo
name)) -> Name () -> Either String (Name ())
forall a b. b -> Either a b
Right (Name () -> Either String (Name ()))
-> Name () -> Either String (Name ())
forall a b. (a -> b) -> a -> b
$ Name SrcSpanInfo -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Name SrcSpanInfo
name
Right Exp SrcSpanInfo
e -> String -> Either String (Name ())
forall a b. a -> Either a b
Left (Exp SrcSpanInfo -> String
forall a. Show a => a -> String
show Exp SrcSpanInfo
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
parseNameWithMode :: Haskell.ParseMode -> String -> Either String (QName ())
parseNameWithMode :: ParseMode -> String -> Either String (QName ())
parseNameWithMode ParseMode
mode String
content =
case ParseResult (Exp SrcSpanInfo) -> Either String (Exp SrcSpanInfo)
forall a. ParseResult a -> Either String a
resultToEither (ParseResult (Exp SrcSpanInfo) -> Either String (Exp SrcSpanInfo))
-> ParseResult (Exp SrcSpanInfo) -> Either String (Exp SrcSpanInfo)
forall a b. (a -> b) -> a -> b
$ ParseMode -> String -> ParseResult (Exp SrcSpanInfo)
Haskell.parseExpWithMode ParseMode
mode String
content of
Right (Var SrcSpanInfo
_ QName SrcSpanInfo
name) -> QName () -> Either String (QName ())
forall a b. b -> Either a b
Right (QName () -> Either String (QName ()))
-> QName () -> Either String (QName ())
forall a b. (a -> b) -> a -> b
$ QName SrcSpanInfo -> QName ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void QName SrcSpanInfo
name
Right (Con SrcSpanInfo
_ QName SrcSpanInfo
name) -> QName () -> Either String (QName ())
forall a b. b -> Either a b
Right (QName () -> Either String (QName ()))
-> QName () -> Either String (QName ())
forall a b. (a -> b) -> a -> b
$ QName SrcSpanInfo -> QName ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void QName SrcSpanInfo
name
Right Exp SrcSpanInfo
e -> String -> Either String (QName ())
forall a b. a -> Either a b
Left (Exp SrcSpanInfo -> String
forall a. Show a => a -> String
show Exp SrcSpanInfo
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not a name")
Left String
err -> String -> Either String (QName ())
forall a b. a -> Either a b
Left String
err
makeFixity :: Haskell.Fixity -> Egison.Fixity (QName ())
makeFixity :: Fixity -> Fixity (QName ())
makeFixity (Haskell.Fixity Assoc ()
assoc Int
prec QName ()
name) = Fixity (QName ())
fixity
where
fixity :: Fixity (QName ())
fixity = Associativity -> Precedence -> QName () -> Fixity (QName ())
forall n. Associativity -> Precedence -> n -> Fixity n
Egison.Fixity (Assoc () -> Associativity
makeAssoc Assoc ()
assoc) (Int -> Precedence
Precedence Int
prec) 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 (QName ()) -> Maybe (Egison.ParseFixity (QName ()) String)
makeParseFixity :: Fixity (QName ()) -> Maybe (ParseFixity (QName ()) String)
makeParseFixity Fixity (QName ())
fixity = Fixity (QName ())
-> ExtParser String () -> ParseFixity (QName ()) String
forall n s. Fixity n -> ExtParser s () -> ParseFixity n s
Egison.ParseFixity Fixity (QName ())
fixity ((String -> Either String ()) -> ParseFixity (QName ()) String)
-> Maybe (String -> Either String ())
-> Maybe (ParseFixity (QName ()) String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName () -> Maybe (String -> Either String ())
makeNameParser QName ()
symbol
where
Egison.Fixity { QName ()
$sel:symbol:Fixity :: forall n. Fixity n -> n
symbol :: QName ()
Egison.symbol } = Fixity (QName ())
fixity
makeNameParser :: QName () -> Maybe (String -> Either String ())
makeNameParser q :: QName ()
q@(Qual () ModuleName ()
_ Name ()
name) = (String -> Either String ()) -> Maybe (String -> Either String ())
forall a. a -> Maybe a
Just ((String -> Either String ())
-> Maybe (String -> Either String ()))
-> (String -> Either String ())
-> Maybe (String -> Either String ())
forall a b. (a -> b) -> a -> b
$ QName () -> Name () -> String -> Either String ()
pparser QName ()
q Name ()
name
makeNameParser q :: QName ()
q@(UnQual () Name ()
name) = (String -> Either String ()) -> Maybe (String -> Either String ())
forall a. a -> Maybe a
Just ((String -> Either String ())
-> Maybe (String -> Either String ()))
-> (String -> Either String ())
-> Maybe (String -> Either String ())
forall a b. (a -> b) -> a -> b
$ QName () -> Name () -> String -> Either String ()
pparser QName ()
q Name ()
name
makeNameParser QName ()
_ = Maybe (String -> Either String ())
forall a. Maybe a
Nothing
pparser :: QName () -> Name () -> String -> Either String ()
pparser QName ()
q Name ()
name String
input | String
input String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== QName () -> Name () -> String
printName QName ()
q Name ()
name = () -> 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"
printName :: QName () -> Name () -> String
printName QName ()
q Name ()
name | Name () -> Bool
isCon Name ()
name = QOp () -> String
forall a. Pretty a => a -> String
Haskell.prettyPrint (QOp () -> String) -> QOp () -> String
forall a b. (a -> b) -> a -> b
$ () -> QName () -> QOp ()
forall l. l -> QName l -> QOp l
QConOp () QName ()
q
| Bool
otherwise = QOp () -> String
forall a. Pretty a => a -> String
Haskell.prettyPrint (QOp () -> String) -> QOp () -> String
forall a b. (a -> b) -> a -> b
$ () -> QName () -> QOp ()
forall l. l -> QName l -> QOp l
QVarOp () QName ()
q
isCon :: Name () -> Bool
isCon (Ident () (Char
c : String
_)) = Char -> Bool
isUpper Char
c
isCon (Symbol () (Char
':' : String
_)) = Bool
True
isCon Name ()
_ = Bool
False
makeParseMode
:: Haskell.ParseMode
-> Egison.ParseMode (QName ()) (Name ()) (Exp SrcSpanInfo) String
makeParseMode :: ParseMode
-> ParseMode (QName ()) (Name ()) (Exp SrcSpanInfo) 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 (QName ()) String]
Egison.fixities = [ParseFixity (QName ()) String]
-> ([Fixity] -> [ParseFixity (QName ()) String])
-> Maybe [Fixity]
-> [ParseFixity (QName ()) String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [Fixity] -> [ParseFixity (QName ()) 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 ())
parseVarNameWithMode ParseMode
mode
, $sel:nameParser:ParseMode :: ExtParser String (QName ())
Egison.nameParser = ParseMode -> String -> Either String (QName ())
parseNameWithMode ParseMode
mode
, $sel:valueExprParser:ParseMode :: ExtParser String (Exp SrcSpanInfo)
Egison.valueExprParser = ParseResult (Exp SrcSpanInfo) -> Either String (Exp SrcSpanInfo)
forall a. ParseResult a -> Either String a
resultToEither (ParseResult (Exp SrcSpanInfo) -> Either String (Exp SrcSpanInfo))
-> (String -> ParseResult (Exp SrcSpanInfo))
-> String
-> Either String (Exp SrcSpanInfo)
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 (QName ()) String]
makeParseFixities :: [Fixity] -> [ParseFixity (QName ()) String]
makeParseFixities = (Fixity -> Maybe (ParseFixity (QName ()) String))
-> [Fixity] -> [ParseFixity (QName ()) String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Fixity -> Maybe (ParseFixity (QName ()) String))
-> [Fixity] -> [ParseFixity (QName ()) String])
-> (Fixity -> Maybe (ParseFixity (QName ()) String))
-> [Fixity]
-> [ParseFixity (QName ()) String]
forall a b. (a -> b) -> a -> b
$ Fixity (QName ()) -> Maybe (ParseFixity (QName ()) String)
makeParseFixity (Fixity (QName ()) -> Maybe (ParseFixity (QName ()) String))
-> (Fixity -> Fixity (QName ()))
-> Fixity
-> Maybe (ParseFixity (QName ()) String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fixity -> Fixity (QName ())
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 (QName ()) String]
fixities :: Maybe [ParseFixity (QName ()) String]
fixities :: ParseMode -> Maybe [ParseFixity (QName ()) String]
fixities } =
ParseMode (QName ()) (Name ()) (Exp SrcSpanInfo) 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 (QName ()) (Name ()) (Exp SrcSpanInfo) String
mode'
where
mode :: ParseMode (QName ()) (Name ()) (Exp SrcSpanInfo) String
mode = ParseMode
-> ParseMode (QName ()) (Name ()) (Exp SrcSpanInfo) String
makeParseMode ParseMode
haskellMode
mode' :: ParseMode (QName ()) (Name ()) (Exp SrcSpanInfo) String
mode' = case Maybe [ParseFixity (QName ()) String]
fixities of
Just [ParseFixity (QName ()) String]
xs -> ParseMode (QName ()) (Name ()) (Exp SrcSpanInfo) String
mode { $sel:fixities:ParseMode :: [ParseFixity (QName ()) String]
Egison.fixities = [ParseFixity (QName ()) String]
xs }
Maybe [ParseFixity (QName ()) String]
Nothing -> ParseMode (QName ()) (Name ()) (Exp SrcSpanInfo) 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