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 {
haskellMode :: Haskell.ParseMode
, fixities :: Maybe [Egison.ParseFixity (QName ()) String]
}
resultToEither :: Haskell.ParseResult a -> Either String a
resultToEither (Haskell.ParseOk a ) = Right a
resultToEither (Haskell.ParseFailed _ e) = Left e
parseVarNameWithMode :: Haskell.ParseMode -> String -> Either String (Name ())
parseVarNameWithMode mode content =
case resultToEither $ Haskell.parseExpWithMode mode content of
Right (Var _ (UnQual _ name)) -> Right $ void name
Right e -> Left (show e ++ " is not a variable")
Left err -> Left err
parseNameWithMode :: Haskell.ParseMode -> String -> Either String (QName ())
parseNameWithMode mode content =
case resultToEither $ Haskell.parseExpWithMode mode content of
Right (Var _ name) -> Right $ void name
Right (Con _ name) -> Right $ void name
Right e -> Left (show e ++ " is not a name")
Left err -> Left err
makeFixity :: Haskell.Fixity -> Egison.Fixity (QName ())
makeFixity (Haskell.Fixity assoc prec name) = fixity
where
fixity = Egison.Fixity (makeAssoc assoc) (Precedence prec) name
makeAssoc (Haskell.AssocRight ()) = Egison.AssocRight
makeAssoc (Haskell.AssocLeft ()) = Egison.AssocLeft
makeAssoc (Haskell.AssocNone ()) = Egison.AssocNone
makeParseFixity
:: Egison.Fixity (QName ()) -> Maybe (Egison.ParseFixity (QName ()) String)
makeParseFixity fixity = Egison.ParseFixity fixity <$> makeNameParser symbol
where
Egison.Fixity { Egison.symbol } = fixity
makeNameParser q@(Qual () _ name) = Just $ pparser q name
makeNameParser q@(UnQual () name) = Just $ pparser q name
makeNameParser _ = Nothing
pparser q name input | input == printName q name = Right ()
| otherwise = Left "not an operator name"
printName q name | isCon name = Haskell.prettyPrint $ QConOp () q
| otherwise = Haskell.prettyPrint $ QVarOp () q
isCon (Ident () (c : _)) = isUpper c
isCon (Symbol () (':' : _)) = True
isCon _ = False
makeParseMode
:: Haskell.ParseMode
-> Egison.ParseMode (QName ()) (Name ()) (Exp SrcSpanInfo) String
makeParseMode mode@Haskell.ParseMode { Haskell.parseFilename, Haskell.fixities }
= Egison.ParseMode
{ Egison.filename = parseFilename
, Egison.fixities = maybe [] makeParseFixities fixities
, Egison.blockComment = Just ("{-", "-}")
, Egison.lineComment = Just "--"
, Egison.varNameParser = parseVarNameWithMode mode
, Egison.nameParser = parseNameWithMode mode
, Egison.valueExprParser = resultToEither . Haskell.parseExpWithMode mode
}
where
makeParseFixities
:: [Haskell.Fixity] -> [Egison.ParseFixity (QName ()) String]
makeParseFixities = mapMaybe $ makeParseFixity . makeFixity
instance Parsable Expr String ParseMode where
parseNonGreedyWithLocation ParseMode { haskellMode, fixities } =
parseNonGreedyWithLocation @Expr mode'
where
mode = makeParseMode haskellMode
mode' = case fixities of
Just xs -> mode { Egison.fixities = xs }
Nothing -> mode
parseExpr :: MonadError (Errors String) m => ParseMode -> String -> m Expr
parseExpr = parse @Expr
parseExprL :: MonadError (Errors String) m => ParseMode -> String -> m ExprL
parseExprL = parseWithLocation @Expr