DepResolve.hs

module Descript.Misc.Build.Read.File.DepResolve
  ( GenDepResolver (..)
  , defaultTextResolver
  ) where

import Descript.Misc.Build.Read.File.DepError
import Descript.Misc.Build.Read.File.Scope
import Descript.Misc.Error
import Core.Data.Functor
import Data.Text (Text)
import qualified Data.Text.IO as Text
import Control.Applicative
import Core.Control.Applicative
import Control.Exception
import System.IO.Error
import Paths_descript_lang

-- | Finds the dependency at the given relative module.
data GenDepResolver u a
  = DepResolver
  { showDepResolver :: String -- ^ Used for 'Show'.
  , resolveDep :: RelScope -> GenDepResultT u a
  }

instance Show (GenDepResolver u a) where
  show = showDepResolver

instance (Functor u) => Functor (GenDepResolver u) where
  fmap f x
    = DepResolver
    { showDepResolver = "f <$> " ++ showDepResolver x
    , resolveDep = f <<$>> resolveDep x
    }

instance (Applicative u) => Applicative (GenDepResolver u) where
  pure x
    = DepResolver
    { showDepResolver = "pure x"
    , resolveDep = pure2 x
    }
  f <*> x
    = DepResolver
    { showDepResolver = showDepResolver f ++ " <*> " ++ showDepResolver x
    , resolveDep = resolveDep f <<*>> resolveDep x
    }

instance (Monad u) => Monad (GenDepResolver u) where
  return = pure
  fx >>= f
    = DepResolver
    { showDepResolver = showDepResolver fx ++ " >>= f"
    , resolveDep = resolve
    }
    where resolve scope = do
            ix <- resolveDep fx scope
            resolveDep (f ix) scope

-- | Will use the second resolver if the first resolver can't find the
-- module. If the first resolver gets another resolver or succeeds,
-- will return its result.
instance (Monad u) => Alternative (GenDepResolver u) where
  empty
    = DepResolver
    { showDepResolver = "empty"
    , resolveDep = resolve
    }
    where resolve _ = mkFailureT $ DepNotExist []
  fx <|> fy
    = DepResolver
    { showDepResolver = showDepResolver fx ++ " <|> " ++ showDepResolver fy
    , resolveDep = resolve
    }
    where resolve scope = ResultT $ do
            xres <- runResultT $ resolveDep fx scope
            case xres of
              Failure (DepNotExist xPaths) -> do
                yres <- runResultT $ resolveDep fy scope
                case yres of
                  Failure (DepNotExist yPaths)
                    -> pure $ Failure $ DepNotExist paths
                    where paths = xPaths ++ yPaths
                  _ -> pure yres
              _ -> pure xres

-- | Resolves dependencies in the filesystem within the given folder,
-- or within the user's dependency folder.
defaultTextResolver :: FilePath -> GenDepResolver IO Text
defaultTextResolver path = localTextResolver path <|> sharedGenDepTextResolver

-- | Resolves dependencies in the filesystem within the given folder.
localTextResolver :: FilePath -> GenDepResolver IO Text
localTextResolver path
  = DepResolver
  { showDepResolver = "localResolver " ++ show path
  , resolveDep = resolveLocalT path
  }

-- | Resolves shared dependencies -- installed dependencies which are
-- accessible to all modules with the same path, like @Base@.
sharedGenDepTextResolver :: GenDepResolver IO Text
sharedGenDepTextResolver
  = DepResolver
  { showDepResolver = "sharedGenDepResolver"
  , resolveDep = resolveLocalT' getSharedDepPath . globalizeRelScope
  }

resolveLocalT :: FilePath -> RelScope -> GenDepResultT IO Text
resolveLocalT path = ResultT . resolveLocal path

resolveLocalT' :: IO FilePath -> RelScope -> GenDepResultT IO Text
resolveLocalT' getPath = ResultT . resolveLocal' getPath

resolveLocal :: FilePath -> RelScope -> IO (GenDepResult Text)
resolveLocal path scope
  = handle (failResolveLocal fullPath) $ forceResolveLocal fullPath
  where fullPath = scopeFilepath path scope

resolveLocal' :: IO FilePath -> RelScope -> IO (GenDepResult Text)
resolveLocal' getPath scope = (`resolveLocal` scope) =<< getPath

forceResolveLocal :: FilePath -> IO (GenDepResult Text)
forceResolveLocal = fmap Success . Text.readFile

failResolveLocal :: FilePath -> IOError -> IO (GenDepResult Text)
failResolveLocal path = pure . Failure . ioErrorToDepError path

ioErrorToDepError :: FilePath -> IOError -> AnonDepError
ioErrorToDepError path err
  | isDoesNotExistError err = DepNotExist [path]
  | otherwise = DepNotReadable

-- | This directory contains modules which can be used by a Descript
-- file anywhere.
getSharedDepPath :: IO FilePath
getSharedDepPath = getDataFileName "resources/modules"