-- |
--
-- Module:      Language.Egison.Parser.Pattern.Mode.Haskell
-- Description: Parser for Egison pattern expressions in Haskell source code
-- Stability:   experimental
--
-- A parser for Egison pattern expressions in Haskell source code.

module Language.Egison.Parser.Pattern.Mode.Haskell
  (
  -- * Parsers
    Expr
  , ExprL
  , ParseMode(..)
  , parseExpr
  , parseExprL
  -- * Converting @haskell-src-exts@'s entities
  , 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 synonym of 'Egison.Expr' to be parsed in Haskell's source code.
type Expr = Egison.Expr (QName ()) (Name ()) (Exp SrcSpanInfo)

-- | Type synonym of 'Egison.ExprL' to be parsed in Haskell's source code.
type ExprL = Egison.ExprL (QName ()) (Name ()) (Exp SrcSpanInfo)

-- | Parser configuration in @egison-pattern-src-haskell-mode@.
data ParseMode
  = ParseMode {
              -- | 'Haskell.ParseMode' from @haskell-src-exts@ for our parsers to base on.
                ParseMode -> ParseMode
haskellMode :: Haskell.ParseMode
              -- | List of fixities to parse infix pattern operators.
              -- If @fixities = Just xs@, @xs@ overrides fixities obtained from 'haskellMode'.
              -- Otherwise, our parsers use fixities from 'haskellMode'.
              , 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

-- | Build 'Egison.Fixity' using 'Haskell.Fixity' from @haskell-src-exts@.
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

-- | Build 'Egison.ParseFixity' using 'Egison.Fixity' to parse Haskell-style operators
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

-- | Build 'Egison.ParseMode' using 'Haskell.ParseMode' from @haskell-src-exts@.
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

-- | Parse 'Expr' using 'ParseMode'.
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

-- | Parse 'Expr' using 'ParseMode' with locations annotated.
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