ehmry/dhall-haskell
ehmry/dhall-haskell
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Implement importing as Location (#1019)

Browse Source
This commit is contained in:
Fabrizio Ferrai 2019-07-01 07:00:14 +02:00 committed by Gabriel Gonzalez
parent 7647adba1a
commit 04d82120a4
6 changed files with 120 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
dhall/dhall-lang

@ -1 +1 @@
Subproject commit dbf4ebcfabf499e87c27e75bec108d91929ccc31
Subproject commit 61c6d3c74b516165e5673753a3ffa2acd69a67fd

3
dhall/src/Dhall/Binary.hs
View File

@ -476,7 +476,7 @@ instance ToTerm Import where
Just digest ->
TBytes ("\x12\x20" <> Data.ByteArray.convert digest)
m = TInt (case importMode of Code -> 0; RawText -> 1)
m = TInt (case importMode of Code -> 0; RawText -> 1; Location -> 2;)
Import {..} = import_
@ -785,6 +785,7 @@ instance FromTerm Import where
importMode <- case mode of
0 -> return Code
1 -> return RawText
2 -> return Location
_ -> empty
let remote scheme = do

8
dhall/src/Dhall/Core.hs
View File

@ -266,7 +266,8 @@ instance Pretty ImportType where
pretty Missing = "missing"
-- | How to interpret the import's contents (i.e. as Dhall code or raw text)
data ImportMode = Code | RawText deriving (Eq, Generic, Ord, Show)
data ImportMode = Code | RawText | Location
deriving (Eq, Generic, Ord, Show)
-- | A `ImportType` extended with an optional hash for semantic integrity checks
data ImportHashed = ImportHashed
@ -299,8 +300,9 @@ instance Pretty Import where
where
suffix :: Text
suffix = case importMode of
RawText -> " as Text"
Code -> ""
RawText -> " as Text"
Location -> " as Location"
Code -> ""
{-| Label for a bound variable

150
dhall/src/Dhall/Import.hs
View File

@ -602,93 +602,93 @@ getCacheDirectory = alternative₀ <|> alternative₁
exprFromUncachedImport :: Import -> StateT (Status IO) IO Resolved
exprFromUncachedImport import_@(Import {..}) = do
let ImportHashed {..} = importHashed
let resolveImport importType' = case importType' of
Local prefix file -> liftIO $ do
path <- localToPath prefix file
exists <- Directory.doesFileExist path
(path, text, newImport) <- case importType of
Local prefix file -> liftIO $ do
path <- localToPath prefix file
exists <- Directory.doesFileExist path
if exists
then return ()
else throwMissingImport (MissingFile path)
if exists
then return ()
else throwMissingImport (MissingFile path)
text <- Data.Text.IO.readFile path
text <- Data.Text.IO.readFile path
return (path, text, import_)
return (path, text, import_)
Remote url@URL { headers = maybeHeadersExpression } -> do
maybeHeadersAndExpression <- case maybeHeadersExpression of
Nothing -> do
return Nothing
Just headersExpression -> do
expr <- loadWith headersExpression
Remote url@URL { headers = maybeHeadersExpression } -> do
maybeHeadersAndExpression <- case maybeHeadersExpression of
Nothing -> do
return Nothing
Just headersExpression -> do
expr <- loadWith headersExpression
let expected :: Expr Src X
expected =
App List
( Record
( Dhall.Map.fromList
[("header", Text), ("value", Text)]
)
)
let suffix_ = Dhall.Pretty.Internal.prettyToStrictText expected
let annot = case expr of
Note (Src begin end bytes) _ ->
Note (Src begin end bytes') (Annot expr expected)
where
bytes' = bytes <> " : " <> suffix_
_ ->
Annot expr expected
let expected :: Expr Src X
expected =
App List
( Record
( Dhall.Map.fromList
[("header", Text), ("value", Text)]
)
)
let suffix_ = Dhall.Pretty.Internal.prettyToStrictText expected
let annot = case expr of
Note (Src begin end bytes) _ ->
Note (Src begin end bytes') (Annot expr expected)
where
bytes' = bytes <> " : " <> suffix_
_ ->
Annot expr expected
case Dhall.TypeCheck.typeOf annot of
Left err -> liftIO (throwIO err)
Right _ -> return ()
case Dhall.TypeCheck.typeOf annot of
Left err -> liftIO (throwIO err)
Right _ -> return ()
let expr' = Dhall.Core.normalize expr
let expr' = Dhall.Core.normalize expr
case toHeaders expr' of
Just headers -> do
return (Just (headers, expr'))
Nothing -> do
liftIO (throwIO InternalError)
case toHeaders expr' of
Just headers -> do
return (Just (headers, expr'))
Nothing -> do
liftIO (throwIO InternalError)
#ifdef MIN_VERSION_http_client
let maybeHeaders = fmap fst maybeHeadersAndExpression
let maybeHeaders = fmap fst maybeHeadersAndExpression
let newHeaders =
fmap (fmap absurd . snd) maybeHeadersAndExpression
let newHeaders =
fmap (fmap absurd . snd) maybeHeadersAndExpression
(path, text) <- fetchFromHttpUrl url maybeHeaders
(path, text) <- fetchFromHttpUrl url maybeHeaders
let newImport = Import
{ importHashed = ImportHashed
{ importType =
Remote (url { headers = newHeaders })
, ..
}
, ..
}
let newImport = Import
{ importHashed = ImportHashed
{ importType =
Remote (url { headers = newHeaders })
, ..
}
, ..
}
return (path, text, newImport)
return (path, text, newImport)
#else
let urlString = Text.unpack (Dhall.Core.pretty url)
let urlString = Text.unpack (Dhall.Core.pretty url)
liftIO (throwIO (CannotImportHTTPURL urlString mheaders))
liftIO (throwIO (CannotImportHTTPURL urlString mheaders))
#endif
Env env -> liftIO $ do
x <- System.Environment.lookupEnv (Text.unpack env)
case x of
Just string -> do
return (Text.unpack env, Text.pack string, import_)
Nothing -> do
throwMissingImport (MissingEnvironmentVariable env)
Env env -> liftIO $ do
x <- System.Environment.lookupEnv (Text.unpack env)
case x of
Just string -> do
return (Text.unpack env, Text.pack string, import_)
Nothing -> do
throwMissingImport (MissingEnvironmentVariable env)
Missing -> liftIO $ do
throwM (MissingImports [])
Missing -> liftIO $ do
throwM (MissingImports [])
case importMode of
Code -> do
(path, text, newImport) <- resolveImport importType
let parser = unParser $ do
Text.Parser.Token.whiteSpace
r <- Dhall.Parser.expr
@ -702,10 +702,30 @@ exprFromUncachedImport import_@(Import {..}) = do
return (Resolved {..})
RawText -> do
(_path, text, newImport) <- resolveImport importType
let resolvedExpression = TextLit (Chunks [] text)
return (Resolved {..})
Location -> do
let locationType = Union $ Dhall.Map.fromList
[ ("Environment", Just Text)
, ("Remote", Just Text)
, ("Local", Just Text)
, ("Missing", Nothing)
]
let resolvedExpression =
case importType of
Missing -> Field locationType "Missing"
local@(Local _ _) -> App (Field locationType "Local") (TextLit (Chunks [] (Dhall.Pretty.Internal.pretty local)))
remote@(Remote _) -> App (Field locationType "Remote") (TextLit (Chunks [] (Dhall.Pretty.Internal.pretty remote)))
Env env -> App (Field locationType "Environment") (TextLit (Chunks [] (Dhall.Pretty.Internal.pretty env)))
return (Resolved resolvedExpression import_)
-- | Default starting `Status`, importing relative to the given directory.
emptyStatus :: FilePath -> Status IO
emptyStatus = emptyStatusWith exprFromImport exprToImport

32
dhall/src/Dhall/Parser/Expression.hs
View File

@ -83,6 +83,21 @@ shallowDenote e = e
completeExpression :: Parser a -> Parser (Expr Src a)
completeExpression embedded = completeExpression_
where
Parsers {..} = parsers embedded
importExpression :: Parser a -> Parser (Expr Src a)
importExpression embedded = importExpression_
where
Parsers {..} = parsers embedded
data Parsers a = Parsers
{ completeExpression_ :: Parser (Expr Src a)
, importExpression_ :: Parser (Expr Src a)
}
parsers :: Parser a -> Parsers a
parsers embedded = Parsers {..}
where
completeExpression_ = do
whitespace
@ -226,8 +241,8 @@ completeExpression embedded = completeExpression_
applicationExpression = do
f <- (do _Some; return Some)
<|> return id
a <- noted importExpression
b <- Text.Megaparsec.many (noted importExpression)
a <- noted importExpression_
b <- Text.Megaparsec.many (noted importExpression_)
return (foldl app (f a) b)
where
app nL@(Note (Src before _ bytesL) _) nR@(Note (Src _ after bytesR) _) =
@ -235,7 +250,7 @@ completeExpression embedded = completeExpression_
app nL nR =
App nL nR
importExpression = noted (choice [ alternative0, alternative1 ])
importExpression_ = noted (choice [ alternative0, alternative1 ])
where
alternative0 = do
a <- embedded
@ -313,8 +328,8 @@ completeExpression embedded = completeExpression_
alternative07 = do
_merge
a <- importExpression
b <- importExpression <?> "second argument to ❰merge❱"
a <- importExpression_
b <- importExpression_ <?> "second argument to ❰merge❱"
return (Merge a b Nothing)
alternative09 = do
@ -717,7 +732,7 @@ http = do
whitespace
headers <- optional (do
_using
(completeExpression import_ <|> (_openParens *> completeExpression import_ <* _closeParens)) )
importExpression import_ )
return (Remote (url { headers }))
missing :: Parser ImportType
@ -759,9 +774,8 @@ import_ = (do
return (Import {..}) ) <?> "import"
where
alternative = do
_as
_Text
return RawText
_as
(_Text >> pure RawText) <|> (_Location >> pure Location)
-- | Similar to `Dhall.Core.renderChunks` except that this doesn't bother to
-- render interpolated expressions to avoid a `Buildable a` constraint. The

4
dhall/src/Dhall/Parser/Token.hs
View File

@ -63,6 +63,7 @@ module Dhall.Parser.Token (
_Type,
_Kind,
_Sort,
_Location,
_equal,
_or,
_plus,
@ -683,6 +684,9 @@ _Kind = reserved "Kind"
_Sort :: Parser ()
_Sort = reserved "Sort"
_Location :: Parser ()
_Location = reserved "Location"
_equal :: Parser ()
_equal = reservedChar '='