From fbdfa42cec6cf1bc489715f4cad4c07c81b81191 Mon Sep 17 00:00:00 2001 From: Gabriel Gonzalez Date: Fri, 31 Mar 2017 11:48:45 -0700 Subject: [PATCH] Add support for importing paths as raw `Text` Part of #23 You can now add ` as Text` to the end of any path and the raw contents at that path will be imported as a raw `Text` literal. For example: ``` $ dhall <<< "http://example.com as Text" Text "\n\n\n Example Domain\n\n \n \n \n \n\n\n\n
\n

Example Domain\n

This domain is established to be used for illustrative examples in d ocuments. You may use this\n domain in examples without prior coordination or asking for permission.

\n

More information...

\n

\n\n\n" ``` --- src/Dhall/Core.hs | 41 +++++-- src/Dhall/Import.hs | 280 +++++++++++++++++++++++++------------------- src/Dhall/Parser.hs | 22 ++-- 3 files changed, 202 insertions(+), 141 deletions(-) diff --git a/src/Dhall/Core.hs b/src/Dhall/Core.hs index 6eeef8ef8..35aed9bf1 100644 --- a/src/Dhall/Core.hs +++ b/src/Dhall/Core.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wall #-} {-| This module contains the core calculus for the Dhall language. @@ -18,6 +19,8 @@ module Dhall.Core ( -- * Syntax Const(..) , HasHome(..) + , PathType(..) + , PathMode(..) , Path(..) , Var(..) , Expr(..) @@ -89,8 +92,8 @@ instance Buildable Const where -- | Whether or not a path is relative to the user's home directory data HasHome = Home | Homeless deriving (Eq, Ord, Show) --- | Path to an external resource -data Path +-- | The type of path to import (i.e. local vs. remote vs. environment) +data PathType = File HasHome FilePath -- ^ Local path | URL Text @@ -99,7 +102,7 @@ data Path -- ^ Environment variable deriving (Eq, Ord, Show) -instance Buildable Path where +instance Buildable PathType where build (File Home file) = "~/" <> build txt where @@ -116,6 +119,22 @@ instance Buildable Path where build (URL str ) = build str <> " " build (Env env ) = "env:" <> build env +-- | How to interpret the path's contents (i.e. as Dhall code or raw text) +data PathMode = Code | RawText deriving (Eq, Ord, Show) + +-- | Path to an external resource +data Path = Path + { pathType :: PathType + , pathMode :: PathMode + } deriving (Eq, Ord, Show) + +instance Buildable Path where + build (Path {..}) = build pathType <> suffix + where + suffix = case pathMode of + RawText -> " as Text" + Code -> "" + {-| Label for a bound variable The `Text` field is the variable's name (i.e. \"@x@\"). diff --git a/src/Dhall/Import.hs b/src/Dhall/Import.hs index 8452a66c1..311d7b364 100644 --- a/src/Dhall/Import.hs +++ b/src/Dhall/Import.hs @@ -72,12 +72,35 @@ > { bar : Text, baz : ∀(x : Bool) → Bool, foo : Integer } > > { bar = "Hi", baz = λ(x : Bool) → x == False, foo = 1 } + + If you wish to import the raw contents of a path as @Text@ then add + @as Text@ to the end of the import: + + > $ dhall <<< "http://example.com as Text" + > Text + > + > "\n\n\n Example Domain\n\n charset=\"utf-8\" />\n ; charset=utf-8\" />\n initial-scale=1\" />\n \n\n\n\n
\n

Example Domain h1>\n

This domain is established to be used for illustrative examples in d + > ocuments. You may use this\n domain in examples without prior coordination or + > asking for permission.

\n

e\">More information...

\n

\n\n\n" -} module Dhall.Import ( -- * Import - exprFromFile - , exprFromURL + exprFromPath , load , Cycle(..) , ReferentiallyOpaque(..) @@ -104,7 +127,8 @@ import Data.Traversable (traverse) #endif import Data.Typeable (Typeable) import Filesystem.Path ((), FilePath) -import Dhall.Core (Expr, HasHome(..), Path(..)) +import Dhall.Core + (Expr(..), HasHome(..), PathMode(..), PathType(..), Path(..)) import Dhall.Parser (Parser(..), ParseError(..), Src) import Dhall.TypeCheck (X(..)) #if MIN_VERSION_http_client(0,5,0) @@ -282,7 +306,7 @@ data Status = Status } canonicalizeAll :: [Path] -> [Path] -canonicalizeAll = map canonicalize . List.tails +canonicalizeAll = map canonicalizePath . List.tails stack :: Lens' Status [Path] stack k s = fmap (\x -> s { _stack = x }) (k (_stack s)) @@ -329,7 +353,7 @@ needManager = do `Text` for O(1) access to the end of the string. The only reason we use `String` at all is for consistency with the @http-client@ library. -} -canonicalize :: [Path] -> Path +canonicalize :: [PathType] -> PathType canonicalize [] = File Homeless "." canonicalize (File hasHome0 file0:paths0) = if Filesystem.relative file0 && hasHome0 == Homeless @@ -372,6 +396,18 @@ canonicalize (File hasHome0 file0:paths0) = canonicalize (URL path:_) = URL path canonicalize (Env env :_) = Env env +canonicalizePath :: [Path] -> Path +canonicalizePath [] = + Path + { pathMode = Code + , pathType = canonicalize [] + } +canonicalizePath (path:paths) = + Path + { pathMode = pathMode path + , pathType = canonicalize (map pathType (path:paths)) + } + parentURL :: Text -> Text parentURL = Text.dropWhileEnd (/= '/') @@ -395,107 +431,119 @@ clean = strip . Filesystem.collapse Nothing -> p Just p' -> p' --- | Parse an expression from a `FilePath` containing a Dhall program -exprFromFile :: FilePath -> IO (Expr Src Path) -exprFromFile path = do - let string = Filesystem.Path.CurrentOS.encodeString path - - -- Unfortunately, GHC throws an `InappropriateType` exception when trying to - -- to read a directory, but does not export the exception, so I must resort - -- to a more heavy-handed `catch` - let handler :: IOException -> IO (Result (Expr Src Path)) - handler e = do - let string' = Filesystem.Path.CurrentOS.encodeString (path "@") - - -- If the fallback fails, reuse the original exception to avoid user - -- confusion - Text.Trifecta.parseFromFileEx parser string' `onException` throwIO e - - exists <- Filesystem.isFile path - if exists - then return () - else Control.Exception.throwIO MissingFile - - x <- Text.Trifecta.parseFromFileEx parser string `catch` handler - case x of - Failure errInfo -> throwIO (ParseError (Text.Trifecta._errDoc errInfo)) - Success expr -> return expr - where - parser = unParser (do - Text.Parser.Token.whiteSpace - r <- Dhall.Parser.expr - Text.Parser.Combinators.eof - return r ) - --- | Parse an expression from a URL hosting a Dhall program -exprFromURL :: Manager -> Text -> IO (Expr Src Path) -exprFromURL m url = do - request <- HTTP.parseUrlThrow (Text.unpack url) - - let handler :: HTTP.HttpException -> IO (HTTP.Response ByteString) +-- | Parse an expression from a `Path` containing a Dhall program +exprFromPath :: Manager -> Path -> IO (Expr Src Path) +exprFromPath m (Path {..}) = case pathType of + File hasHome file -> do + path <- case hasHome of + Home -> do + home <- liftIO Filesystem.getHomeDirectory + return (home file) + Homeless -> do + return file + + case pathMode of + Code -> do + exists <- Filesystem.isFile path + if exists + then return () + else Control.Exception.throwIO MissingFile + + let string = Filesystem.Path.CurrentOS.encodeString path + + -- Unfortunately, GHC throws an `InappropriateType` exception + -- when trying to read a directory, but does not export the + -- exception, so I must resort to a more heavy-handed `catch` + let handler :: IOException -> IO (Result (Expr Src Path)) + handler e = do + let string' = + Filesystem.Path.CurrentOS.encodeString + (path "@") + + -- If the fallback fails, reuse the original exception + -- to avoid user confusion + Text.Trifecta.parseFromFileEx parser string' + `onException` throwIO e + + x <- Text.Trifecta.parseFromFileEx parser string `catch` handler + case x of + Failure errInfo -> do + throwIO (ParseError (Text.Trifecta._errDoc errInfo)) + Success expr -> do + return expr + RawText -> do + text <- Filesystem.readTextFile path + return (TextLit (build text)) + URL url -> do + request <- HTTP.parseUrlThrow (Text.unpack url) + + let handler :: HTTP.HttpException -> IO (HTTP.Response ByteString) #if MIN_VERSION_http_client(0,5,0) - handler err@(HttpExceptionRequest _ (StatusCodeException _ _)) = do + handler err@(HttpExceptionRequest _ (StatusCodeException _ _)) = do #else - handler err@(StatusCodeException _ _ _) = do + handler err@(StatusCodeException _ _ _) = do #endif - let request' = request { HTTP.path = HTTP.path request <> "/@" } - -- If the fallback fails, reuse the original exception to avoid user - -- confusion - HTTP.httpLbs request' m `onException` throwIO (PrettyHttpException err) - handler err = throwIO (PrettyHttpException err) - response <- HTTP.httpLbs request m `catch` handler - - let bytes = HTTP.responseBody response - - text <- case Data.Text.Lazy.Encoding.decodeUtf8' bytes of - Left err -> throwIO err - Right text -> return text - - let urlBytes = Data.Text.Lazy.Encoding.encodeUtf8 url - let delta = Directed (Data.ByteString.Lazy.toStrict urlBytes) 0 0 0 0 - case Text.Trifecta.parseString parser delta (Text.unpack text) of - Failure err -> do - -- Also try the fallback in case of a parse error, since the parse - -- error might signify that this URL points to a directory list - let err' = ParseError (Text.Trifecta._errDoc err) - - request' <- HTTP.parseUrlThrow (Text.unpack url) - - let request'' = request' { HTTP.path = HTTP.path request' <> "/@" } - response' <- HTTP.httpLbs request'' m `onException` throwIO err' - - let bytes' = HTTP.responseBody response' - - text' <- case Data.Text.Lazy.Encoding.decodeUtf8' bytes' of - Left _ -> throwIO err' - Right text' -> return text' - - case Text.Trifecta.parseString parser delta (Text.unpack text') of - Failure _ -> throwIO err' - Success expr -> return expr - Success expr -> return expr - where - parser = unParser (do - Text.Parser.Token.whiteSpace - r <- Dhall.Parser.expr - Text.Parser.Combinators.eof - return r ) - --- | Parse an expression from an environment variable -exprFromEnv :: Text -> IO (Expr Src Path) -exprFromEnv env = do - m <- System.Environment.lookupEnv (Text.unpack env) - case m of - Just str -> do - let envBytes = Data.Text.Lazy.Encoding.encodeUtf8 env - let delta = - Directed (Data.ByteString.Lazy.toStrict envBytes) 0 0 0 0 - case Text.Trifecta.parseString parser delta str of - Failure errInfo -> do - throwIO (ParseError (Text.Trifecta._errDoc errInfo)) - Success expr -> do - return expr - Nothing -> throwIO (MissingEnvironmentVariable env) + let request' = request { HTTP.path = HTTP.path request <> "/@" } + -- If the fallback fails, reuse the original exception to avoid + -- user confusion + HTTP.httpLbs request' m `onException` throwIO (PrettyHttpException err) + handler err = throwIO (PrettyHttpException err) + response <- HTTP.httpLbs request m `catch` handler + + let bytes = HTTP.responseBody response + + text <- case Data.Text.Lazy.Encoding.decodeUtf8' bytes of + Left err -> throwIO err + Right text -> return text + + case pathMode of + Code -> do + let urlBytes = Data.Text.Lazy.Encoding.encodeUtf8 url + let delta = + Directed (Data.ByteString.Lazy.toStrict urlBytes) 0 0 0 0 + case Text.Trifecta.parseString parser delta (Text.unpack text) of + Failure err -> do + -- Also try the fallback in case of a parse error, since + -- the parse error might signify that this URL points to + -- a directory list + let err' = ParseError (Text.Trifecta._errDoc err) + + request' <- HTTP.parseUrlThrow (Text.unpack url) + + let request'' = + request' + { HTTP.path = HTTP.path request' <> "/@" } + response' <- HTTP.httpLbs request'' m + `onException` throwIO err' + + let bytes' = HTTP.responseBody response' + + text' <- case Data.Text.Lazy.Encoding.decodeUtf8' bytes' of + Left _ -> throwIO err' + Right text' -> return text' + + case Text.Trifecta.parseString parser delta (Text.unpack text') of + Failure _ -> throwIO err' + Success expr -> return expr + Success expr -> return expr + RawText -> do + return (TextLit (build text)) + Env env -> do + x <- System.Environment.lookupEnv (Text.unpack env) + case x of + Just str -> do + case pathMode of + Code -> do + let envBytes = Data.Text.Lazy.Encoding.encodeUtf8 env + let delta = + Directed (Data.ByteString.Lazy.toStrict envBytes) 0 0 0 0 + case Text.Trifecta.parseString parser delta str of + Failure errInfo -> do + throwIO (ParseError (Text.Trifecta._errDoc errInfo)) + Success expr -> do + return expr + RawText -> return (TextLit (build str)) + Nothing -> throwIO (MissingEnvironmentVariable env) where parser = unParser (do Text.Parser.Token.whiteSpace @@ -514,37 +562,25 @@ loadDynamic p = do let handler :: SomeException -> IO (Expr Src Path) handler e = throwIO (Imported (p:paths) e) - case canonicalize (p:paths) of - File hasHome file -> do - path <- case hasHome of - Home -> do - home <- liftIO Filesystem.getHomeDirectory - return (home file) - Homeless -> do - return file - liftIO (exprFromFile path `catch` handler) - URL url -> do - m <- needManager - liftIO (exprFromURL m url `catch` handler) - Env env -> do - liftIO (exprFromEnv env `catch` handler) + m <- needManager + liftIO (exprFromPath m (canonicalizePath (p:paths)) `catch` handler) -- | Load a `Path` as a \"static\" expression (with all imports resolved) loadStatic :: Path -> StateT Status IO (Expr Src X) loadStatic path = do paths <- zoom stack State.get - let local (URL url ) = case HTTP.parseUrlThrow (Text.unpack url) of + let local (Path (URL url ) _) = case HTTP.parseUrlThrow (Text.unpack url) of Nothing -> False Just request -> case HTTP.host request of "127.0.0.1" -> True "localhost" -> True _ -> False - local (File _ _) = True - local (Env _ ) = True + local (Path (File _ _) _) = True + local (Path (Env _ ) _) = True - let parent = canonicalize paths - let here = canonicalize (path:paths) + let parent = canonicalizePath paths + let here = canonicalizePath (path:paths) if local here && not (local parent) then liftIO (throwIO (Imported paths (ReferentiallyOpaque path))) diff --git a/src/Dhall/Parser.hs b/src/Dhall/Parser.hs index 495658139..e4448dcab 100644 --- a/src/Dhall/Parser.hs +++ b/src/Dhall/Parser.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -- | This module contains Dhall's parsing logic @@ -29,7 +30,7 @@ import Data.Text.Lazy (Text) import Data.Text.Lazy.Builder (Builder) import Data.Typeable (Typeable) import Data.Vector (Vector) -import Dhall.Core (Const(..), Expr(..), HasHome(..), Path(..), Var(..)) +import Dhall.Core import Prelude hiding (const, pi) import Text.PrettyPrint.ANSI.Leijen (Doc) import Text.Parser.Combinators (choice, try, ()) @@ -50,7 +51,6 @@ import qualified Data.Text.Lazy import qualified Data.Text.Lazy.Builder import qualified Data.Text.Lazy.Encoding import qualified Data.Vector -import qualified Dhall.Core import qualified Filesystem.Path.CurrentOS import qualified Text.Parser.Char import qualified Text.Parser.Combinators @@ -127,6 +127,7 @@ identifierStyle = IdentifierStyle , "if" , "then" , "else" + , "as" , "Natural" , "Natural/fold" , "Natural/build" @@ -724,11 +725,16 @@ listLit embedded = do import_ :: Parser Path import_ = do - a <- file <|> url <|> env + pathType <- file <|> url <|> env Text.Parser.Token.whiteSpace - return a - -file :: Parser Path + let rawText = do + _ <- reserve "as" + _ <- reserve "Text" + return RawText + pathMode <- rawText <|> pure Code + return (Path {..}) + +file :: Parser PathType file = try (token file0) <|> token file1 <|> token file2 @@ -758,7 +764,7 @@ file = try (token file0) b <- many (Text.Parser.Char.satisfy (not . Data.Char.isSpace)) return (File Home (Filesystem.Path.CurrentOS.decodeString b)) -url :: Parser Path +url :: Parser PathType url = try url0 <|> url1 where @@ -772,7 +778,7 @@ url = try url0 b <- many (Text.Parser.Char.satisfy (not . Data.Char.isSpace)) return (URL (Data.Text.Lazy.pack (a <> b))) -env :: Parser Path +env :: Parser PathType env = do _ <- Text.Parser.Char.string "env:" a <- many (Text.Parser.Char.satisfy (not . Data.Char.isSpace))