{-# LANGUAGE DataKinds          #-}
{-# LANGUAGE GADTs              #-}
{-# LANGUAGE KindSignatures     #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections      #-}
{-# LANGUAGE ViewPatterns       #-}
-- | Parsing command line targets
module Stack.Build.Target
    ( -- * Types
      ComponentName
    , UnresolvedComponent (..)
    , RawTarget (..)
    , LocalPackageView (..)
    , SimpleTarget (..)
    , NeedTargets (..)
      -- * Parsers
    , parseRawTarget
    , parseTargets
    ) where

import           Control.Applicative
import           Control.Arrow (second)
import           Control.Monad.Catch (MonadCatch, throwM)
import           Control.Monad.IO.Class
import           Data.Either (partitionEithers)
import           Data.Foldable
import           Data.List.Extra (groupSort)
import           Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.List.NonEmpty as NonEmpty
import           Data.Map (Map)
import qualified Data.Map as Map
import           Data.Maybe (mapMaybe)
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Text (Text)
import qualified Data.Text as T
import           Path
import           Path.Extra (rejectMissingDir)
import           Path.IO
import           Prelude hiding (concat, concatMap) -- Fix redundant import warnings
import           Stack.Types.PackageIdentifier
import           Stack.Types.PackageName
import           Stack.Types.Version
import           Stack.Types.Config
import           Stack.Types.Build
import           Stack.Types.Package

-- | The name of a component, which applies to executables, test suites, and benchmarks
type ComponentName = Text

newtype RawInput = RawInput { unRawInput :: Text }

-- | Either a fully resolved component, or a component name that could be
-- either an executable, test, or benchmark
data UnresolvedComponent
    = ResolvedComponent !NamedComponent
    | UnresolvedComponent !ComponentName
    deriving (Show, Eq, Ord)

-- | Raw command line input, without checking against any databases or list of
-- locals. Does not deal with directories
data RawTarget (a :: RawTargetType) where
    RTPackageComponent :: !PackageName -> !UnresolvedComponent -> RawTarget a
    RTComponent :: !ComponentName -> RawTarget a
    RTPackage :: !PackageName -> RawTarget a
    RTPackageIdentifier :: !PackageIdentifier -> RawTarget 'HasIdents

deriving instance Show (RawTarget a)
deriving instance Eq (RawTarget a)
deriving instance Ord (RawTarget a)

data RawTargetType = HasIdents | NoIdents

-- | If this function returns @Nothing@, the input should be treated as a
-- directory.
parseRawTarget :: Text -> Maybe (RawTarget 'HasIdents)
parseRawTarget t =
        (RTPackageIdentifier <$> parsePackageIdentifierFromString s)
    <|> (RTPackage <$> parsePackageNameFromString s)
    <|> (RTComponent <$> T.stripPrefix ":" t)
    <|> parsePackageComponent
  where
    s = T.unpack t

    parsePackageComponent =
        case T.splitOn ":" t of
            [pname, "lib"]
                | Just pname' <- parsePackageNameFromString (T.unpack pname) ->
                    Just $ RTPackageComponent pname' $ ResolvedComponent CLib
            [pname, cname]
                | Just pname' <- parsePackageNameFromString (T.unpack pname) ->
                    Just $ RTPackageComponent pname' $ UnresolvedComponent cname
            [pname, typ, cname]
                | Just pname' <- parsePackageNameFromString (T.unpack pname)
                , Just wrapper <- parseCompType typ ->
                    Just $ RTPackageComponent pname' $ ResolvedComponent $ wrapper cname
            _ -> Nothing

    parseCompType t' =
        case t' of
            "exe" -> Just CExe
            "test" -> Just CTest
            "bench" -> Just CBench
            _ -> Nothing

-- | A view of a local package needed for resolving components
data LocalPackageView = LocalPackageView
    { lpvVersion    :: !Version
    , lpvRoot       :: !(Path Abs Dir)
    , lpvCabalFP    :: !(Path Abs File)
    , lpvComponents :: !(Set NamedComponent)
    , lpvExtraDep   :: !TreatLikeExtraDep
    }

-- | Same as @parseRawTarget@, but also takes directories into account.
parseRawTargetDirs :: (MonadIO m, MonadCatch m)
                   => Path Abs Dir -- ^ current directory
                   -> Map PackageName LocalPackageView
                   -> Text
                   -> m (Either Text [(RawInput, RawTarget 'HasIdents)])
parseRawTargetDirs root locals t =
    case parseRawTarget t of
        Just rt -> return $ Right [(ri, rt)]
        Nothing -> do
            mdir <- forgivingAbsence (resolveDir root (T.unpack t))
              >>= rejectMissingDir
            case mdir of
                Nothing -> return $ Left $ "Directory not found: " `T.append` t
                Just dir ->
                    case mapMaybe (childOf dir) $ Map.toList locals of
                        [] -> return $ Left $
                            "No local directories found as children of " `T.append`
                            t
                        names -> return $ Right $ map ((ri, ) . RTPackage) names
  where
    ri = RawInput t

    childOf dir (name, lpv) =
        if (dir == lpvRoot lpv || isParentOf dir (lpvRoot lpv)) && not (lpvExtraDep lpv)
            then Just name
            else Nothing

data SimpleTarget
    = STUnknown
    | STNonLocal
    | STLocalComps !(Set NamedComponent)
    | STLocalAll
    deriving (Show, Eq, Ord)

resolveIdents :: Map PackageName Version -- ^ snapshot
              -> Map PackageName Version -- ^ extra deps
              -> Map PackageName LocalPackageView
              -> (RawInput, RawTarget 'HasIdents)
              -> Either Text ((RawInput, RawTarget 'NoIdents), Map PackageName Version)
resolveIdents _ _ _ (ri, RTPackageComponent x y) = Right ((ri, RTPackageComponent x y), Map.empty)
resolveIdents _ _ _ (ri, RTComponent x) = Right ((ri, RTComponent x), Map.empty)
resolveIdents _ _ _ (ri, RTPackage x) = Right ((ri, RTPackage x), Map.empty)
resolveIdents snap extras locals (ri, RTPackageIdentifier (PackageIdentifier name version)) =
    fmap ((ri, RTPackage name), ) newExtras
  where
    newExtras =
        case (Map.lookup name locals, mfound) of
            -- Error if it matches a local package, pkg idents not
            -- supported for local.
            (Just _, _) -> Left $ T.concat
                [ packageNameText name
                , " target has a specific version number, but it is a local package."
                , "\nTo avoid confusion, we will not install the specified version or build the local one."
                , "\nTo build the local package, specify the target without an explicit version."
                ]
            -- If the found version matches, no need for an extra-dep.
            (_, Just foundVersion) | foundVersion == version -> Right Map.empty
            -- Otherwise, if there is no specified version or a
            -- mismatch, add an extra-dep.
            _ -> Right $ Map.singleton name version
    mfound = asum (map (Map.lookup name) [extras, snap])

resolveRawTarget :: Map PackageName Version -- ^ snapshot
                 -> Map PackageName Version -- ^ extra deps
                 -> Map PackageName LocalPackageView
                 -> (RawInput, RawTarget 'NoIdents)
                 -> Either Text (PackageName, (RawInput, SimpleTarget))
resolveRawTarget snap extras locals (ri, rt) =
    go rt
  where
    go (RTPackageComponent name ucomp) =
        case Map.lookup name locals of
            Nothing -> Left $ T.pack $ "Unknown local package: " ++ packageNameString name
            Just lpv ->
                case ucomp of
                    ResolvedComponent comp
                        | comp `Set.member` lpvComponents lpv ->
                            Right (name, (ri, STLocalComps $ Set.singleton comp))
                        | otherwise -> Left $ T.pack $ concat
                            [ "Component "
                            , show comp
                            , " does not exist in package "
                            , packageNameString name
                            ]
                    UnresolvedComponent comp ->
                        case filter (isCompNamed comp) $ Set.toList $ lpvComponents lpv of
                            [] -> Left $ T.concat
                                [ "Component "
                                , comp
                                , " does not exist in package "
                                , T.pack $ packageNameString name
                                ]
                            [x] -> Right (name, (ri, STLocalComps $ Set.singleton x))
                            matches -> Left $ T.concat
                                [ "Ambiguous component name "
                                , comp
                                , " for package "
                                , T.pack $ packageNameString name
                                , ": "
                                , T.pack $ show matches
                                ]
    go (RTComponent cname) =
        let allPairs = concatMap
                (\(name, lpv) -> map (name,) $ Set.toList $ lpvComponents lpv)
                (Map.toList locals)
         in case filter (isCompNamed cname . snd) allPairs of
                [] -> Left $ "Could not find a component named " `T.append` cname
                [(name, comp)] ->
                    Right (name, (ri, STLocalComps $ Set.singleton comp))
                matches -> Left $ T.concat
                    [ "Ambiugous component name "
                    , cname
                    , ", matches: "
                    , T.pack $ show matches
                    ]

    go (RTPackage name) =
        case Map.lookup name locals of
            Just _lpv -> Right (name, (ri, STLocalAll))
            Nothing ->
                case Map.lookup name extras of
                    Just _ -> Right (name, (ri, STNonLocal))
                    Nothing ->
                        case Map.lookup name snap of
                            Just _ -> Right (name, (ri, STNonLocal))
                            Nothing -> Right (name, (ri, STUnknown))

isCompNamed :: Text -> NamedComponent -> Bool
isCompNamed _ CLib = False
isCompNamed t1 (CExe t2) = t1 == t2
isCompNamed t1 (CTest t2) = t1 == t2
isCompNamed t1 (CBench t2) = t1 == t2

simplifyTargets :: [(PackageName, (RawInput, SimpleTarget))]
                -> ([Text], Map PackageName SimpleTarget)
simplifyTargets =
    foldMap go . collect
  where
    go :: (PackageName, NonEmpty (RawInput, SimpleTarget))
       -> ([Text], Map PackageName SimpleTarget)
    go (name, (_, st) :| []) = ([], Map.singleton name st)
    go (name, pairs) =
        case partitionEithers $ map (getLocalComp . snd) (NonEmpty.toList pairs) of
            ([], comps) -> ([], Map.singleton name $ STLocalComps $ Set.unions comps)
            _ ->
                let err = T.pack $ concat
                        [ "Overlapping targets provided for package "
                        , packageNameString name
                        , ": "
                        , show $ map (unRawInput . fst) (NonEmpty.toList pairs)
                        ]
                 in ([err], Map.empty)

    collect :: Ord a => [(a, b)] -> [(a, NonEmpty b)]
    collect = map (second NonEmpty.fromList) . groupSort

    getLocalComp (STLocalComps comps) = Right comps
    getLocalComp _ = Left ()

-- | Need targets, e.g. `stack build` or allow none?
data NeedTargets
    = NeedTargets
    | AllowNoTargets

parseTargets :: (MonadCatch m, MonadIO m)
             => NeedTargets -- ^ need at least one target
             -> Bool -- ^ using implicit global project?
             -> Map PackageName Version -- ^ snapshot
             -> Map PackageName Version -- ^ extra deps
             -> Map PackageName LocalPackageView
             -> Path Abs Dir -- ^ current directory
             -> [Text] -- ^ command line targets
             -> m (Map PackageName Version, Map PackageName SimpleTarget)
parseTargets needTargets implicitGlobal snap extras locals currDir textTargets' = do
    let nonExtraDeps = Map.keys $ Map.filter (not . lpvExtraDep) locals
        textTargets =
            if null textTargets'
                then map (T.pack . packageNameString) nonExtraDeps
                else textTargets'
    erawTargets <- mapM (parseRawTargetDirs currDir locals) textTargets

    let (errs1, rawTargets) = partitionEithers erawTargets
        (errs2, unzip -> (rawTargets', newExtras)) = partitionEithers $
            map (resolveIdents snap extras locals) $ concat rawTargets
        (errs3, targetTypes) = partitionEithers $
            map (resolveRawTarget snap extras locals) rawTargets'
        (errs4, targets) = simplifyTargets targetTypes
        errs = concat [errs1, errs2, errs3, errs4]

    if null errs
        then if Map.null targets
                 then case needTargets of
                        AllowNoTargets ->
                            return (Map.empty, Map.empty)
                        NeedTargets
                            | null textTargets' && implicitGlobal -> throwM $ TargetParseException
                                ["The specified targets matched no packages.\nPerhaps you need to run 'stack init'?"]
                            | null textTargets' && null nonExtraDeps -> throwM $ TargetParseException
                                ["The project contains no local packages (packages not marked with 'extra-dep')"]
                            | otherwise -> throwM $ TargetParseException
                                ["The specified targets matched no packages"]
                 else return (Map.unions newExtras, targets)
        else throwM $ TargetParseException errs