-- |
--
-- Module:      Language.Egison.Parser.Pattern.Mode.Haskell
-- Description: Parser for Egison pattern expressions to use with Template Haskell
-- Stability:   experimental
--
-- A parser for Egison pattern expressions to use with Template Haskell.

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

-- | Type synonym of 'Egison.ExprL' to be used with Template Haskell.
type ExprL = Egison.ExprL TH.Name TH.Name TH.Exp

-- | Parser configuration in @egison-pattern-src-th-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 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

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

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

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

-- | 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