SourceMatch.hs

-- | This module will implement pattern matching on Haskell source as parsed by `haskell-src-exts`.
--
{-# LANGUAGE QuasiQuotes     #-}
{-# LANGUAGE LambdaCase      #-}
{-# LANGUAGE TemplateHaskell #-}
module Language.Haskell.SourceMatch
    ( isStringMatchedToDecl
    , isFileMatchedToDecl
    , MatchResult
    --
    , T_1, T_2, T_3, T_4, T_5, T_6, T_7, T_8, T_9, T_10
    ) where


import           Control.Monad
import           Control.Monad.Trans.Class           as T
import           Control.Monad.Trans.Except
import           Control.Monad.Trans.State
import           Data.Either
import           Data.List
import           Data.List.Split
import           Data.Map.Strict (Map)
import           Data.Maybe
import           Language.Haskell.Exts
import           Language.Haskell.Exts.Parser
import           Language.Haskell.Exts.Syntax        as HS
import           Language.Haskell.TH                 as TH
import           Language.Haskell.TH.Lib
import           Language.Haskell.TH.Quote(QuasiQuoter(..))
import           Language.Haskell.TH.Syntax          as TH
import           Text.InterpolatedString.Perl6 (qc)
import qualified Data.Map.Strict                     as Map
import qualified Language.Haskell.TH.Syntax          as TH

-- | Dummy Types to use as metavariables
data T_1
data T_2
data T_3
data T_4
data T_5
data T_6
data T_7
data T_8
data T_9
data T_10


matchExpr, matchDecl :: QuasiQuoter
-- | This should return TH expression that will type to `Matches Exp`
matchExpr  = QuasiQuoter {
               quoteExp  = quoterToBeImplemented
             , quotePat  = quoterUndefined
             , quoteType = quoterUndefined
             , quoteDec  = quoterUndefined
             }


quoterToBeImplemented _ = [| undefined |]
quoterUndefined       _ = undefined


-- | This should return TH expression that will type to `Matches Decl`
matchDecl  = QuasiQuoter {
               quoteExp = quoterToBeImplemented
             , quotePat  = quoterUndefined
             , quoteType = quoterUndefined
             , quoteDec  = quoterUndefined
             }


-- | All declarations for:
--   * `data` types
--   * `newtype` types
--   * `type` aliases
dataDecls :: HS.Module a -> Map.Map String [Decl a]
dataDecls  = undefined


instanceDecls :: HS.Module a -> Map.Map String [Decl a]
instanceDecls  = undefined


-- | Milestones for `Match`:
type Matches a = a -> Bool
-- ^ Above is key to writing first tests for Homplexity!


defParseMode :: ParseMode
defParseMode = defaultParseMode


-- | This function should read input string, and check that it contains given declaration.
--
isStringMatchedToDecl :: String -> DecsQ -> IO (Either MatchingError MatchResult)
isStringMatchedToDecl declarationStr expectedDecl =
    case parseDeclWithMode defParseMode declarationStr of
        ParseFailed _ errorMessage ->
            fail [qc|Can't parse "{declarationStr}", error occurs: {errorMessage}|] -- TODO
        ParseOk hsParseResult -> do
            allDecls@(thParseResult:_) <- runQ expectedDecl
            when (null allDecls)        $ fail [qc|Empty `expectedDecl`|]
            when (length allDecls >= 2) $ fail [qc|Too long `expectedDecl` is not supported|]
            let result = tryMatch thParseResult hsParseResult
            return result


isFileMatchedToDecl :: FilePath -> DecsQ -> IO (Either MatchingError MatchResult)
isFileMatchedToDecl filepath expectedDecl = do
    allDecls@(thParseResult:_) <- runQ expectedDecl
    when (null allDecls)        $ fail [qc|Empty `expectedDecl`|]
    when (length allDecls >= 2) $ fail [qc|Too long `expectedDecl` is not supported|]
    --
    file <- readFile filepath
    let extensions = maybe [] snd $ readExtensions file
    case parseModuleWithMode (defParseMode { extensions = extensions }) file of
        ParseFailed _ errorMessage ->
            fail [qc|Can't parse "{filepath}", error occurs: {errorMessage}|]
        ParseOk (HS.Module _ _ _ _ decls) -> do
            let someMatchings = rights $ map (tryMatch thParseResult) decls
            case someMatchings of
                []    -> return $ Left (MatchingError "No matches")
                (m:_) -> return $ Right m


tryMatch :: (Show a)
         => TH.Dec
         -> HS.Decl a
         -> Either MatchingError MatchResult
tryMatch thDecl hsDecl = runExcept $ execStateT (thToHsMatchDeclaration thDecl hsDecl) Map.empty


--
-- * Matching itself
--

data MetaVariable = MetaVariableDecl String
                  | MetaVariableConstructor String
                  | MetaVariableVar String
                  | MetaVariableType String
                  deriving (Eq, Ord, Show)


-- | Result of matching (metavariables unification)
--
type MatchResult = Map MetaVariable String


newtype MatchingError = MatchingError String deriving Show


matchError :: String -> MatchState a
matchError = T.lift . throwE . MatchingError


-- | State of matching process
--
type MatchState a = StateT MatchResult (Except MatchingError) a


--
-- * Some useful utilities for matching state
--

-- | Add match to match result. Fail if metavariable already matched
addMatch :: MetaVariable -> String -> MatchState ()
addMatch metaVar hsName = get >>= Map.alterF insertKey metaVar >>= put
  where
    insertKey Nothing = return $ Just hsName
    insertKey k@(Just hsName')
      | hsName == hsName' = return k
      | otherwise         = matchError [qc|Var ({metaVar}, {hsName}) already matched|]


-- | Check length of lists and `zipWithM` their
zipWithLengthCheckM_ :: (Show a, Show b)
                     => String -> (a -> b -> MatchState c) -> [a] -> [b] -> MatchState ()
zipWithLengthCheckM_ listName f as bs
    | length as /= length bs = matchError [qc|{listName} list length not matched|]
    | otherwise              = zipWithM_ f as bs


--
-- * Matcher
--


thToHsMatchDeclaration :: (Show a)
                       => TH.Dec
                       -> HS.Decl a
                       -> MatchState ()
thToHsMatchDeclaration
    (TH.DataD _ thDataName _ _ thConstructors thDerivings)
    (HS.DataDecl _ (DataType _) _context (DHead _ hsDataName) hsConstructors hsDerivings) = do
        thToHsMatchIdents datatypeDeclMatcher thDataName hsDataName
        zipWithLengthCheckM_ "contstructors" thToHsMatchConstructors thConstructors hsConstructors
        zipWithLengthCheckM_ "derivings"     thToHsMatchDerivings    thDerivings    hsDerivings
thToHsMatchDeclaration th hs = matchError [qc|Mismatch: {th} =/= {hs}|]


thToHsMatchConstructors :: (Show a)
                        => Con
                        -> QualConDecl a
                        -> MatchState ()
thToHsMatchConstructors
    (TH.RecC thConstructorName thFields)
    (HS.QualConDecl _ _ _ (RecDecl _ hsConstructorName hsFields)) = do
        thToHsMatchIdents constructorMatcher thConstructorName hsConstructorName
        zipWithLengthCheckM_ "fields" thToHsMatchConstructorArgs thFields hsFields
thToHsMatchConstructors th hs = matchError [qc|Constructors mismatch: {th} =/ {hs}|]


thToHsMatchConstructorArgs :: (Show a)
                           => TH.VarBangType
                           -> HS.FieldDecl a
                           -> MatchState ()
thToHsMatchConstructorArgs
    (thName, _thBang, thType)
    (HS.FieldDecl _ names@(hsName:_) hsType) = do
        when (null names)       $ matchError "Number of TH names and HS names not matched"
        when (length names > 1) $ matchError "Many names is record declaration not supported"
        thToHsMatchIdents varMatcher thName hsName
        thToHsMatchTypes thType hsType
thToHsMatchConstructorArgs th hs = matchError [qc|Constructor args mismatch: {th} =/ {hs}|]


thToHsMatchTypes :: (Show a)
                 => TH.Type
                 -> HS.Type a
                 -> MatchState ()
thToHsMatchTypes
    (TH.AppT ListT (ConT    tsType))
    (HS.TyList _   (TyCon _ hsType')) = do
        thToHsMatchIdents typenameMatcher tsType (hsQNameToName hsType')
thToHsMatchTypes
    (TH.ConT    tsType)
    (HS.TyCon _ hsType') = do
        thToHsMatchIdents typenameMatcher tsType (hsQNameToName hsType')
thToHsMatchTypes th hs = matchError [qc|Types args mismatch: {th} =/ {hs}|]


thToHsMatchDerivings :: (Show a)
                     => TH.DerivClause
                     -> HS.Deriving a
                     -> MatchState ()
thToHsMatchDerivings
    (TH.DerivClause _ thTypes)
    (HS.Deriving _ _ instRules) = do
        let thDerivNames  = map thDerivTypeToNameStr thTypes
            thDerivNames' = sort thDerivNames -- TODO Does order of derivings important or not?
            hsDerivNames  = map hsInstRuleToNameStr instRules
            hsDerivNames' = sort hsDerivNames
        when (thDerivNames' /= hsDerivNames') $
            matchError [qc|Derivings TH: {thDerivNames'} is not matched to {hsDerivNames'}|]
        return ()
  where
    thDerivTypeToNameStr (ConT name) = thUnqualName name
    thDerivTypeToNameStr t = error [qc|Unsupported {t}|]
    hsInstRuleToNameStr (IRule _ _ _ (IHCon _ qname)) =
        case hsQNameToName qname of
            Ident  _ sname -> sname
            Symbol _ sname -> sname
    hsInstRuleToNameStr inst = error [qc|Unsupported {inst}|]
    thUnqualName (Name (OccName occ) _) = occ


thToHsMatchIdents :: (Show a) => IdentMatcher -> TH.Name -> HS.Name a -> MatchState ()
thToHsMatchIdents matcher thName (Ident _ hsName) =
    maybe (matchError [qc|TH: '{thNameStr}' is not matched to '{hsName}'|])
          (\(thName', hsName') -> addMatch thName' hsName')
          (matcher thNameStr hsName)
  where
        thNameStr = show thName
thToHsMatchIdents matcher thName hsName = matchError [qc|Mismatch: {thName} {hsName}|]


--
-- * Utilities for matchers
--


hsQNameToName :: (Show a) => HS.QName a -> HS.Name a
hsQNameToName (Qual _ _ name) = name
hsQNameToName (UnQual _ name) = name
hsQNameToName t               = error [qc|Type identifier '{t}' unsupported|]
-- TODO implement qualification support


type IdentMatcher = String -> String -> Maybe (MetaVariable, String)


-- | Matcher for data types
datatypeDeclMatcher :: IdentMatcher
datatypeDeclMatcher th hs
    | hs `isPrefixOf` th = Just (MetaVariableDecl hs, hs)
    | otherwise          = Nothing


-- | Matcher for constructor (meta)variables
constructorMatcher :: IdentMatcher
constructorMatcher = templateMatcher False MetaVariableConstructor "C"


-- | Matcher for variable (meta)variables
varMatcher :: IdentMatcher
varMatcher = templateMatcher False MetaVariableVar "v"


-- | Matcher for type (meta)variables
typenameMatcher :: IdentMatcher
typenameMatcher th hs = templateMatcher True MetaVariableType "T" (removeQualificationIfTemplate th) hs
  where
    -- Main.T_2 -> T_2
    removeQualificationIfTemplate name =
        case splitOn "." name of
            []             -> error "Impossible happened"
            [_justOneName] -> name
            path           -> last path


templateMatcher :: Bool -> (String -> MetaVariable) -> String -> IdentMatcher
templateMatcher exactMatch metavarConstr prefix th hs
    | length sth >= (if exactMatch then 2 else 3) && head sth == prefix
    = if exactMatch then Just (metavarConstr th, hs)
                    else Just (metavarConstr $ intercalate "_" (init sth), hs)
    | hs `isPrefixOf` th = Just (metavarConstr hs, hs)
    | otherwise          = Nothing
  where
    sth = splitOn "_" th