-
Notifications
You must be signed in to change notification settings - Fork 33
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
Showing
20 changed files
with
669 additions
and
146 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,68 @@ | ||
# HLint configuration file | ||
# https://github.com/ndmitchell/hlint | ||
########################## | ||
|
||
# This file contains a template configuration file, which is typically | ||
# placed as .hlint.yaml in the root of your project | ||
|
||
|
||
# Specify additional command line arguments | ||
# | ||
# - arguments: [--color, --cpp-simple, -XQuasiQuotes] | ||
|
||
|
||
# Control which extensions/flags/modules/functions can be used | ||
# | ||
# - extensions: | ||
# - default: false # all extension are banned by default | ||
# - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used | ||
# - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module | ||
# | ||
# - flags: | ||
# - {name: -w, within: []} # -w is allowed nowhere | ||
# | ||
# - modules: | ||
# - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set' | ||
# - {name: Control.Arrow, within: []} # Certain modules are banned entirely | ||
# | ||
# - functions: | ||
# - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules | ||
|
||
|
||
# Add custom hints for this project | ||
# | ||
# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar" | ||
# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x} | ||
|
||
# The hints are named by the string they display in warning messages. | ||
# For example, if you see a warning starting like | ||
# | ||
# Main.hs:116:51: Warning: Redundant == | ||
# | ||
# You can refer to that hint with `{name: Redundant ==}` (see below). | ||
|
||
# Turn on hints that are off by default | ||
# | ||
# Ban "module X(module X) where", to require a real export list | ||
# - warn: {name: Use explicit module export list} | ||
# | ||
# Replace a $ b $ c with a . b $ c | ||
# - group: {name: dollar, enabled: true} | ||
# | ||
# Generalise map to fmap, ++ to <> | ||
# - group: {name: generalise, enabled: true} | ||
|
||
|
||
# Ignore some builtin hints | ||
# - ignore: {name: Use let} | ||
# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules | ||
- ignore: {name: Use fmap, within: Grace.Parser} | ||
- ignore: {name: Use <$>, within: Grace.Parser} | ||
|
||
|
||
# Define some custom infix operators | ||
# - fixity: infixr 3 ~^#^~ | ||
|
||
|
||
# To generate a suitable file for HLint do: | ||
# $ hlint --default > .hlint.yaml |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,124 @@ | ||
{-# LANGUAGE BlockArguments #-} | ||
{-# LANGUAGE DataKinds #-} | ||
{-# LANGUAGE DerivingStrategies #-} | ||
{-# LANGUAGE FlexibleContexts #-} | ||
{-# LANGUAGE LambdaCase #-} | ||
{-# LANGUAGE OverloadedStrings #-} | ||
{-# LANGUAGE ViewPatterns #-} | ||
|
||
{- | This module contains the functions and types that power to URI-base imports | ||
-} | ||
|
||
module Grace.Import | ||
( Input(..) | ||
, Resolver(..) | ||
, resolverToCallback | ||
, ImportError(..) | ||
) where | ||
|
||
import Control.Exception.Safe (Exception(..), throw) | ||
import Data.List.NonEmpty (NonEmpty(..)) | ||
import Data.Text (Text) | ||
import Grace.Location (Location) | ||
import Grace.Pretty (Pretty(..)) | ||
import Grace.Syntax (Syntax) | ||
import System.FilePath ((</>)) | ||
|
||
import qualified Data.Text as Text | ||
import qualified System.FilePath as FilePath | ||
import qualified Text.URI as URI | ||
|
||
{-| Input to the interpreter. | ||
You should prefer to use `Path` if possible (for better error messages and | ||
correctly handling transitive imports). The `Code` constructor is intended | ||
for cases like interpreting code read from standard input. | ||
-} | ||
data Input | ||
= Path FilePath | ||
-- ^ The path to the code | ||
| Code String Text | ||
-- ^ Source code: @Code name content@ | ||
| URI URI.URI | ||
deriving (Eq, Show) | ||
|
||
instance Semigroup Input where | ||
_ <> URI uri = URI uri | ||
|
||
_ <> Code name code = Code name code | ||
|
||
Code _ _ <> Path child = Path child | ||
Path parent <> Path child = Path (FilePath.takeDirectory parent </> child) | ||
URI parent <> Path child | ||
| FilePath.isRelative child | ||
, Just uri <- URI.relativeTo childURI parent = | ||
URI uri | ||
| otherwise = | ||
Path child | ||
where | ||
uriPath = do | ||
c : cs <- traverse (URI.mkPathPiece . Text.pack) (FilePath.splitPath child) | ||
|
||
return (FilePath.hasTrailingPathSeparator child, c :| cs) | ||
|
||
childURI = | ||
URI.URI | ||
{ URI.uriScheme = Nothing | ||
, URI.uriAuthority = Left False | ||
, URI.uriPath = uriPath | ||
, URI.uriQuery = [] | ||
, URI.uriFragment = Nothing | ||
} | ||
|
||
instance Pretty Input where | ||
pretty (Code _ code) = pretty code | ||
pretty (Path path) = pretty path | ||
pretty (URI uri) = pretty uri | ||
|
||
{- | A resolver for an URI. | ||
When the interpreter tries to resolve an URI pointing to some source code | ||
it will try multiple resolvers sequentially and stops if one returns a | ||
@Just code@ value where @code@ is the source code of an expression. | ||
It will then try to parse and interpret that expression. | ||
Here are some good practices for the development of resolvers: | ||
* A resolver should handle exactly one URI scheme. | ||
* If a resolver encounters an URI which it cannot process (e.g. a | ||
@file://@ URI is passed to a HTTP resolver) it should return @Nothing@ | ||
as fast as possible. | ||
* Exceptions thrown in resolvers will be caught and rethrown as an | ||
`ImportError` by the interpreter. | ||
-} | ||
newtype Resolver = Resolver | ||
{ runResolver :: Input -> IO (Maybe (Syntax Location Input)) | ||
} | ||
|
||
instance Semigroup Resolver where | ||
x <> y = Resolver \uri -> do | ||
maybeResult <- runResolver x uri | ||
case maybeResult of | ||
Nothing -> runResolver y uri | ||
_ -> return maybeResult | ||
|
||
instance Monoid Resolver where | ||
mempty = Resolver (const (return Nothing)) | ||
|
||
-- | Convert a resolver to a callback function | ||
resolverToCallback :: Resolver -> Input -> IO (Syntax Location Input) | ||
resolverToCallback resolver uri = do | ||
maybeResult <- runResolver resolver uri | ||
case maybeResult of | ||
Nothing -> throw UnsupportedInput | ||
Just result -> return result | ||
|
||
-- | Errors that might be raised during import resolution. | ||
data ImportError | ||
= UnsupportedInput | ||
deriving stock Show | ||
|
||
instance Exception ImportError where | ||
displayException UnsupportedInput = "Resolving this input is not supported" |
Oops, something went wrong.