134 lines
4.7 KiB
Haskell
134 lines
4.7 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE DerivingStrategies #-}
|
|
module Ubc.Parse.Syntax.Import
|
|
( parse
|
|
, Import(..)
|
|
)
|
|
where
|
|
|
|
import Control.Arrow ((>>>))
|
|
|
|
import Control.Monad (filterM)
|
|
import Control.Monad.Catch ( MonadThrow, )
|
|
import Control.Monad.Trans (lift, MonadIO (liftIO))
|
|
import Control.Monad.Trans.Except ()
|
|
import Control.Monad.Trans.Reader (asks, ReaderT)
|
|
|
|
import Data.Functor ((<&>))
|
|
|
|
import Data.List.NonEmpty (NonEmpty)
|
|
import qualified Data.List as List
|
|
import qualified Data.Set as Set
|
|
import qualified Data.List.NonEmpty as NonEmpty
|
|
|
|
import qualified System.Directory as IO
|
|
|
|
import Text.Parsec (sepBy1, ParsecT, anyChar, many, char, choice, notFollowedBy, oneOf, option)
|
|
import qualified Text.Parsec as Parsec
|
|
|
|
import Path as Path ( Path, File, parseRelFile, Rel, parseRelDir, Dir, Abs, (</>), fromAbsFile, fromRelFile )
|
|
|
|
import Ubc.Parse.Syntax (Transformer)
|
|
import Ubc.Parse.Syntax.Config (Config)
|
|
import qualified Ubc.Parse.Syntax.Config as Config
|
|
import qualified Ubc.Parse.Syntax.File as File
|
|
import qualified Ubc.Parse.Syntax.Language as UbcLanguage
|
|
|
|
data Import = Import
|
|
{ file :: File.File
|
|
, alias :: String
|
|
}
|
|
deriving stock (Show)
|
|
|
|
importPath :: Monad m => ParsecT String u m (NonEmpty String)
|
|
importPath = UbcLanguage.angles (many importChar `sepBy1` char '/')
|
|
<&> NonEmpty.fromList
|
|
|
|
importChar :: (Monad m) => ParsecT String u m Char
|
|
importChar = choice
|
|
[ char '\\' >> oneOf ">/\\"
|
|
, notFollowedBy (oneOf ">/") >> anyChar
|
|
]
|
|
|
|
parse :: ParsecT String u Transformer Import
|
|
parse = do
|
|
UbcLanguage.reserved "import"
|
|
fragments <- importPath
|
|
importAs <- option (NonEmpty.last fragments) importAlias
|
|
|
|
-- concatenate directory and file parts, also utf-decoding
|
|
relFile <- case parseRelPath fragments of
|
|
Left err -> fail $ "Failed to decode path:\n" <> show err
|
|
Right relFile -> pure relFile
|
|
|
|
-- appended to all search directories
|
|
possiblePaths <- lift $ constructPaths relFile
|
|
-- only existing files
|
|
existingFiles <- liftIO $ filterInexistent possiblePaths
|
|
|
|
-- fail if there are multiple files
|
|
case existingFiles of
|
|
[] -> fail $ notFoundMessage relFile possiblePaths
|
|
[path] -> parseFile path importAs
|
|
fs@_ -> fail $ multipleFoundMessage relFile fs
|
|
|
|
importAlias :: Monad m => ParsecT String u m String
|
|
importAlias = UbcLanguage.reserved "as"
|
|
*> UbcLanguage.identifier
|
|
|
|
multipleFoundMessage :: Path Rel File -> [Path Abs File] -> String
|
|
multipleFoundMessage relFile foundFiles = "Could not identify imported file " <> Path.fromRelFile relFile <> "\n"
|
|
<> "Found multiple files in the search path:"
|
|
<> (unlines . List.map (Path.fromAbsFile >>> ('\t':)) $ foundFiles)
|
|
|
|
notFoundMessage :: Path Rel File -> [Path Abs File] -> String
|
|
notFoundMessage relFile searchedLocations = "Could not locate import file path" <> Path.fromRelFile relFile <> "\n"
|
|
<> "Searched locations were:"
|
|
<> (unlines . List.map (('\t':) . Path.fromAbsFile) $ searchedLocations)
|
|
|
|
parseFile :: Path Abs File -> String -> ParsecT String u Transformer Import
|
|
parseFile path importAs = do
|
|
let stringPath = Path.fromAbsFile path
|
|
contents <- liftIO . readFile $ stringPath
|
|
|
|
-- save old state
|
|
oldInput <- Parsec.getInput
|
|
oldPosition <- Parsec.getPosition
|
|
|
|
-- calculate new state
|
|
let newPosition = (flip Parsec.setSourceName) stringPath
|
|
>>> (flip Parsec.setSourceLine) 1
|
|
>>> (flip Parsec.setSourceColumn) 1
|
|
$ oldPosition
|
|
|
|
-- prepare new state
|
|
Parsec.setInput contents
|
|
Parsec.setPosition newPosition
|
|
importedFile <- File.parse stringPath
|
|
|
|
-- restore old state
|
|
Parsec.setInput oldInput
|
|
Parsec.setPosition oldPosition
|
|
|
|
pure $ Import importedFile importAs
|
|
|
|
parseRelPath :: MonadThrow m => NonEmpty FilePath -> m (Path Rel File)
|
|
parseRelPath fragments = do
|
|
name <- Path.parseRelFile $ NonEmpty.last fragments
|
|
dirPath <- mapM Path.parseRelDir . NonEmpty.init $ fragments
|
|
pure $ constructRelative name dirPath
|
|
|
|
constructRelative :: Path Rel t -> [Path Rel Dir] -> Path Rel t
|
|
constructRelative = foldr (</>)
|
|
|
|
filterInexistent :: [Path Abs File] -> IO [Path Abs File]
|
|
filterInexistent paths = filterM (IO.doesFileExist . Path.fromAbsFile) paths
|
|
|
|
constructPaths :: Monad m => Path Rel t -> ReaderT Config m [Path Abs t]
|
|
constructPaths suffix = do
|
|
paths <- asks Config.includePaths
|
|
Set.toList
|
|
>>> List.map (</> suffix)
|
|
>>> pure
|
|
$ paths
|
|
|