148 lines
5.1 KiB
Haskell
148 lines
5.1 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE DerivingStrategies #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
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.List.NonEmpty as NonEmpty
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.IO as Text.IO
|
|
|
|
import qualified System.Directory as IO
|
|
|
|
import Text.Parsec (sepBy1, ParsecT, anyChar, many, char, choice, notFollowedBy, oneOf)
|
|
import qualified Text.Parsec as Parsec
|
|
|
|
import Path as Path ( Path, File, parseRelFile, Rel, parseRelDir, Dir, Abs, (</>), fromAbsFile, fromRelFile )
|
|
|
|
import Ubc.Parse.Syntax (Transformer, Token)
|
|
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 :: Maybe Token
|
|
, list :: [Token]
|
|
}
|
|
deriving stock (Show)
|
|
|
|
importPath :: Monad m => ParsecT Token u m (NonEmpty Token)
|
|
importPath = UbcLanguage.angles (many importChar `sepBy1` char '/')
|
|
<&> NonEmpty.fromList . List.map Text.pack
|
|
|
|
importChar :: (Monad m) => ParsecT Token u m Char
|
|
importChar = choice
|
|
[ char '\\' >> oneOf ">/\\"
|
|
, notFollowedBy (oneOf ">/") >> anyChar
|
|
]
|
|
|
|
parse :: ParsecT Token u Transformer Import
|
|
parse = do
|
|
UbcLanguage.reserved "import"
|
|
fragments <- importPath
|
|
|
|
-- 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 or parse
|
|
importedFile <- case existingFiles of
|
|
[] -> fail . Text.unpack $ notFoundMessage relFile possiblePaths
|
|
[path] -> parseFile path
|
|
fs@_ -> fail . Text.unpack $ multipleFoundMessage relFile fs
|
|
|
|
importAs <- Parsec.optionMaybe importAlias
|
|
|
|
importList <- UbcLanguage.parens $ UbcLanguage.commaSeparated UbcLanguage.identifier
|
|
|
|
return $ Import importedFile importAs importList
|
|
|
|
importAlias :: Monad m => ParsecT Token u m Token
|
|
importAlias = UbcLanguage.reserved "as"
|
|
*> UbcLanguage.identifier
|
|
|
|
multipleFoundMessage :: Path Rel File -> [Path Abs File] -> Token
|
|
multipleFoundMessage relFile foundFiles = "Could not identify imported file " <> Text.pack (Path.fromRelFile relFile) <> "\n"
|
|
<> "Found multiple files in the search path:"
|
|
<> (Text.unlines . List.map (Path.fromAbsFile >>> ('\t':) >>> Text.pack) $ foundFiles)
|
|
|
|
notFoundMessage :: Path Rel File -> [Path Abs File] -> Token
|
|
notFoundMessage relFile searchedLocations = "Could not locate import file <" <> Text.pack (Path.fromRelFile relFile) <> ">\n"
|
|
<> "Searched locations were:\n"
|
|
<> (Text.unlines . List.map (Path.fromAbsFile >>> ('\t':) >>> Text.pack) $ searchedLocations)
|
|
|
|
parseFile :: Path Abs File -> ParsecT Token u Transformer File.File
|
|
parseFile path = do
|
|
let stringPath = Path.fromAbsFile path
|
|
contents <- liftIO . Text.IO.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
|
|
|
|
-- disable backtracking (consuming input)
|
|
Parsec.setInput "_" <* Parsec.char '_'
|
|
|
|
-- prepare new state
|
|
Parsec.setInput contents
|
|
Parsec.setPosition newPosition
|
|
|
|
-- parse the file
|
|
importedFile <- File.parse <* Parsec.eof
|
|
|
|
-- restore old state
|
|
Parsec.setInput oldInput
|
|
Parsec.setPosition oldPosition
|
|
|
|
pure importedFile
|
|
|
|
parseRelPath :: MonadThrow m => NonEmpty Token -> m (Path Rel File)
|
|
parseRelPath fragments = do
|
|
name <- Path.parseRelFile . Text.unpack $ NonEmpty.last fragments
|
|
dirPath <- mapM (Path.parseRelDir . Text.unpack) . 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
|
|
|