{-# LANGUAGE DeriveGeneric #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Client.BuildTargets
-- Copyright   :  (c) Duncan Coutts 2012
-- License     :  BSD-like
--
-- Maintainer  :  [email protected]
--
-- Handling for user-specified build targets
-----------------------------------------------------------------------------
module Distribution.Simple.BuildTarget (

    -- * Build targets
    BuildTarget(..),
    readBuildTargets,
    showBuildTarget,
    QualLevel(..),
    buildTargetComponentName,

    -- * Parsing user build targets
    UserBuildTarget,
    readUserBuildTargets,
    showUserBuildTarget,
    UserBuildTargetProblem(..),
    reportUserBuildTargetProblems,

    -- * Resolving build targets
    resolveBuildTargets,
    BuildTargetProblem(..),
    reportBuildTargetProblems,
  ) where

import Distribution.Package
import Distribution.PackageDescription
import Distribution.ModuleName
import Distribution.Simple.LocalBuildInfo
import Distribution.Text
import Distribution.Simple.Utils

import Distribution.Compat.Binary (Binary)
import qualified Distribution.Compat.ReadP as Parse
import Distribution.Compat.ReadP
         ( (+++), (<++) )

import Data.List
         ( nub, stripPrefix, sortBy, groupBy, partition )
import Data.Maybe
         ( listToMaybe, catMaybes )
import Data.Either
         ( partitionEithers )
import GHC.Generics (Generic)
import qualified Data.Map as Map
import Control.Monad
import Control.Applicative as AP (Alternative(..), Applicative(..))
import Data.Char
         ( isSpace, isAlphaNum )
import System.FilePath as FilePath
         ( dropExtension, normalise, splitDirectories, joinPath, splitPath
         , hasTrailingPathSeparator )
import System.Directory
         ( doesFileExist, doesDirectoryExist )

-- ------------------------------------------------------------
-- * User build targets
-- ------------------------------------------------------------

-- | Various ways that a user may specify a build target.
--
data UserBuildTarget =

     -- | A target specified by a single name. This could be a component
     -- module or file.
     --
     -- > cabal build foo
     -- > cabal build Data.Foo
     -- > cabal build Data/Foo.hs  Data/Foo.hsc
     --
     UserBuildTargetSingle String

     -- | A target specified by a qualifier and name. This could be a component
     -- name qualified by the component namespace kind, or a module or file
     -- qualified by the component name.
     --
     -- > cabal build lib:foo exe:foo
     -- > cabal build foo:Data.Foo
     -- > cabal build foo:Data/Foo.hs
     --
   | UserBuildTargetDouble String String

     -- A fully qualified target, either a module or file qualified by a
     -- component name with the component namespace kind.
     --
     -- > cabal build lib:foo:Data/Foo.hs exe:foo:Data/Foo.hs
     -- > cabal build lib:foo:Data.Foo exe:foo:Data.Foo
     --
   | UserBuildTargetTriple String String String
  deriving (Show, Eq, Ord)


-- ------------------------------------------------------------
-- * Resolved build targets
-- ------------------------------------------------------------

-- | A fully resolved build target.
--
data BuildTarget =

     -- | A specific component
     --
     BuildTargetComponent ComponentName

     -- | A specific module within a specific component.
     --
   | BuildTargetModule ComponentName ModuleName

     -- | A specific file within a specific component.
     --
   | BuildTargetFile ComponentName FilePath
  deriving (Eq, Show, Generic)

instance Binary BuildTarget

buildTargetComponentName :: BuildTarget -> ComponentName
buildTargetComponentName (BuildTargetComponent cn)   = cn
buildTargetComponentName (BuildTargetModule    cn _) = cn
buildTargetComponentName (BuildTargetFile      cn _) = cn

-- | Read a list of user-supplied build target strings and resolve them to
-- 'BuildTarget's according to a 'PackageDescription'. If there are problems
-- with any of the targets e.g. they don't exist or are misformatted, throw an
-- 'IOException'.
readBuildTargets :: PackageDescription -> [String] -> IO [BuildTarget]
readBuildTargets pkg targetStrs = do
    let (uproblems, utargets) = readUserBuildTargets targetStrs
    reportUserBuildTargetProblems uproblems

    utargets' <- mapM checkTargetExistsAsFile utargets

    let (bproblems, btargets) = resolveBuildTargets pkg utargets'
    reportBuildTargetProblems bproblems

    return btargets

checkTargetExistsAsFile :: UserBuildTarget -> IO (UserBuildTarget, Bool)
checkTargetExistsAsFile t = do
    fexists <- existsAsFile (fileComponentOfTarget t)
    return (t, fexists)

  where
    existsAsFile f = do
      exists <- doesFileExist f
      case splitPath f of
        (d:_)   | hasTrailingPathSeparator d -> doesDirectoryExist d
        (d:_:_) | not exists                 -> doesDirectoryExist d
        _                                    -> return exists

    fileComponentOfTarget (UserBuildTargetSingle     s1) = s1
    fileComponentOfTarget (UserBuildTargetDouble _   s2) = s2
    fileComponentOfTarget (UserBuildTargetTriple _ _ s3) = s3


-- ------------------------------------------------------------
-- * Parsing user targets
-- ------------------------------------------------------------

readUserBuildTargets :: [String] -> ([UserBuildTargetProblem]
                                    ,[UserBuildTarget])
readUserBuildTargets = partitionEithers . map readUserBuildTarget

readUserBuildTarget :: String -> Either UserBuildTargetProblem
                                        UserBuildTarget
readUserBuildTarget targetstr =
    case readPToMaybe parseTargetApprox targetstr of
      Nothing  -> Left  (UserBuildTargetUnrecognised targetstr)
      Just tgt -> Right tgt

  where
    parseTargetApprox :: Parse.ReadP r UserBuildTarget
    parseTargetApprox =
          (do a <- tokenQ
              return (UserBuildTargetSingle a))
      +++ (do a <- token
              _ <- Parse.char ':'
              b <- tokenQ
              return (UserBuildTargetDouble a b))
      +++ (do a <- token
              _ <- Parse.char ':'
              b <- token
              _ <- Parse.char ':'
              c <- tokenQ
              return (UserBuildTargetTriple a b c))

    token  = Parse.munch1 (\x -> not (isSpace x) && x /= ':')
    tokenQ = parseHaskellString <++ token
    parseHaskellString :: Parse.ReadP r String
    parseHaskellString = Parse.readS_to_P reads

    readPToMaybe :: Parse.ReadP a a -> String -> Maybe a
    readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str
                                         , all isSpace s ]

data UserBuildTargetProblem
   = UserBuildTargetUnrecognised String
  deriving Show

reportUserBuildTargetProblems :: [UserBuildTargetProblem] -> IO ()
reportUserBuildTargetProblems problems = do
    case [ target | UserBuildTargetUnrecognised target <- problems ] of
      []     -> return ()
      target ->
        die $ unlines
                [ "Unrecognised build target '" ++ name ++ "'."
                | name <- target ]
           ++ "Examples:\n"
           ++ " - build foo          -- component name "
           ++ "(library, executable, test-suite or benchmark)\n"
           ++ " - build Data.Foo     -- module name\n"
           ++ " - build Data/Foo.hsc -- file name\n"
           ++ " - build lib:foo exe:foo   -- component qualified by kind\n"
           ++ " - build foo:Data.Foo      -- module qualified by component\n"
           ++ " - build foo:Data/Foo.hsc  -- file qualified by component"

showUserBuildTarget :: UserBuildTarget -> String
showUserBuildTarget = intercalate ":" . getComponents
  where
    getComponents (UserBuildTargetSingle s1)       = [s1]
    getComponents (UserBuildTargetDouble s1 s2)    = [s1,s2]
    getComponents (UserBuildTargetTriple s1 s2 s3) = [s1,s2,s3]

showBuildTarget :: QualLevel -> PackageId -> BuildTarget -> String
showBuildTarget ql pkgid bt =
    showUserBuildTarget (renderBuildTarget ql bt pkgid)


-- ------------------------------------------------------------
-- * Resolving user targets to build targets
-- ------------------------------------------------------------

{-
stargets =
  [ BuildTargetComponent (CExeName "foo")
  , BuildTargetModule    (CExeName "foo") (mkMn "Foo")
  , BuildTargetModule    (CExeName "tst") (mkMn "Foo")
  ]
    where
    mkMn :: String -> ModuleName
    mkMn  = fromJust . simpleParse

ex_pkgid :: PackageIdentifier
Just ex_pkgid = simpleParse "thelib"
-}

-- | Given a bunch of user-specified targets, try to resolve what it is they
-- refer to.
--
resolveBuildTargets :: PackageDescription
                    -> [(UserBuildTarget, Bool)]
                    -> ([BuildTargetProblem], [BuildTarget])
resolveBuildTargets pkg = partitionEithers
                        . map (uncurry (resolveBuildTarget pkg))

resolveBuildTarget :: PackageDescription -> UserBuildTarget -> Bool
                   -> Either BuildTargetProblem BuildTarget
resolveBuildTarget pkg userTarget fexists =
    case findMatch (matchBuildTarget pkg userTarget fexists) of
      Unambiguous target  -> Right target
      Ambiguous   targets -> Left (BuildTargetAmbiguous userTarget targets')
                               where targets' = disambiguateBuildTargets
                                                    (packageId pkg) userTarget
                                                    targets
      None        errs    -> Left (classifyMatchErrors errs)

  where
    classifyMatchErrors errs
      | not (null expected) = let (things, got:_) = unzip expected in
                              BuildTargetExpected userTarget things got
      | not (null nosuch)   = BuildTargetNoSuch   userTarget nosuch
      | otherwise = error $ "resolveBuildTarget: internal error in matching"
      where
        expected = [ (thing, got) | MatchErrorExpected thing got <- errs ]
        nosuch   = [ (thing, got) | MatchErrorNoSuch   thing got <- errs ]


data BuildTargetProblem
   = BuildTargetExpected  UserBuildTarget [String]  String
     -- ^  [expected thing] (actually got)
   | BuildTargetNoSuch    UserBuildTarget [(String, String)]
     -- ^ [(no such thing,  actually got)]
   | BuildTargetAmbiguous UserBuildTarget [(UserBuildTarget, BuildTarget)]
  deriving Show


disambiguateBuildTargets :: PackageId -> UserBuildTarget -> [BuildTarget]
                         -> [(UserBuildTarget, BuildTarget)]
disambiguateBuildTargets pkgid original =
    disambiguate (userTargetQualLevel original)
  where
    disambiguate ql ts
        | null amb  = unamb
        | otherwise = unamb ++ disambiguate (succ ql) amb
      where
        (amb, unamb) = step ql ts

    userTargetQualLevel (UserBuildTargetSingle _    ) = QL1
    userTargetQualLevel (UserBuildTargetDouble _ _  ) = QL2
    userTargetQualLevel (UserBuildTargetTriple _ _ _) = QL3

    step  :: QualLevel -> [BuildTarget]
          -> ([BuildTarget], [(UserBuildTarget, BuildTarget)])
    step ql = (\(amb, unamb) -> (map snd $ concat amb, concat unamb))
            . partition (\g -> length g > 1)
            . groupBy (equating fst)
            . sortBy (comparing fst)
            . map (\t -> (renderBuildTarget ql t pkgid, t))

data QualLevel = QL1 | QL2 | QL3
  deriving (Enum, Show)

renderBuildTarget :: QualLevel -> BuildTarget -> PackageId -> UserBuildTarget
renderBuildTarget ql target pkgid =
    case ql of
      QL1 -> UserBuildTargetSingle s1        where  s1          = single target
      QL2 -> UserBuildTargetDouble s1 s2     where (s1, s2)     = double target
      QL3 -> UserBuildTargetTriple s1 s2 s3  where (s1, s2, s3) = triple target

  where
    single (BuildTargetComponent cn  ) = dispCName cn
    single (BuildTargetModule    _  m) = display m
    single (BuildTargetFile      _  f) = f

    double (BuildTargetComponent cn  ) = (dispKind cn, dispCName cn)
    double (BuildTargetModule    cn m) = (dispCName cn, display m)
    double (BuildTargetFile      cn f) = (dispCName cn, f)

    triple (BuildTargetComponent _   ) = error "triple BuildTargetComponent"
    triple (BuildTargetModule    cn m) = (dispKind cn, dispCName cn, display m)
    triple (BuildTargetFile      cn f) = (dispKind cn, dispCName cn, f)

    dispCName = componentStringName pkgid
    dispKind  = showComponentKindShort . componentKind

reportBuildTargetProblems :: [BuildTargetProblem] -> IO ()
reportBuildTargetProblems problems = do

    case [ (t, e, g) | BuildTargetExpected t e g <- problems ] of
      []      -> return ()
      targets ->
        die $ unlines
          [    "Unrecognised build target '" ++ showUserBuildTarget target
            ++ "'.\n"
            ++ "Expected a " ++ intercalate " or " expected
            ++ ", rather than '" ++ got ++ "'."
          | (target, expected, got) <- targets ]

    case [ (t, e) | BuildTargetNoSuch t e <- problems ] of
      []      -> return ()
      targets ->
        die $ unlines
          [    "Unknown build target '" ++ showUserBuildTarget target
            ++ "'.\nThere is no "
            ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'"
                                  | (thing, got) <- nosuch ] ++ "."
          | (target, nosuch) <- targets ]
        where
          mungeThing "file" = "file target"
          mungeThing thing  = thing

    case [ (t, ts) | BuildTargetAmbiguous t ts <- problems ] of
      []      -> return ()
      targets ->
        die $ unlines
          [    "Ambiguous build target '" ++ showUserBuildTarget target
            ++ "'. It could be:\n "
            ++ unlines [ "   "++ showUserBuildTarget ut ++
                         " (" ++ showBuildTargetKind bt ++ ")"
                       | (ut, bt) <- amb ]
          | (target, amb) <- targets ]

  where
    showBuildTargetKind (BuildTargetComponent _  ) = "component"
    showBuildTargetKind (BuildTargetModule    _ _) = "module"
    showBuildTargetKind (BuildTargetFile      _ _) = "file"


----------------------------------
-- Top level BuildTarget matcher
--

matchBuildTarget :: PackageDescription
                 -> UserBuildTarget -> Bool -> Match BuildTarget
matchBuildTarget pkg = \utarget fexists ->
    case utarget of
      UserBuildTargetSingle str1 ->
        matchBuildTarget1 cinfo str1 fexists

      UserBuildTargetDouble str1 str2 ->
        matchBuildTarget2 cinfo str1 str2 fexists

      UserBuildTargetTriple str1 str2 str3 ->
        matchBuildTarget3 cinfo str1 str2 str3 fexists
  where
    cinfo = pkgComponentInfo pkg

matchBuildTarget1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget
matchBuildTarget1 cinfo str1 fexists =
                        matchComponent1 cinfo str1
   `matchPlusShadowing` matchModule1    cinfo str1
   `matchPlusShadowing` matchFile1      cinfo str1 fexists


matchBuildTarget2 :: [ComponentInfo] -> String -> String -> Bool
                  -> Match BuildTarget
matchBuildTarget2 cinfo str1 str2 fexists =
                        matchComponent2 cinfo str1 str2
   `matchPlusShadowing` matchModule2    cinfo str1 str2
   `matchPlusShadowing` matchFile2      cinfo str1 str2 fexists


matchBuildTarget3 :: [ComponentInfo] -> String -> String -> String -> Bool
                  -> Match BuildTarget
matchBuildTarget3 cinfo str1 str2 str3 fexists =
                        matchModule3    cinfo str1 str2 str3
   `matchPlusShadowing` matchFile3      cinfo str1 str2 str3 fexists


data ComponentInfo = ComponentInfo {
       cinfoName    :: ComponentName,
       cinfoStrName :: ComponentStringName,
       cinfoSrcDirs :: [FilePath],
       cinfoModules :: [ModuleName],
       cinfoHsFiles :: [FilePath],   -- other hs files (like main.hs)
       cinfoCFiles  :: [FilePath],
       cinfoJsFiles :: [FilePath]
     }

type ComponentStringName = String

pkgComponentInfo :: PackageDescription -> [ComponentInfo]
pkgComponentInfo pkg =
    [ ComponentInfo {
        cinfoName    = componentName c,
        cinfoStrName = componentStringName pkg (componentName c),
        cinfoSrcDirs = hsSourceDirs bi,
        cinfoModules = componentModules c,
        cinfoHsFiles = componentHsFiles c,
        cinfoCFiles  = cSources bi,
        cinfoJsFiles = jsSources bi
      }
    | c <- pkgComponents pkg
    , let bi = componentBuildInfo c ]

componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName
componentStringName pkg CLibName          = display (packageName pkg)
componentStringName _   (CExeName  name)  = name
componentStringName _   (CTestName  name) = name
componentStringName _   (CBenchName name) = name

componentModules :: Component -> [ModuleName]
componentModules (CLib   lib)   = libModules lib
componentModules (CExe   exe)   = exeModules exe
componentModules (CTest  test)  = testModules test
componentModules (CBench bench) = benchmarkModules bench

componentHsFiles :: Component -> [FilePath]
componentHsFiles (CExe exe) = [modulePath exe]
componentHsFiles (CTest  TestSuite {
                           testInterface = TestSuiteExeV10 _ mainfile
                         }) = [mainfile]
componentHsFiles (CBench Benchmark {
                           benchmarkInterface = BenchmarkExeV10 _ mainfile
                         }) = [mainfile]
componentHsFiles _          = []

{-
ex_cs :: [ComponentInfo]
ex_cs =
  [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"])
  , (mkC (CExeName "tst") ["src1", "test"]      ["Foo"])
  ]
    where
    mkC n ds ms = ComponentInfo n (componentStringName pkgid n) ds (map mkMn ms)
    mkMn :: String -> ModuleName
    mkMn  = fromJust . simpleParse
    pkgid :: PackageIdentifier
    Just pkgid = simpleParse "thelib"
-}

------------------------------
-- Matching component kinds
--

data ComponentKind = LibKind | ExeKind | TestKind | BenchKind
  deriving (Eq, Ord, Show)

componentKind :: ComponentName -> ComponentKind
componentKind CLibName       = LibKind
componentKind (CExeName  _)  = ExeKind
componentKind (CTestName  _) = TestKind
componentKind (CBenchName _) = BenchKind

cinfoKind :: ComponentInfo -> ComponentKind
cinfoKind = componentKind . cinfoName

matchComponentKind :: String -> Match ComponentKind
matchComponentKind s
  | s `elem` ["lib", "library"]            = increaseConfidence >> return LibKind
  | s `elem` ["exe", "executable"]         = increaseConfidence >> return ExeKind
  | s `elem` ["tst", "test", "test-suite"] = increaseConfidence
                                             >> return TestKind
  | s `elem` ["bench", "benchmark"]        = increaseConfidence
                                             >> return BenchKind
  | otherwise                              = matchErrorExpected
                                             "component kind" s

showComponentKind :: ComponentKind -> String
showComponentKind LibKind   = "library"
showComponentKind ExeKind   = "executable"
showComponentKind TestKind  = "test-suite"
showComponentKind BenchKind = "benchmark"

showComponentKindShort :: ComponentKind -> String
showComponentKindShort LibKind   = "lib"
showComponentKindShort ExeKind   = "exe"
showComponentKindShort TestKind  = "test"
showComponentKindShort BenchKind = "bench"

------------------------------
-- Matching component targets
--

matchComponent1 :: [ComponentInfo] -> String -> Match BuildTarget
matchComponent1 cs = \str1 -> do
    guardComponentName str1
    c <- matchComponentName cs str1
    return (BuildTargetComponent (cinfoName c))

matchComponent2 :: [ComponentInfo] -> String -> String -> Match BuildTarget
matchComponent2 cs = \str1 str2 -> do
    ckind <- matchComponentKind str1
    guardComponentName str2
    c <- matchComponentKindAndName cs ckind str2
    return (BuildTargetComponent (cinfoName c))

-- utils:

guardComponentName :: String -> Match ()
guardComponentName s
  | all validComponentChar s
    && not (null s)  = increaseConfidence
  | otherwise        = matchErrorExpected "component name" s
  where
    validComponentChar c = isAlphaNum c || c == '.'
                        || c == '_' || c == '-' || c == '\''

matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo
matchComponentName cs str =
    orNoSuchThing "component" str
  $ increaseConfidenceFor
  $ matchInexactly caseFold
      [ (cinfoStrName c, c) | c <- cs ]
      str

matchComponentKindAndName :: [ComponentInfo] -> ComponentKind -> String
                          -> Match ComponentInfo
matchComponentKindAndName cs ckind str =
    orNoSuchThing (showComponentKind ckind ++ " component") str
  $ increaseConfidenceFor
  $ matchInexactly (\(ck, cn) -> (ck, caseFold cn))
      [ ((cinfoKind c, cinfoStrName c), c) | c <- cs ]
      (ckind, str)


------------------------------
-- Matching module targets
--

matchModule1 :: [ComponentInfo] -> String -> Match BuildTarget
matchModule1 cs = \str1 -> do
    guardModuleName str1
    nubMatchErrors $ do
      c <- tryEach cs
      let ms = cinfoModules c
      m <- matchModuleName ms str1
      return (BuildTargetModule (cinfoName c) m)

matchModule2 :: [ComponentInfo] -> String -> String -> Match BuildTarget
matchModule2 cs = \str1 str2 -> do
    guardComponentName str1
    guardModuleName    str2
    c <- matchComponentName cs str1
    let ms = cinfoModules c
    m <- matchModuleName ms str2
    return (BuildTargetModule (cinfoName c) m)

matchModule3 :: [ComponentInfo] -> String -> String -> String
             -> Match BuildTarget
matchModule3 cs str1 str2 str3 = do
    ckind <- matchComponentKind str1
    guardComponentName str2
    c <- matchComponentKindAndName cs ckind str2
    guardModuleName    str3
    let ms = cinfoModules c
    m <- matchModuleName ms str3
    return (BuildTargetModule (cinfoName c) m)

-- utils:

guardModuleName :: String -> Match ()
guardModuleName s
  | all validModuleChar s
    && not (null s)       = increaseConfidence
  | otherwise             = matchErrorExpected "module name" s
  where
    validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\''

matchModuleName :: [ModuleName] -> String -> Match ModuleName
matchModuleName ms str =
    orNoSuchThing "module" str
  $ increaseConfidenceFor
  $ matchInexactly caseFold
      [ (display m, m)
      | m <- ms ]
      str


------------------------------
-- Matching file targets
--

matchFile1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget
matchFile1 cs str1 exists =
    nubMatchErrors $ do
      c <- tryEach cs
      filepath <- matchComponentFile c str1 exists
      return (BuildTargetFile (cinfoName c) filepath)


matchFile2 :: [ComponentInfo] -> String -> String -> Bool -> Match BuildTarget
matchFile2 cs str1 str2 exists = do
    guardComponentName str1
    c <- matchComponentName cs str1
    filepath <- matchComponentFile c str2 exists
    return (BuildTargetFile (cinfoName c) filepath)


matchFile3 :: [ComponentInfo] -> String -> String -> String -> Bool
           -> Match BuildTarget
matchFile3 cs str1 str2 str3 exists = do
    ckind <- matchComponentKind str1
    guardComponentName str2
    c <- matchComponentKindAndName cs ckind str2
    filepath <- matchComponentFile c str3 exists
    return (BuildTargetFile (cinfoName c) filepath)


matchComponentFile :: ComponentInfo -> String -> Bool -> Match FilePath
matchComponentFile c str fexists =
    expecting "file" str $
      matchPlus
        (matchFileExists str fexists)
        (matchPlusShadowing
          (msum [ matchModuleFileRooted   dirs ms      str
                , matchOtherFileRooted    dirs hsFiles str ])
          (msum [ matchModuleFileUnrooted      ms      str
                , matchOtherFileUnrooted       hsFiles str
                , matchOtherFileUnrooted       cFiles  str
                , matchOtherFileUnrooted       jsFiles str ]))
  where
    dirs = cinfoSrcDirs c
    ms   = cinfoModules c
    hsFiles = cinfoHsFiles c
    cFiles  = cinfoCFiles c
    jsFiles = cinfoJsFiles c


-- utils

matchFileExists :: FilePath -> Bool -> Match a
matchFileExists _     False = mzero
matchFileExists fname True  = do increaseConfidence
                                 matchErrorNoSuch "file" fname

matchModuleFileUnrooted :: [ModuleName] -> String -> Match FilePath
matchModuleFileUnrooted ms str = do
    let filepath = normalise str
    _ <- matchModuleFileStem ms filepath
    return filepath

matchModuleFileRooted :: [FilePath] -> [ModuleName] -> String -> Match FilePath
matchModuleFileRooted dirs ms str = nubMatches $ do
    let filepath = normalise str
    filepath' <- matchDirectoryPrefix dirs filepath
    _ <- matchModuleFileStem ms filepath'
    return filepath

matchModuleFileStem :: [ModuleName] -> FilePath -> Match ModuleName
matchModuleFileStem ms =
      increaseConfidenceFor
    . matchInexactly caseFold
        [ (toFilePath m, m) | m <- ms ]
    . dropExtension

matchOtherFileRooted :: [FilePath] -> [FilePath] -> FilePath -> Match FilePath
matchOtherFileRooted dirs fs str = do
    let filepath = normalise str
    filepath' <- matchDirectoryPrefix dirs filepath
    _ <- matchFile fs filepath'
    return filepath

matchOtherFileUnrooted :: [FilePath] -> FilePath -> Match FilePath
matchOtherFileUnrooted fs str = do
    let filepath = normalise str
    _ <- matchFile fs filepath
    return filepath

matchFile :: [FilePath] -> FilePath -> Match FilePath
matchFile fs = increaseConfidenceFor
             . matchInexactly caseFold [ (f, f) | f <- fs ]

matchDirectoryPrefix :: [FilePath] -> FilePath -> Match FilePath
matchDirectoryPrefix dirs filepath =
    exactMatches $
      catMaybes
       [ stripDirectory (normalise dir) filepath | dir <- dirs ]
  where
    stripDirectory :: FilePath -> FilePath -> Maybe FilePath
    stripDirectory dir fp =
      joinPath `fmap` stripPrefix (splitDirectories dir) (splitDirectories fp)


------------------------------
-- Matching monad
--

-- | A matcher embodies a way to match some input as being some recognised
-- value. In particular it deals with multiple and ambiguous matches.
--
-- There are various matcher primitives ('matchExactly', 'matchInexactly'),
-- ways to combine matchers ('ambiguousWith', 'shadows') and finally we can
-- run a matcher against an input using 'findMatch'.
--

data Match a = NoMatch      Confidence [MatchError]
             | ExactMatch   Confidence [a]
             | InexactMatch Confidence [a]
  deriving Show

type Confidence = Int

data MatchError = MatchErrorExpected String String
                | MatchErrorNoSuch   String String
  deriving (Show, Eq)


instance Alternative Match where
      empty = mzero
      (<|>) = mplus

instance MonadPlus Match where
  mzero = matchZero
  mplus = matchPlus

matchZero :: Match a
matchZero = NoMatch 0 []

-- | Combine two matchers. Exact matches are used over inexact matches
-- but if we have multiple exact, or inexact then the we collect all the
-- ambiguous matches.
--
matchPlus :: Match a -> Match a -> Match a
matchPlus   (ExactMatch   d1 xs)   (ExactMatch   d2 xs') =
  ExactMatch (max d1 d2) (xs ++ xs')
matchPlus a@(ExactMatch   _  _ )   (InexactMatch _  _  ) = a
matchPlus a@(ExactMatch   _  _ )   (NoMatch      _  _  ) = a
matchPlus   (InexactMatch _  _ ) b@(ExactMatch   _  _  ) = b
matchPlus   (InexactMatch d1 xs)   (InexactMatch d2 xs') =
  InexactMatch (max d1 d2) (xs ++ xs')
matchPlus a@(InexactMatch _  _ )   (NoMatch      _  _  ) = a
matchPlus   (NoMatch      _  _ ) b@(ExactMatch   _  _  ) = b
matchPlus   (NoMatch      _  _ ) b@(InexactMatch _  _  ) = b
matchPlus a@(NoMatch      d1 ms) b@(NoMatch      d2 ms')
                                             | d1 >  d2  = a
                                             | d1 <  d2  = b
                                             | otherwise = NoMatch d1 (ms ++ ms')

-- | Combine two matchers. This is similar to 'ambiguousWith' with the
-- difference that an exact match from the left matcher shadows any exact
-- match on the right. Inexact matches are still collected however.
--
matchPlusShadowing :: Match a -> Match a -> Match a
matchPlusShadowing a@(ExactMatch _ _) (ExactMatch _ _) = a
matchPlusShadowing a                   b               = matchPlus a b

instance Functor Match where
  fmap _ (NoMatch      d ms) = NoMatch      d ms
  fmap f (ExactMatch   d xs) = ExactMatch   d (fmap f xs)
  fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs)

instance Applicative Match where
  pure a = ExactMatch 0 [a]
  (<*>) = ap

instance Monad Match where
  return = AP.pure

  NoMatch      d ms >>= _ = NoMatch d ms
  ExactMatch   d xs >>= f = addDepth d
                          $ foldr matchPlus matchZero (map f xs)
  InexactMatch d xs >>= f = addDepth d .  forceInexact
                          $ foldr matchPlus matchZero (map f xs)

addDepth :: Confidence -> Match a -> Match a
addDepth d' (NoMatch      d msgs) = NoMatch      (d'+d) msgs
addDepth d' (ExactMatch   d xs)   = ExactMatch   (d'+d) xs
addDepth d' (InexactMatch d xs)   = InexactMatch (d'+d) xs

forceInexact :: Match a -> Match a
forceInexact (ExactMatch d ys) = InexactMatch d ys
forceInexact m                 = m

------------------------------
-- Various match primitives
--

matchErrorExpected, matchErrorNoSuch :: String -> String -> Match a
matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got]
matchErrorNoSuch   thing got = NoMatch 0 [MatchErrorNoSuch   thing got]

expecting :: String -> String -> Match a -> Match a
expecting thing got (NoMatch 0 _) = matchErrorExpected thing got
expecting _     _   m             = m

orNoSuchThing :: String -> String -> Match a -> Match a
orNoSuchThing thing got (NoMatch 0 _) = matchErrorNoSuch thing got
orNoSuchThing _     _   m             = m

increaseConfidence :: Match ()
increaseConfidence = ExactMatch 1 [()]

increaseConfidenceFor :: Match a -> Match a
increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r

nubMatches :: Eq a => Match a -> Match a
nubMatches (NoMatch      d msgs) = NoMatch      d msgs
nubMatches (ExactMatch   d xs)   = ExactMatch   d (nub xs)
nubMatches (InexactMatch d xs)   = InexactMatch d (nub xs)

nubMatchErrors :: Match a -> Match a
nubMatchErrors (NoMatch      d msgs) = NoMatch      d (nub msgs)
nubMatchErrors (ExactMatch   d xs)   = ExactMatch   d xs
nubMatchErrors (InexactMatch d xs)   = InexactMatch d xs

-- | Lift a list of matches to an exact match.
--
exactMatches, inexactMatches :: [a] -> Match a

exactMatches [] = matchZero
exactMatches xs = ExactMatch 0 xs

inexactMatches [] = matchZero
inexactMatches xs = InexactMatch 0 xs

tryEach :: [a] -> Match a
tryEach = exactMatches


------------------------------
-- Top level match runner
--

-- | Given a matcher and a key to look up, use the matcher to find all the
-- possible matches. There may be 'None', a single 'Unambiguous' match or
-- you may have an 'Ambiguous' match with several possibilities.
--
findMatch :: Eq b => Match b -> MaybeAmbiguous b
findMatch match =
    case match of
      NoMatch    _ msgs -> None (nub msgs)
      ExactMatch   _ xs -> checkAmbiguous xs
      InexactMatch _ xs -> checkAmbiguous xs
  where
    checkAmbiguous xs = case nub xs of
                          [x] -> Unambiguous x
                          xs' -> Ambiguous   xs'

data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous [a]
  deriving Show


------------------------------
-- Basic matchers
--

{-
-- | A primitive matcher that looks up a value in a finite 'Map'. The
-- value must match exactly.
--
matchExactly :: forall a b. Ord a => [(a, b)] -> (a -> Match b)
matchExactly xs =
    \x -> case Map.lookup x m of
            Nothing -> matchZero
            Just ys -> ExactMatch 0 ys
  where
    m :: Ord a => Map a [b]
    m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ]
-}

-- | A primitive matcher that looks up a value in a finite 'Map'. It checks
-- for an exact or inexact match. We get an inexact match if the match
-- is not exact, but the canonical forms match. It takes a canonicalisation
-- function for this purpose.
--
-- So for example if we used string case fold as the canonicalisation
-- function, then we would get case insensitive matching (but it will still
-- report an exact match when the case matches too).
--
matchInexactly :: (Ord a, Ord a') =>
                        (a -> a') ->
                        [(a, b)] -> (a -> Match b)
matchInexactly cannonicalise xs =
    \x -> case Map.lookup x m of
            Just ys -> exactMatches ys
            Nothing -> case Map.lookup (cannonicalise x) m' of
                         Just ys -> inexactMatches ys
                         Nothing -> matchZero
  where
    m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ]

    -- the map of canonicalised keys to groups of inexact matches
    m' = Map.mapKeysWith (++) cannonicalise m



------------------------------
-- Utils
--

caseFold :: String -> String
caseFold = lowercase