diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,101 @@ +1.2.0 + +* BREAKING CHANGE: Add support for customizing derived `Interpret` instances + * This is a breaking change to the Dhall library API since this changes the + signature of the `Interpret` class by replacing the `auto` method with a + more general `autoWith` method. This `autoWith` now takes an + `InterpretOptions` argument that lets you customize derived field and + constuctor names + * In practice user programs that use the common path will be unaffected by + this change + * This is not a breaking change to the Dhall language +* BREAKING CHANGE: Type annotations now bind more tightly than lambda + abstraction + * This is a breaking change to the Dhall language. An expression like this: + + ``` + λ(x : A) → y : B + ``` + + ... used to parenthesized implicitly as: + + ``` + (λ(x : A) → y) : T + ``` + + ... but is now parenthesized implicitly as: + + ``` + λ(x : A) → (y : T) + ``` + + This is now consistent with Haskell's precedence and also consistent with + the precedence of `List` and `Optional` type annotations + + * This change affects programs with an expression like this: + + ``` + -- Assuming that `y : B` + λ(x : A) → y : A → B + ``` + + The above program would type-check before this change but not type-check + after this change. You would you need to fix the above program by either + changing the type signature to annotate just the type of `y` like this: + + ``` + λ(x : A) → y : B + ``` + + ... or by adding explicit parentheses like this: + + ``` + (λ(x : A) → y) : A → B + ``` + + * This is not a breaking change to the Dhall library API +* BREAKING CHANGE: Add support for importing a path's contents as raw `Text` by + adding `as Text` after the import + * This is a breaking change to the Dhall language + * This is technically a breaking change, but is extremely unlikely to affect + you program. This only changes the behavior of old programs that had an + expression of the form: + + ``` + /some/imported/function as Text + ``` + + ... where `/some/imported/function` is an imported function being applied + to two arguments, the first of which is a bound variable named `as` and + the second of which is the type `Text` + * This is not a breaking change to the Dhall library API +* BREAKING CHANGE: Add support for importing environment variables using + `env:VAR` syntax + * This is a breaking change to the Dhall library API since it adds a new + `Path` constructor + * This also technically a breaking change to the Dhall language but + extremely unlikely to affect your program. This only changes the behavior + of old programs that had an expression of the form: + + ``` + env:VAR + ``` + + ... where `env` was the name of a bound variable and `:VAR` was a type + annotation without spaces around the type annotation operator + + After this change the program would be interpreted as an import of the + contents for the environment variable named `VAR` +* BREAKING CHANGE: Support importing paths relative to home directory using + `~/some/path` syntax + * This is a breaking change to the Dhall library API since it adds a new + field to the `File` constructor indicating whether or not the imported + path is relative to the home directory + * This is not a breaking change to the Dhall language and the new syntax + does not override any old syntax +* Permit trailing commas and bars in record/union syntax +* Improve location information for parsing errors + 1.1.0 * BREAKING CHANGE: Non-empty lists no longer require a type annotation diff --git a/dhall.cabal b/dhall.cabal --- a/dhall.cabal +++ b/dhall.cabal @@ -1,5 +1,5 @@ Name: dhall -Version: 1.1.0 +Version: 1.2.0 Cabal-Version: >=1.8.0.2 Build-Type: Simple Tested-With: GHC == 7.10.2, GHC == 8.0.1 diff --git a/src/Dhall.hs b/src/Dhall.hs --- a/src/Dhall.hs +++ b/src/Dhall.hs @@ -22,6 +22,9 @@ , Type , Interpret(..) , InvalidType(..) + , auto + , InterpretOptions(..) + , defaultInterpretOptions , bool , natural , integer @@ -29,6 +32,7 @@ , text , maybe , vector + , GenericInterpret(..) -- * Re-exports , Natural @@ -379,46 +383,80 @@ types. -} class Interpret a where - auto :: Type a - default auto :: (Generic a, GenericInterpret (Rep a)) => Type a - auto = fmap GHC.Generics.to genericAuto + autoWith:: InterpretOptions -> Type a + default autoWith + :: (Generic a, GenericInterpret (Rep a)) => InterpretOptions -> Type a + autoWith options = fmap GHC.Generics.to (genericAutoWith options) instance Interpret Bool where - auto = bool + autoWith _ = bool instance Interpret Natural where - auto = natural + autoWith _ = natural instance Interpret Integer where - auto = integer + autoWith _ = integer instance Interpret Double where - auto = double + autoWith _ = double instance Interpret Text where - auto = text + autoWith _ = text instance Interpret a => Interpret (Maybe a) where - auto = maybe auto + autoWith opts = maybe (autoWith opts) instance Interpret a => Interpret (Vector a) where - auto = vector auto + autoWith opts = vector (autoWith opts) +{-| Use the default options for interpreting a configuration file + +> auto = autoWith defaultInterpretOptions +-} +auto :: Interpret a => Type a +auto = autoWith defaultInterpretOptions + +{-| Use these options to tweak how Dhall derives a generic implementation of + `Interpret` +-} +data InterpretOptions = InterpretOptions + { fieldModifier :: Text -> Text + -- ^ Function used to transform Haskell field names into their corresponding + -- Dhall field names + , constructorModifier :: Text -> Text + -- ^ Function used to transform Haskell constructor names into their + -- corresponding Dhall alternative names + } + +{-| Default interpret options, which you can tweak or override, like this: + +> autoWith +> (defaultInterpretOptions { fieldModifier = Data.Text.Lazy.dropWhile (== '_') }) +-} +defaultInterpretOptions :: InterpretOptions +defaultInterpretOptions = InterpretOptions + { fieldModifier = id + , constructorModifier = id + } + +{-| This is the underlying class that powers the `Interpret` class's support + for automatically deriving a generic implementation +-} class GenericInterpret f where - genericAuto :: Type (f a) + genericAutoWith :: InterpretOptions -> Type (f a) instance GenericInterpret f => GenericInterpret (M1 D d f) where - genericAuto = fmap M1 genericAuto + genericAutoWith = fmap (fmap M1) genericAutoWith instance GenericInterpret V1 where - genericAuto = Type {..} + genericAutoWith _ = Type {..} where extract _ = Nothing expected = Union Data.Map.empty instance (Constructor c1, Constructor c2, GenericInterpret f1, GenericInterpret f2) => GenericInterpret (M1 C c1 f1 :+: M1 C c2 f2) where - genericAuto = Type {..} + genericAutoWith options@(InterpretOptions {..}) = Type {..} where nL :: M1 i c1 f1 a nL = undefined @@ -426,8 +464,8 @@ nR :: M1 i c2 f2 a nR = undefined - nameL = Data.Text.Lazy.pack (conName nL) - nameR = Data.Text.Lazy.pack (conName nR) + nameL = constructorModifier (Data.Text.Lazy.pack (conName nL)) + nameR = constructorModifier (Data.Text.Lazy.pack (conName nR)) extract (UnionLit name e _) | name == nameL = fmap (L1 . M1) (extractL e) @@ -438,16 +476,16 @@ expected = Union (Data.Map.fromList [(nameL, expectedL), (nameR, expectedR)]) - Type extractL expectedL = genericAuto - Type extractR expectedR = genericAuto + Type extractL expectedL = genericAutoWith options + Type extractR expectedR = genericAutoWith options instance (Constructor c, GenericInterpret (f :+: g), GenericInterpret h) => GenericInterpret ((f :+: g) :+: M1 C c h) where - genericAuto = Type {..} + genericAutoWith options@(InterpretOptions {..}) = Type {..} where n :: M1 i c h a n = undefined - name = Data.Text.Lazy.pack (conName n) + name = constructorModifier (Data.Text.Lazy.pack (conName n)) extract u@(UnionLit name' e _) | name == name' = fmap (R1 . M1) (extractR e) @@ -456,16 +494,16 @@ expected = Union (Data.Map.insert name expectedR expectedL) - Type extractL (Union expectedL) = genericAuto - Type extractR expectedR = genericAuto + Type extractL (Union expectedL) = genericAutoWith options + Type extractR expectedR = genericAutoWith options instance (Constructor c, GenericInterpret f, GenericInterpret (g :+: h)) => GenericInterpret (M1 C c f :+: (g :+: h)) where - genericAuto = Type {..} + genericAutoWith options@(InterpretOptions {..}) = Type {..} where n :: M1 i c f a n = undefined - name = Data.Text.Lazy.pack (conName n) + name = constructorModifier (Data.Text.Lazy.pack (conName n)) extract u@(UnionLit name' e _) | name == name' = fmap (L1 . M1) (extractL e) @@ -474,31 +512,31 @@ expected = Union (Data.Map.insert name expectedL expectedR) - Type extractL expectedL = genericAuto - Type extractR (Union expectedR) = genericAuto + Type extractL expectedL = genericAutoWith options + Type extractR (Union expectedR) = genericAutoWith options instance (GenericInterpret (f :+: g), GenericInterpret (h :+: i)) => GenericInterpret ((f :+: g) :+: (h :+: i)) where - genericAuto = Type {..} + genericAutoWith options = Type {..} where extract e = fmap L1 (extractL e) <|> fmap R1 (extractR e) expected = Union (Data.Map.union expectedL expectedR) - Type extractL (Union expectedL) = genericAuto - Type extractR (Union expectedR) = genericAuto + Type extractL (Union expectedL) = genericAutoWith options + Type extractR (Union expectedR) = genericAutoWith options instance GenericInterpret f => GenericInterpret (M1 C c f) where - genericAuto = fmap M1 genericAuto + genericAutoWith = fmap (fmap M1) genericAutoWith instance GenericInterpret U1 where - genericAuto = Type {..} + genericAutoWith _ = Type {..} where extract _ = Just U1 expected = Record (Data.Map.fromList []) instance (GenericInterpret f, GenericInterpret g) => GenericInterpret (f :*: g) where - genericAuto = Type {..} + genericAutoWith options = Type {..} where extract = liftA2 (liftA2 (:*:)) extractL extractR @@ -506,11 +544,11 @@ where Record ktsL = expectedL Record ktsR = expectedR - Type extractL expectedL = genericAuto - Type extractR expectedR = genericAuto + Type extractL expectedL = genericAutoWith options + Type extractR expectedR = genericAutoWith options instance (Selector s, Interpret a) => GenericInterpret (M1 S s (K1 i a)) where - genericAuto = Type {..} + genericAutoWith opts@(InterpretOptions {..}) = Type {..} where n :: M1 i s f a n = undefined @@ -519,12 +557,13 @@ case selName n of "" -> Nothing name -> do - e <- Data.Map.lookup (Data.Text.Lazy.pack name) m + let name' = fieldModifier (Data.Text.Lazy.pack name) + e <- Data.Map.lookup name' m fmap (M1 . K1) (extract' e) extract _ = Nothing expected = Record (Data.Map.fromList [(key, expected')]) where - key = Data.Text.Lazy.pack (selName n) + key = fieldModifier (Data.Text.Lazy.pack (selName n)) - Type extract' expected' = auto + Type extract' expected' = autoWith opts diff --git a/src/Dhall/Core.hs b/src/Dhall/Core.hs --- 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. @@ -17,6 +18,9 @@ module Dhall.Core ( -- * Syntax Const(..) + , HasHome(..) + , PathType(..) + , PathMode(..) , Path(..) , Var(..) , Expr(..) @@ -85,14 +89,25 @@ instance Buildable Const where build = buildConst --- | Path to an external resource -data Path - = File FilePath +-- | Whether or not a path is relative to the user's home directory +data HasHome = Home | Homeless deriving (Eq, Ord, Show) + +-- | The type of path to import (i.e. local vs. remote vs. environment) +data PathType + = File HasHome FilePath + -- ^ Local path | URL Text + -- ^ Remote resource + | Env Text + -- ^ Environment variable deriving (Eq, Ord, Show) -instance Buildable Path where - build (File file) +instance Buildable PathType where + build (File Home file) + = "~/" <> build txt + where + txt = Text.fromStrict (either id id (Filesystem.toText file)) + build (File Homeless file) | Text.isPrefixOf "./" txt || Text.isPrefixOf "/" txt || Text.isPrefixOf "../" txt @@ -102,6 +117,23 @@ where txt = Text.fromStrict (either id id (Filesystem.toText file)) 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 diff --git a/src/Dhall/Import.hs b/src/Dhall/Import.hs --- a/src/Dhall/Import.hs +++ b/src/Dhall/Import.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wall #-} {-| Dhall lets you import external expressions located either in local files or @@ -59,12 +60,47 @@ You can also reuse directory names as expressions. If you provide a path to a local or remote directory then the compiler will look for a file named @\@@ within that directory and use that file to represent the directory. + + You can also import expressions stored within environment variables using + @env:NAME@, where @NAME@ is the name of the environment variable. For + example: + + > $ export FOO=1 + > $ export BAR='"Hi"' + > $ export BAZ='λ(x : Bool) → x == False' + > $ dhall <<< "{ foo = env:FOO , bar = env:BAR , baz = env:BAZ }" + > { 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(..) @@ -91,7 +127,8 @@ #endif import Data.Typeable (Typeable) import Filesystem.Path ((), FilePath) -import Dhall.Core (Expr, 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) @@ -118,6 +155,7 @@ import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Client.TLS as HTTP import qualified Filesystem.Path.CurrentOS as Filesystem +import qualified System.Environment import qualified Text.Parser.Combinators import qualified Text.Parser.Token import qualified Text.Trifecta @@ -248,6 +286,19 @@ "\n" <> "\ESC[1;31mError\ESC[0m: Missing file\n" +-- | Exception thrown when an environment variable is missing +newtype MissingEnvironmentVariable = MissingEnvironmentVariable { name :: Text } + deriving (Typeable) + +instance Exception MissingEnvironmentVariable + +instance Show MissingEnvironmentVariable where + show (MissingEnvironmentVariable {..}) = + "\n" + <> "\ESC[1;31mError\ESC[0m: Missing environment variable\n" + <> "\n" + <> "↳ " <> Text.unpack name + data Status = Status { _stack :: [Path] , _cache :: Map Path (Expr Src X) @@ -255,7 +306,7 @@ } 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)) @@ -302,14 +353,15 @@ `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 [] = File "." -canonicalize (File file0:paths0) = - if Filesystem.relative file0 - then go file0 paths0 - else File (clean file0) +canonicalize :: [PathType] -> PathType +canonicalize [] = File Homeless "." +canonicalize (File hasHome0 file0:paths0) = + if Filesystem.relative file0 && hasHome0 == Homeless + then go file0 paths0 + else File hasHome0 (clean file0) where - go currPath [] = File (clean currPath) + go currPath [] = File hasHome0 (clean currPath) + go currPath (Env _ :_ ) = File hasHome0 (clean currPath) go currPath (URL url0:_ ) = combine prefix suffix where prefix = parentURL (removeAtFromURL url0) @@ -335,14 +387,27 @@ path' = Text.fromStrict (case Filesystem.toText path of Left txt -> txt Right txt -> txt ) - go currPath (File file:paths) = - if Filesystem.relative file - then go file' paths - else File (clean file') + go currPath (File hasHome file:paths) = + if Filesystem.relative file && hasHome == Homeless + then go file' paths + else File hasHome0 (clean file') where file' = Filesystem.parent (removeAtFromFile file) currPath 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 (/= '/') @@ -366,85 +431,119 @@ 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 +-- | 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 - -- 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 "@") + case pathMode of + Code -> do + exists <- Filesystem.isFile path + if exists + then return () + else Control.Exception.throwIO MissingFile - -- If the fallback fails, reuse the original exception to avoid user - -- confusion - Text.Trifecta.parseFromFileEx parser string' `onException` throwIO e + let string = Filesystem.Path.CurrentOS.encodeString path - exists <- Filesystem.isFile path - if exists - then return () - else Control.Exception.throwIO MissingFile + -- 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 "@") - 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 ) + -- If the fallback fails, reuse the original exception + -- to avoid user confusion + Text.Trifecta.parseFromFileEx parser string' + `onException` throwIO e --- | 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) + 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) + 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 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 + let bytes = HTTP.responseBody response - text <- case Data.Text.Lazy.Encoding.decodeUtf8' bytes of - Left err -> throwIO err - Right text -> return text + 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) + 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) + request' <- HTTP.parseUrlThrow (Text.unpack url) - let request'' = request' { HTTP.path = HTTP.path request' <> "/@" } - response' <- HTTP.httpLbs request'' m `onException` throwIO err' + let request'' = + request' + { HTTP.path = HTTP.path request' <> "/@" } + response' <- HTTP.httpLbs request'' m + `onException` throwIO err' - let bytes' = HTTP.responseBody response' + let bytes' = HTTP.responseBody response' - text' <- case Data.Text.Lazy.Encoding.decodeUtf8' bytes' of - Left _ -> throwIO err' - Right text' -> return text' + 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 + 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 @@ -463,28 +562,25 @@ let handler :: SomeException -> IO (Expr Src Path) handler e = throwIO (Imported (p:paths) e) - case canonicalize (p:paths) of - File file -> do - liftIO (exprFromFile file `catch` handler) - URL url -> do - m <- needManager - liftIO (exprFromURL m url `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 (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 --- 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,9 +30,8 @@ import Data.Text.Lazy.Builder (Builder) import Data.Typeable (Typeable) import Data.Vector (Vector) -import Dhall.Core (Const(..), Expr(..), Path(..), Var(..)) -import Filesystem.Path (FilePath) -import Prelude hiding (FilePath, const, pi) +import Dhall.Core +import Prelude hiding (const, pi) import Text.PrettyPrint.ANSI.Leijen (Doc) import Text.Parser.Combinators (choice, try, ()) import Text.Parser.Token (IdentifierStyle(..), TokenParsing(..)) @@ -51,7 +51,6 @@ 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 @@ -128,6 +127,7 @@ , "if" , "then" , "else" + , "as" , "Natural" , "Natural/fold" , "Natural/build" @@ -183,6 +183,19 @@ _ <- Text.Parser.Token.symbol string return () +sepBy :: Parser a -> Parser b -> Parser [a] +sepBy p sep = sepBy1 p sep <|> pure [] + +sepBy1 :: Parser a -> Parser b -> Parser [a] +sepBy1 p sep = do + a <- p + b <- optional sep + case b of + Nothing -> return [a] + Just _ -> do + as <- sepBy p sep + return (a:as) + stringLiteral :: Parser Builder stringLiteral = Text.Parser.Token.stringLiteral <|> doubleSingleQuoteString @@ -259,31 +272,16 @@ -- | Parser for a top-level Dhall expression. The expression is parameterized -- over any parseable type, allowing the language to be extended as needed. exprA :: Show a => Parser a -> Parser (Expr Src a) -exprA embedded = noted (do - a <- exprB embedded - - let exprA0 = do - symbol ":" - b <- exprA embedded - return (Annot a b) - - let exprA1 = pure a - - exprA0 <|> exprA1 ) - -exprB :: Show a => Parser a -> Parser (Expr Src a) -exprB embedded = choice - [ noted exprB0 - , noted exprB1 - , noted exprB3 - , noted exprB5 - , noted (try exprB6) - , noted exprB7 - , noted (try exprB2) - , exprB8 +exprA embedded = choice + [ noted exprA0 + , noted exprA1 + , noted exprA2 + , noted exprA3 + , noted (try exprA4) + , exprA5 ] where - exprB0 = do + exprA0 = do lambda symbol "(" a <- label @@ -291,25 +289,19 @@ b <- exprA embedded symbol ")" arrow - c <- exprB embedded + c <- exprA embedded return (Lam a b c) - exprB1 = do + exprA1 = do reserve "if" a <- exprA embedded reserve "then" - b <- exprB embedded + b <- exprA embedded reserve "else" - c <- exprC embedded + c <- exprA embedded return (BoolIf a b c) - exprB2 = do - a <- exprC embedded - arrow - b <- exprB embedded - return (Pi "_" a b) - - exprB3 = do + exprA2 = do pi symbol "(" a <- label @@ -317,10 +309,10 @@ b <- exprA embedded symbol ")" arrow - c <- exprB embedded + c <- exprA embedded return (Pi a b c) - exprB5 = do + exprA3 = do reserve "let" a <- label b <- optional (do @@ -329,10 +321,33 @@ symbol "=" c <- exprA embedded reserve "in" - d <- exprB embedded + d <- exprA embedded return (Let a b c d) - exprB6 = do + exprA4 = do + a <- exprC embedded + arrow + b <- exprA embedded + return (Pi "_" a b) + + exprA5 = exprB embedded + +exprB :: Show a => Parser a -> Parser (Expr Src a) +exprB embedded = choice + [ noted exprB0 + , noted (try exprB1) + , noted exprB2 + ] + where + exprB0 = do + reserve "merge" + a <- exprE embedded + b <- exprE embedded + symbol ":" + c <- exprD embedded + return (Merge a b c) + + exprB1 = do symbol "[" a <- elems embedded symbol "]" @@ -341,16 +356,18 @@ c <- exprE embedded return (b c a) - exprB7 = do - reserve "merge" - a <- exprE embedded - b <- exprE embedded - symbol ":" - c <- exprD embedded - return (Merge a b c) + exprB2 = do + a <- exprC embedded - exprB8 = exprC embedded + let exprB2A= do + symbol ":" + b <- exprA embedded + return (Annot a b) + let exprB2B = pure a + + exprB2A <|> exprB2B + listLike :: Parser (Expr Src a -> Vector (Expr Src a) -> Expr Src a) listLike = ( listLike0 @@ -391,12 +408,13 @@ -- arguments exprD :: Show a => Parser a -> Parser (Expr Src a) exprD embedded = do - es <- some (noted (try (exprE embedded))) + e <- noted (exprE embedded) + es <- many (noted (try (exprE embedded))) let app nL@(Note (Src before _ bytesL) _) nR@(Note (Src _ after bytesR) _) = Note (Src before after (bytesL <> bytesR)) (App nL nR) app _ _ = Dhall.Core.internalError ("Dhall.Parser.exprD: foldl1 app (" <> Data.Text.pack (show es) <> ")") - return (Data.List.foldl1 app es) + return (Data.List.foldl1 app (e:es)) exprE :: Show a => Parser a -> Parser (Expr Src a) exprE embedded = noted (do @@ -609,7 +627,7 @@ elems :: Show a => Parser a -> Parser (Vector (Expr Src a)) elems embedded = do - a <- Text.Parser.Combinators.sepBy (exprA embedded) (symbol ",") + a <- sepBy (exprA embedded) (symbol ",") return (Data.Vector.fromList a) recordLit :: Show a => Parser a -> Parser (Expr Src a) @@ -629,8 +647,7 @@ return (RecordLit b) fieldValues :: Show a => Parser a -> Parser [(Text, Expr Src a)] -fieldValues embedded = - Text.Parser.Combinators.sepBy1 (fieldValue embedded) (symbol ",") +fieldValues embedded = sepBy1 (fieldValue embedded) (symbol ",") fieldValue :: Show a => Parser a -> Parser (Text, Expr Src a) fieldValue embedded = do @@ -648,8 +665,7 @@ return (Record b) fieldTypes :: Show a => Parser a -> Parser [(Text, Expr Src a)] -fieldTypes embedded = - Text.Parser.Combinators.sepBy (fieldType embedded) (symbol ",") +fieldTypes embedded = sepBy (fieldType embedded) (symbol ",") fieldType :: Show a => Parser a -> Parser (Text, Expr Src a) fieldType embedded = do @@ -667,8 +683,7 @@ return (Union b) alternativeTypes :: Show a => Parser a -> Parser [(Text, Expr Src a)] -alternativeTypes embedded = - Text.Parser.Combinators.sepBy (alternativeType embedded) (symbol "|") +alternativeTypes embedded = sepBy (alternativeType embedded) (symbol "|") alternativeType :: Show a => Parser a -> Parser (Text, Expr Src a) alternativeType embedded = do @@ -710,22 +725,20 @@ import_ :: Parser Path import_ = do - a <- import0 <|> import1 + pathType <- file <|> url <|> env Text.Parser.Token.whiteSpace - return a - where - import0 = do - a <- file - return (File a) - - import1 = do - a <- url - return (URL a) + let rawText = do + _ <- reserve "as" + _ <- reserve "Text" + return RawText + pathMode <- rawText <|> pure Code + return (Path {..}) -file :: Parser FilePath +file :: Parser PathType file = try (token file0) <|> token file1 <|> token file2 + <|> token file3 where file0 = do a <- Text.Parser.Char.string "/" @@ -733,37 +746,50 @@ case b of '\\':_ -> empty -- So that "/\" parses as the operator and not a path _ -> return () - return (Filesystem.Path.CurrentOS.decodeString (a <> b)) + return (File Homeless (Filesystem.Path.CurrentOS.decodeString (a <> b))) file1 = do a <- Text.Parser.Char.string "./" b <- many (Text.Parser.Char.satisfy (not . Data.Char.isSpace)) - return (Filesystem.Path.CurrentOS.decodeString (a <> b)) + return (File Homeless (Filesystem.Path.CurrentOS.decodeString (a <> b))) file2 = do a <- Text.Parser.Char.string "../" b <- many (Text.Parser.Char.satisfy (not . Data.Char.isSpace)) - return (Filesystem.Path.CurrentOS.decodeString (a <> b)) + return (File Homeless (Filesystem.Path.CurrentOS.decodeString (a <> b))) -url :: Parser Text + file3 = do + _ <- Text.Parser.Char.string "~" + _ <- some (Text.Parser.Char.string "/") + b <- many (Text.Parser.Char.satisfy (not . Data.Char.isSpace)) + return (File Home (Filesystem.Path.CurrentOS.decodeString b)) + +url :: Parser PathType url = try url0 <|> url1 where url0 = do a <- Text.Parser.Char.string "https://" b <- many (Text.Parser.Char.satisfy (not . Data.Char.isSpace)) - return (Data.Text.Lazy.pack (a <> b)) + return (URL (Data.Text.Lazy.pack (a <> b))) url1 = do a <- Text.Parser.Char.string "http://" b <- many (Text.Parser.Char.satisfy (not . Data.Char.isSpace)) - return (Data.Text.Lazy.pack (a <> b)) + return (URL (Data.Text.Lazy.pack (a <> b))) +env :: Parser PathType +env = do + _ <- Text.Parser.Char.string "env:" + a <- many (Text.Parser.Char.satisfy (not . Data.Char.isSpace)) + return (Env (Data.Text.Lazy.pack a)) + -- | A parsing error newtype ParseError = ParseError Doc deriving (Typeable) instance Show ParseError where - show (ParseError doc) = show doc + show (ParseError doc) = + "\n\ESC[1;31mError\ESC[0m: Invalid input\n\n" <> show doc instance Exception ParseError diff --git a/src/Dhall/Tutorial.hs b/src/Dhall/Tutorial.hs --- a/src/Dhall/Tutorial.hs +++ b/src/Dhall/Tutorial.hs @@ -417,6 +417,12 @@ -- Dhall expression anywhere that you can host UTF8-encoded text on the web, such -- as Github, a pastebin, or your own web server. -- +-- You can also import Dhall expressions from environment variables, too: +-- +-- > >>> System.Environment.setEnv "FOO" "1" +-- > >>> input auto "env:FOO" :: IO Integer +-- > 1 +-- -- You can import types, too. For example, we can change our @./bar@ file to: -- -- > $ echo "[3.0, 4.0, 5.0] : List ./type" > ./bar