module Language.Haskell.Modules.ModuVerse
( ModuleInfo(..)
, moduleName
, ModuVerseState
, moduVerseInit
, ModuVerse(..)
, getNames
, getInfo
, putModule
, putModuleAnew
, findModule
, delName
, getExtensions
, modifyExtensions
, parseModule
, parseModuleMaybe
, loadModule
, unloadModule
) where
import Control.Applicative ((<$>))
import Control.Exception.Lifted as IO (catch, throw)
import Control.Monad.Trans (liftIO, MonadIO)
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Map as Map (delete, empty, insert, keys, lookup, Map)
import Data.Maybe (fromMaybe)
import Data.Set as Set (fromList, Set)
import qualified Language.Haskell.Exts.Annotated as A (Module(..), ModuleHead(..), ModuleName(..), parseFileWithComments)
import Language.Haskell.Exts.Comments (Comment(..))
#if MIN_VERSION_haskell_src_exts(1,14,0)
import Language.Haskell.Exts.Extension (Extension(..), KnownExtension(..))
#else
import Language.Haskell.Exts.Extension (Extension(..))
#endif
import qualified Language.Haskell.Exts.Parser as Exts (defaultParseMode, fromParseResult, ParseMode(extensions, parseFilename, fixities), ParseResult)
import Language.Haskell.Exts.SrcLoc (SrcSpanInfo)
import Language.Haskell.Exts.Syntax as S (ModuleName(..))
import Language.Haskell.Modules.SourceDirs (modulePathBase, PathKey(..), Path(..), pathKey, SourceDirs(..))
import Language.Haskell.Modules.Util.QIO (MonadVerbosity, qLnPutStr, quietly)
import System.IO.Error (isDoesNotExistError, isUserError)
#if MIN_VERSION_haskell_src_exts(1,14,0)
nameToExtension :: KnownExtension -> Extension
nameToExtension x = EnableExtension x
#else
deriving instance Ord Extension
deriving instance Ord KnownExtension
nameToExtension x = id x
#endif
deriving instance Ord Comment
data ModuleInfo
= ModuleInfo
{ module_ :: A.Module SrcSpanInfo
, text_ :: String
, comments_ :: [Comment]
, key_ :: PathKey }
deriving (Eq, Ord, Show)
moduleName :: ModuleInfo -> S.ModuleName
moduleName (ModuleInfo (A.Module _ mh _ _ _) _ _ _) =
S.ModuleName $ maybe "Main" (\ (A.ModuleHead _ (A.ModuleName _ s) _ _) -> s) mh
moduleName (ModuleInfo m _ _ _) = error $ "Unsupported Module: " ++ show m
data ModuVerseState =
ModuVerseState { moduleNames_ :: Maybe (Map S.ModuleName ModuleInfo)
, moduleInfo_ :: Map PathKey ModuleInfo
, extensions_ :: [Extension]
, sourceDirs_ :: [FilePath]
} deriving (Eq, Ord, Show)
moduVerseInit :: ModuVerseState
moduVerseInit =
ModuVerseState { moduleNames_ = Nothing
, moduleInfo_ = Map.empty
, extensions_ = Exts.extensions Exts.defaultParseMode ++ [nameToExtension StandaloneDeriving]
, sourceDirs_ = ["."] }
hseExtensions :: [Extension]
hseExtensions = map nameToExtension
[ RecursiveDo, ParallelListComp, MultiParamTypeClasses, FunctionalDependencies, RankNTypes, ExistentialQuantification
, ScopedTypeVariables, ImplicitParams, FlexibleContexts, FlexibleInstances, EmptyDataDecls, KindSignatures
, BangPatterns, TemplateHaskell, ForeignFunctionInterface, Generics, NamedFieldPuns, PatternGuards
, MagicHash, TypeFamilies, StandaloneDeriving, TypeOperators, RecordWildCards, GADTs, UnboxedTuples
, PackageImports, QuasiQuotes, ViewPatterns, XmlSyntax, RegularPatterns, TupleSections
#if MIN_VERSION_haskell_src_exts(1,16,0)
, ExplicitNamespaces
#endif
]
getNames :: ModuVerse m => m (Set S.ModuleName)
getNames = getModuVerse >>= return . Set.fromList . keys . fromMaybe (error "No modules in ModuVerse, use putModule") . moduleNames_
getInfo :: ModuVerse m => S.ModuleName -> m (Maybe ModuleInfo)
getInfo name = getModuVerse >>= return . Map.lookup name . fromMaybe (error "No modules in ModuVerse, use putModule") . moduleNames_
putName :: ModuVerse m => S.ModuleName -> ModuleInfo -> m ()
putName name info = modifyModuVerse (\ s -> s {moduleNames_ = Just (Map.insert name info (fromMaybe Map.empty (moduleNames_ s)))})
putModule :: (ModuVerse m, MonadVerbosity m) => S.ModuleName -> m ()
putModule name = pathKey (modulePathBase "hs" name) >>= parseModule >>= putName name
putModuleAnew :: (ModuVerse m, MonadVerbosity m) => S.ModuleName -> m PathKey
putModuleAnew name =
do key <- pathKey (modulePathBase "hs" name)
loadModule key >>= putName name
return key
findModule :: (ModuVerse m, MonadVerbosity m) => S.ModuleName -> m (Maybe ModuleInfo)
findModule name = pathKeyMaybe (modulePathBase "hs" name) >>= parseModuleMaybe
delName :: ModuVerse m => S.ModuleName -> m ()
delName name = modifyModuVerse (\ s -> s { moduleNames_ = Just (Map.delete name (fromMaybe Map.empty (moduleNames_ s)))
, moduleInfo_ = Map.empty })
class (MonadIO m, MonadBaseControl IO m, Functor m) => ModuVerse m where
getModuVerse :: m ModuVerseState
modifyModuVerse :: (ModuVerseState -> ModuVerseState) -> m ()
getExtensions :: ModuVerse m => m [Extension]
getExtensions = getModuVerse >>= return . extensions_
modifyExtensions :: ModuVerse m => ([Extension] -> [Extension]) -> m ()
modifyExtensions f = modifyModuVerse (\ s -> s {extensions_ = f (extensions_ s)})
instance ModuVerse m => SourceDirs m where
putDirs xs = modifyModuVerse (\ s -> s {sourceDirs_ = xs})
getDirs = getModuVerse >>= return . sourceDirs_
parseModule :: (ModuVerse m, MonadVerbosity m) => PathKey -> m ModuleInfo
parseModule key = parseModuleMaybe (Just key) >>= maybe (error $ "parseModule - not found: " ++ show key) return
parseModuleMaybe :: (ModuVerse m, MonadVerbosity m) => Maybe PathKey -> m (Maybe ModuleInfo)
parseModuleMaybe Nothing = return Nothing
parseModuleMaybe (Just key) =
(look >>= load) `IO.catch` (\ (e :: IOError) -> if isDoesNotExistError e || isUserError e then return Nothing else throw e)
where
look =
do verse <- getModuVerse
return $ Map.lookup key (moduleInfo_ verse)
load (Just x) = return (Just x)
load Nothing = Just <$> loadModule key
loadModule :: (ModuVerse m, MonadVerbosity m) => PathKey -> m ModuleInfo
loadModule key =
do text <- liftIO $ readFile (unPathKey key)
quietly $ qLnPutStr ("parsing " ++ unPathKey key)
(parsed, comments) <- parseFileWithComments (unPathKey key) >>= return . Exts.fromParseResult
modifyModuVerse (\ x -> x {moduleInfo_ = Map.insert key (ModuleInfo parsed text comments key) (moduleInfo_ x)})
return (ModuleInfo parsed text comments key)
unloadModule :: (ModuVerse m, MonadVerbosity m) => PathKey -> m ()
unloadModule key =
modifyModuVerse (\ x -> x {moduleInfo_ = Map.delete key (moduleInfo_ x)})
parseFileWithComments :: ModuVerse m => FilePath -> m (Exts.ParseResult (A.Module SrcSpanInfo, [Comment]))
parseFileWithComments path =
liftIO (A.parseFileWithComments mode path)
where
mode = Exts.defaultParseMode {Exts.extensions = hseExtensions, Exts.parseFilename = path, Exts.fixities = Nothing }