{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}

module HsDev.Symbols.Location (
	ModulePackage(..), mkPackage, PackageConfig(..),
	ModuleLocation(..), locationId, noLocation,
	ModuleId(..), moduleName, moduleLocation,
	SymbolId(..), symbolName, symbolModule,
	Position(..), Region(..), region, regionAt, regionLines, regionStr,
	Location(..),

	packageName, packageVersion,
	package, packageModules, packageExposed,
	moduleFile, moduleProject, moduleInstallDirs, modulePackage, installedModuleName, installedModuleExposed, otherLocationName,
	positionLine, positionColumn,
	regionFrom, regionTo,
	locationModule, locationPosition,

	sourceModuleRoot,
	importPath,
	sourceRoot, sourceRoot_,
	RecalcTabs(..),

	module HsDev.PackageDb.Types
	) where

import Control.Applicative
import Control.DeepSeq (NFData(..))
import Control.Lens (makeLenses, view, preview, over)
import Data.Aeson
import Data.Char (isSpace, isDigit)
import Data.List (findIndex)
import Data.Maybe
import Data.Text (Text, pack, unpack)
import Data.Text.Lens (unpacked)
import qualified Data.Text as T
import System.FilePath
import Text.Read (readMaybe)
import Text.Format

import System.Directory.Paths
import HsDev.Display
import HsDev.PackageDb.Types
import HsDev.Project.Types
import HsDev.Util ((.::), (.::?), (.::?!), objectUnion, noNulls)

-- | Just package name and version without its location
data ModulePackage = ModulePackage {
	_packageName :: Text,
	_packageVersion :: Text }
		deriving (Eq, Ord)

makeLenses ''ModulePackage

mkPackage :: Text -> ModulePackage
mkPackage n = ModulePackage n ""

instance NFData ModulePackage where
	rnf (ModulePackage n v) = rnf n `seq` rnf v

instance Show ModulePackage where
	show (ModulePackage n "") = unpack n
	show (ModulePackage n v) = unpack n ++ "-" ++ unpack v

instance Read ModulePackage where
	readsPrec _ str = case pkg of
		"" -> []
		_ -> [(ModulePackage (pack n) (pack v), str')]
		where
			(pkg, str') = break isSpace str
			(rv, rn) = span versionChar $ reverse pkg
			v = reverse rv
			n = reverse $ dropWhile (== '-') rn

			versionChar ch = isDigit ch || ch == '.'

instance ToJSON ModulePackage where
	toJSON (ModulePackage n v) = object [
		"name" .= n,
		"version" .= v]

instance FromJSON ModulePackage where
	parseJSON = withObject "module package" $ \v ->
		ModulePackage <$> (v .:: "name") <*> (v .:: "version")

data PackageConfig = PackageConfig {
	_package :: ModulePackage,
	_packageModules :: [Text],
	_packageExposed :: Bool }
		deriving (Eq, Ord, Read, Show)

makeLenses ''PackageConfig

instance NFData PackageConfig where
	rnf (PackageConfig p ms e) = rnf p `seq` rnf ms `seq` rnf e

instance ToJSON PackageConfig where
	toJSON (PackageConfig p ms e) = toJSON p `objectUnion` object ["modules" .= ms, "exposed" .= e]

instance FromJSON PackageConfig where
	parseJSON = withObject "package-config" $ \v -> PackageConfig <$>
		parseJSON (Object v) <*>
		(v .::?! "modules") <*>
		(v .:: "exposed" <|> pure False)

-- | Location of module
data ModuleLocation =
	FileModule { _moduleFile :: Path, _moduleProject :: Maybe Project } |
	InstalledModule { _moduleInstallDirs :: [Path], _modulePackage :: ModulePackage, _installedModuleName :: Text, _installedModuleExposed :: Bool } |
	OtherLocation { _otherLocationName :: Text } |
	NoLocation

instance Eq ModuleLocation where
	FileModule lfile _ == FileModule rfile _ = lfile == rfile
	InstalledModule ldirs _ lname _ == InstalledModule rdirs _ rname _ = ldirs == rdirs && lname == rname
	OtherLocation l == OtherLocation r = l == r
	NoLocation == NoLocation = True
	_ == _ = False

instance Ord ModuleLocation where
	compare l r = compare (locType l, locNames l) (locType r, locNames r) where
		locType :: ModuleLocation -> Int
		locType (FileModule _ _) = 0
		locType (InstalledModule _ _ _ _) = 1
		locType (OtherLocation _) = 2
		locType NoLocation = 3
		locNames (FileModule f _) = [f]
		locNames (InstalledModule dirs _ nm _) = nm : dirs
		locNames (OtherLocation n) = [n]
		locNames NoLocation = []

makeLenses ''ModuleLocation

locationId :: ModuleLocation -> Text
locationId (FileModule fpath _) = fpath
locationId (InstalledModule dirs mpack nm _) = T.intercalate ":" (take 1 dirs ++ [pack (show mpack), nm])
locationId (OtherLocation src) = src
locationId NoLocation = "<no-location>"

instance NFData ModuleLocation where
	rnf (FileModule f p) = rnf f `seq` rnf p
	rnf (InstalledModule d p n e) = rnf d `seq` rnf p `seq` rnf n `seq` rnf e
	rnf (OtherLocation s) = rnf s
	rnf NoLocation = ()

instance Show ModuleLocation where
	show = unpack . locationId

instance Display ModuleLocation where
	display (FileModule f _) = display f
	display (InstalledModule _ _ n _) = view unpacked n
	display (OtherLocation s) = view unpacked s
	display NoLocation = "<no-location>"
	displayType _ = "module"

instance Formattable ModuleLocation where
	formattable = formattable . display

instance ToJSON ModuleLocation where
	toJSON (FileModule f p) = object $ noNulls ["file" .= f, "project" .= fmap (view projectCabal) p]
	toJSON (InstalledModule c p n e) = object $ noNulls ["dirs" .= c, "package" .= show p, "name" .= n, "exposed" .= e]
	toJSON (OtherLocation s) = object ["source" .= s]
	toJSON NoLocation = object []

instance FromJSON ModuleLocation where
	parseJSON = withObject "module location" $ \v ->
		(FileModule <$> v .:: "file" <*> (fmap project <$> (v .::? "project"))) <|>
		(InstalledModule <$> v .::?! "dirs" <*> (readPackage =<< (v .:: "package")) <*> v .:: "name" <*> v .:: "exposed") <|>
		(OtherLocation <$> v .:: "source") <|>
		(pure NoLocation)
		where
			readPackage s = maybe (fail $ "can't parse package: " ++ s) return . readMaybe $ s

instance Paths ModuleLocation where
	paths f (FileModule fpath p) = FileModule <$> paths f fpath <*> traverse (paths f) p
	paths f (InstalledModule c p n e) = InstalledModule <$> traverse (paths f) c <*> pure p <*> pure n <*> pure e
	paths _ (OtherLocation s) = pure $ OtherLocation s
	paths _ NoLocation = pure NoLocation

noLocation :: ModuleLocation
noLocation = NoLocation

data ModuleId = ModuleId {
	_moduleName :: Text,
	_moduleLocation :: ModuleLocation }
		deriving (Eq, Ord)

makeLenses ''ModuleId

instance NFData ModuleId where
	rnf (ModuleId n l) = rnf n `seq` rnf l

instance Show ModuleId where
	show (ModuleId n l) = show l ++ ":" ++ unpack n

instance ToJSON ModuleId where
	toJSON m = object $ noNulls [
		"name" .= _moduleName m,
		"location" .= _moduleLocation m]

instance FromJSON ModuleId where
	parseJSON = withObject "module-id" $ \v -> ModuleId <$>
		(fromMaybe "" <$> (v .::? "name")) <*>
		(fromMaybe NoLocation <$> (v .::? "location"))

-- | Symbol
data SymbolId = SymbolId {
	_symbolName :: Text,
	_symbolModule :: ModuleId }
		deriving (Eq, Ord)

makeLenses ''SymbolId

instance NFData SymbolId where
	rnf (SymbolId n m) = rnf n `seq` rnf m

instance Show SymbolId where
	show (SymbolId n m) = show m ++ ":" ++ unpack n

instance ToJSON SymbolId where
	toJSON s = object $ noNulls [
		"name" .= _symbolName s,
		"module" .= _symbolModule s]

instance FromJSON SymbolId where
	parseJSON = withObject "symbol-id" $ \v -> SymbolId <$>
		(fromMaybe "" <$> (v .::? "name")) <*>
		(fromMaybe (ModuleId "" NoLocation) <$> (v .::? "module"))

data Position = Position {
	_positionLine :: Int,
	_positionColumn :: Int }
		deriving (Eq, Ord, Read)

makeLenses ''Position

instance NFData Position where
	rnf (Position l c) = rnf l `seq` rnf c

instance Show Position where
 	show (Position l c) = show l ++ ":" ++ show c

instance ToJSON Position where
	toJSON (Position l c) = object [
		"line" .= l,
		"column" .= c]

instance FromJSON Position where
	parseJSON = withObject "position" $ \v -> Position <$>
		v .:: "line" <*>
		v .:: "column"

data Region = Region {
	_regionFrom :: Position,
	_regionTo :: Position }
		deriving (Eq, Ord, Read)

makeLenses ''Region

region :: Position -> Position -> Region
region f t = Region (min f t) (max f t)

regionAt :: Position -> Region
regionAt f = region f f

regionLines :: Region -> Int
regionLines (Region f t) = succ (view positionLine t - view positionLine f)

-- | Get string at region
regionStr :: Region -> Text -> Text
regionStr r@(Region f t) s = T.intercalate "\n" $ T.drop (pred $ view positionColumn f) fline : tl where
	s' = take (regionLines r) $ drop (pred (view positionLine f)) $ T.lines s
	(fline:tl) = init s' ++ [T.take (pred $ view positionColumn t) (last s')]

instance NFData Region where
	rnf (Region f t) = rnf f `seq` rnf t

instance Show Region where
	show (Region f t) = show f ++ "-" ++ show t

instance ToJSON Region where
	toJSON (Region f t) = object [
		"from" .= f,
		"to" .= t]

instance FromJSON Region where
	parseJSON = withObject "region" $ \v -> Region <$>
		v .:: "from" <*>
		v .:: "to"

-- | Location of symbol
data Location = Location {
	_locationModule :: ModuleLocation,
	_locationPosition :: Maybe Position }
		deriving (Eq, Ord)

makeLenses ''Location

instance NFData Location where
	rnf (Location m p) = rnf m `seq` rnf p

instance Show Location where
	show (Location m p) = show m ++ ":" ++ show p

instance ToJSON Location where
	toJSON (Location ml p) = object [
		"module" .= ml,
		"pos" .= p]

instance FromJSON Location where
	parseJSON = withObject "location" $ \v -> Location <$>
		v .:: "module" <*>
		v .::? "pos"

-- | Get source module root directory, i.e. for "...\src\Foo\Bar.hs" with module 'Foo.Bar' will return "...\src"
sourceModuleRoot :: Text -> Path -> Path
sourceModuleRoot mname = over paths $
	normalise . joinPath .
	reverse . drop (length $ T.split (== '.') mname) . reverse .
	splitDirectories

-- | Path to module source
-- >importPath "Quux.Blah" = "Quux/Blah.hs"
importPath :: Text -> Path
importPath = fromFilePath . (`addExtension` "hs") . joinPath . map unpack . T.split (== '.')

-- | Root of sources, package dir or root directory of standalone modules
sourceRoot :: ModuleId -> Maybe Path
sourceRoot m = do
	fpath <- preview (moduleLocation . moduleFile) m
	mproj <- preview (moduleLocation . moduleProject) m
	return $ maybe
		(sourceModuleRoot (view moduleName m) fpath)
		(view projectPath)
		mproj

sourceRoot_ :: ModuleId -> Path
sourceRoot_ = fromMaybe (error "sourceRoot_: not a source location") . sourceRoot

-- | Recalc positions to interpret '\t' as one symbol instead of N
class RecalcTabs a where
	-- | Interpret '\t' as one symbol instead of N
	recalcTabs :: Text -> Int -> a -> a
	-- | Inverse of `recalcTabs`: interpret '\t' as N symbols instead of 1
	calcTabs :: Text -> Int -> a -> a

instance RecalcTabs Position where
	recalcTabs cts n (Position l c) = Position l c' where
		line = listToMaybe $ drop (pred l) $ T.lines cts
		c' = case line of
			Nothing -> c
			Just line' -> let sizes = map charSize (unpack line') in
				succ . fromMaybe (length sizes) .
				findIndex (>= pred c) .
				scanl (+) 0 $ sizes
		charSize :: Char -> Int
		charSize '\t' = n
		charSize _ = 1
	calcTabs cts n (Position l c) = Position l c' where
		line = listToMaybe $ drop (pred l) $ T.lines cts
		c' = maybe c (succ . sum . map charSize . take (pred c) . unpack) line
		charSize :: Char -> Int
		charSize '\t' = n
		charSize _ = 1

instance RecalcTabs Region where
	recalcTabs cts n (Region f t) = Region (recalcTabs cts n f) (recalcTabs cts n t)
	calcTabs cts n (Region f t) = Region (calcTabs cts n f) (calcTabs cts n t)