-- |
--
-- 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
  , parseExpr
  , parseExprWithFixities
  -- * Converting @haskell-src-exts@'s entities
  , ParseMode
  , ParseFixity
  , Fixity
  , makeHaskellMode
  , makeFixity
  , makeParseFixity
  , makeParseFixities
  )
where

import           Data.Functor                   ( void )
import           Data.Maybe                     ( mapMaybe )
import           Control.Monad.Except           ( MonadError )

import           Language.Haskell.Exts.Syntax   ( QName(..)
                                                , Exp(..)
                                                , Name(..)
                                                , ModuleName(..)
                                                , 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.Parser  as Haskell
                                                ( parseExpWithMode
                                                , ParseMode(..)
                                                , ParseResult(..)
                                                )

import qualified Language.Egison.Syntax.Pattern
                                               as Egison
                                                ( Expr )
import qualified Language.Egison.Parser.Pattern
                                               as Egison
                                                ( ParseMode(..)
                                                , ParseFixity(..)
                                                , Fixity(..)
                                                , Associativity(..)
                                                , parseExpr
                                                )
import           Language.Egison.Parser.Pattern ( Precedence(..)
                                                , 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.ParseMode' to parse 'Expr'.
type ParseMode = Egison.ParseMode (QName ()) (Name ()) (Exp SrcSpanInfo) String

-- | Type synonym of 'Egison.Fixity' to parse 'Expr'.
type Fixity = Egison.Fixity (QName ())

-- | Type synonym of 'Egison.ParseFixity' to parse 'Expr'.
type ParseFixity = 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

-- | Build 'Egison.Fixity' using 'Haskell.Fixity' from @haskell-src-exts@.
-- Note that a built-in constructor with special syntax, that is represented as 'Special' in 'QName', is just ignored here.
makeFixity :: Haskell.Fixity -> Fixity
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

-- | Build 'Egison.ParseFixity' using 'Egison.Fixity' to parse Haskell-style operators
-- Note that a built-in constructor with special syntax, that is represented as 'Special' in 'QName', is just ignored here.
makeParseFixity :: Fixity -> Maybe ParseFixity
makeParseFixity fixity = Egison.ParseFixity fixity <$> makeNameParser symbol
 where
  Egison.Fixity { Egison.symbol } = fixity
  makeNameParser (UnQual () (Ident () n)) = Just $ makeIdentOpParser Nothing n
  makeNameParser (UnQual () (Symbol () n)) =
    Just $ makeSymbolOpParser Nothing n
  makeNameParser (Qual () (ModuleName () m) (Ident () n)) =
    Just $ makeIdentOpParser (Just m) n
  makeNameParser (Qual () (ModuleName () m) (Symbol () n)) =
    Just $ makeSymbolOpParser (Just m) n
  makeNameParser (Special () _) = Nothing  -- Skipping special built-in constructors
  -- TODO: Maybe we could do better here
  makeIdentOpParser mModName ident content
    | content == printed = Right ()
    | otherwise          = Left "not an operator name"
    where printed = '`' : maybe ident (++ '.' : ident) mModName ++ "`"
  makeSymbolOpParser mModName sym content
    | content == printed = Right ()
    | otherwise          = Left "not an operator name"
    where printed = maybe sym (++ '.' : sym) mModName

-- | @'makeParseFixities' = 'mapMaybe' $ 'makeParseFixity' . 'makeFixity'@
makeParseFixities :: [Haskell.Fixity] -> [ParseFixity]
makeParseFixities = mapMaybe $ makeParseFixity . makeFixity

-- | Build 'ParseMode' using 'Haskell.ParseMode' from @haskell-src-exts@.
makeHaskellMode :: Haskell.ParseMode -> ParseMode
makeHaskellMode mode@Haskell.ParseMode { Haskell.fixities } = Egison.ParseMode
  { 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
  }

-- | Parse 'Expr' using 'Haskell.ParseMode' from @haskell-src-exts@.
parseExpr
  :: MonadError (Errors String) m => Haskell.ParseMode -> String -> m Expr
parseExpr mode@Haskell.ParseMode { Haskell.parseFilename } =
  Egison.parseExpr (makeHaskellMode mode) parseFilename

-- | Parse 'Expr' using 'Haskell.ParseMode' from @haskell-src-exts@, while supplying an explicit list of 'ParseFixity'.
-- Note that fixities obtained from 'Haskell.ParseMode' are just ignored here.
parseExprWithFixities
  :: MonadError (Errors String) m
  => Haskell.ParseMode
  -> [Fixity]
  -> String
  -> m Expr
parseExprWithFixities mode@Haskell.ParseMode { Haskell.parseFilename } fixities
  = Egison.parseExpr hsModeWithFixities parseFilename
 where
  hsMode = makeHaskellMode mode
  hsModeWithFixities =
    hsMode { Egison.fixities = mapMaybe makeParseFixity fixities }