expresso 0.1.0.2 → 0.1.1.0
raw patch · 6 files changed
+324/−21 lines, 6 filesdep +template-haskelldep +terminfo
Dependencies added: template-haskell, terminfo
Files
- CHANGELOG.md +7/−0
- README.md +116/−0
- expresso.cabal +18/−2
- src/Expresso.hs +24/−0
- src/Expresso/Eval.hs +99/−19
- src/Expresso/TH/QQ.hs +60/−0
CHANGELOG.md view
@@ -1,5 +1,12 @@ # Change Log +## 0.1.1.0++- API convenience functions for building record/variant HasValue instances.+- HasValue instances for function types.+- added Type constructors and pattern synonyms to API+- terminfo as an explicit dependency.+ ## 0.1.0.2 Expresso REPL fails to build on Hackage, disable building for now.
README.md view
@@ -302,6 +302,122 @@ Note that removing `fix` and Turing equivalence does not guarantee termination in practice. It is still possible to write exponential programs that will not terminate during the lifetime of the universe without recursion or fix. +## A configuration file format++Expresso can be used as a typed configuration file format from within Haskell programs. As an example, let's consider a hypothetical small config file for a backup program:++ let awsTemplate =+ { location ="s3://s3-eu-west-2.amazonaws.com/atavachron-backup"+ , include = []+ , exclude = []+ }+ in+ { cachePath = Default{}+ , taskThreads = Override 2+ , profiles =+ [ { name = "pictures", source = "~/Pictures" | awsTemplate }+ , { name = "music", source = "~/Music", exclude := ["**/*.m4a"] | awsTemplate }+ ]+ }++Note that even for such a small example, we can already leverage some of the abstraction power of extensible records to avoid repetition in the config file.++In order to consume this file from a Haskell program, we can define some corresponding nominal data types:++ data Config = Config+ { configCachePath :: Overridable Text+ , configTaskThreads :: Overridable Integer+ , configProfiles :: [Profile]+ } deriving Show++ data Overridable a = Default | Override a deriving Show++ data Profile = Profile+ { profileName :: Text+ , profileLocation :: Text+ , profileInclude :: [Text]+ , profileExclude :: [Text]+ , profileSource :: Text+ } deriving Show++Using the Expresso API, we can write `HasValue` instances to handle the projection into and injection from, Haskell values:++ import Expresso++ instance HasValue Config where+ proj v = Config+ <$> v .: "cachePath"+ <*> v .: "taskThreads"+ <*> v .: "profiles"+ inj Config{..} = mkRecord+ [ "cachePath" .= inj configCachePath+ , "taskThreads" .= inj configTaskThreads+ , "profiles" .= inj configProfiles+ ]++ instance HasValue a => HasValue (Overridable a) where+ proj = choice [("Override", fmap Override . proj)+ ,("Default", const $ pure Default)+ ]+ inj (Override x) = mkVariant "Override" (inj x)+ inj Default = mkVariant "Default" unit++ instance HasValue Profile where+ proj v = Profile+ <$> v .: "name"+ <*> v .: "location"+ <*> v .: "include"+ <*> v .: "exclude"+ <*> v .: "source"+ inj Profile{..} = mkRecord+ [ "name" .= inj profileName+ , "location" .= inj profileLocation+ , "include" .= inj profileInclude+ , "exclude" .= inj profileExclude+ , "source" .= inj profileSource+ ]++Before we load the config file, we will probably want to check the inferred types against an agreed signature (a.k.a. schema validation). The Expresso API provides a Template Haskell quasi-quoter to make this convenient from within Haskell:++ import Expresso.TH.QQ++ schema :: Type+ schema =+ [expressoType|+ { cachePath : <Default : {}, Override : Text>+ , taskThreads : <Default : {}, Override : Int>+ , profiles :+ [ { name : Text+ , location : Text+ , include : [Text]+ , exclude : [Text]+ , source : Text+ }+ ]+ }|]++We can thus load, validate and evaluate the above config file using the following code:++ loadConfig :: FilePath -> IO (Either String Config)+ loadConfig = evalFile (Just schema)++Note that we can also install our own custom values/functions for users to reference in their config files. For example:++ loadConfig :: FilePath -> IO (Either String Config)+ loadConfig = evalFile' envs (Just schema)+ where+ envs = installBinding "system" TText (inj System.Info.os)+ . installBinding "takeFileName" (TFun TText TText) (inj takeFileName)+ . installBinding "takeDirectory" (TFun TText TText) (inj takeDirectory)+ . installBinding "doesPathExist" (TFun TText TBool) (inj doesPathExist) -- NB: This does IO reads+ $ initEnvironments++Finally, we need not limit ourselves to config files that specify record values. We can project Expresso function values into Haskell functions (in IO), allowing higher-order config files! The projection itself is handled by the `HasValue` class, just like any other value:++ Haskell> Right (f :: Integer -> IO Integer) <- evalString (Just $ TFun TInt TInt) "x -> x + 1"+ Haskell> f 1+ 2+ ## References Expresso is built upon many ideas described in the following publications:
expresso.cabal view
@@ -1,5 +1,5 @@ Name: expresso-Version: 0.1.0.2+Version: 0.1.1.0 Cabal-Version: >= 1.10 License: BSD3 License-File: LICENSE@@ -25,6 +25,11 @@ Type: git Location: https://github.com/willtim/Expresso +Flag terminfo+ Description: On POSIX systems, build with the terminfo lib for detecting terminal width.+ Manual: False+ Default: True+ Library Hs-Source-Dirs: src Default-Language: Haskell2010@@ -37,9 +42,14 @@ haskeline >= 0.7.4 && < 0.8, mtl >= 2.2.2 && < 2.3, parsec >= 3.1.13 && < 3.2,+ template-haskell >= 2.13.0 && < 2.15, unordered-containers >= 0.2.9 && < 0.3, wl-pprint >= 1.2.1 && < 1.3+ if (!(os(windows))) && (flag(terminfo))+ Build-Depends: terminfo >= 0.4 && < 0.5+ Exposed-Modules: Expresso+ Expresso.TH.QQ Other-Modules: Expresso.Parser Expresso.Eval Expresso.Type@@ -47,6 +57,7 @@ Expresso.Syntax Expresso.Pretty Expresso.Utils+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-orphans -fno-warn-unused-do-bind@@ -57,9 +68,11 @@ Main-Is: Repl.hs Hs-Source-Dirs: src Default-Language: Haskell2010- Buildable: False Build-Depends: base, containers, hashable, mtl, parsec, wl-pprint, text, unordered-containers, haskeline, directory, filepath+ if (!(os(windows))) && (flag(terminfo))+ Build-Depends: terminfo+ Other-Modules: Expresso.Parser Expresso.Eval Expresso.Type@@ -84,6 +97,9 @@ Build-Depends: base, containers, hashable, mtl, parsec, wl-pprint, text, unordered-containers, haskeline, directory, filepath, expresso, tasty, tasty-hunit+ if (!(os(windows))) && (flag(terminfo))+ Build-Depends: terminfo+ Other-Modules: Expresso Expresso.Eval Expresso.Parser
src/Expresso.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TupleSections #-}+{-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} -- |@@ -26,6 +27,22 @@ , Name , Thunk(..) , TIState+ , Type+ , pattern TForAll+ , pattern TVar+ , pattern TMetaVar+ , pattern TInt+ , pattern TDbl+ , pattern TBool+ , pattern TChar+ , pattern TText+ , pattern TFun+ , pattern TList+ , pattern TRecord+ , pattern TVariant+ , pattern TRowEmpty+ , pattern TRowExtend+ , TypeF(..) , TypeEnv , Value(..) , bind@@ -46,9 +63,16 @@ , typeOfString , typeOfWithEnv , validate+ , Eval.choice+ , Eval.mkRecord , Eval.mkStrictLam , Eval.mkStrictLam2 , Eval.mkStrictLam3+ , Eval.mkVariant+ , Eval.typeMismatch+ , Eval.unit+ , (Eval..:)+ , (Eval..=) ) where import Control.Monad ((>=>))
src/Expresso/Eval.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} @@ -29,15 +30,22 @@ , Thunk(..) , Value(..) , bind + , choice , eval , insertEnv + , mkRecord , mkStrictLam , mkStrictLam2 , mkStrictLam3 , mkThunk + , mkVariant , ppValue , ppValue' , runEvalM + , typeMismatch + , unit + , (.:) + , (.=) ) where @@ -129,6 +137,10 @@ runEvalM :: EvalM a -> IO (Either String a) runEvalM = runExceptT +-- | Partial variant of @runEvalM@. +runEvalM' :: EvalM a -> IO a +runEvalM' = fmap (either error id) . runExceptT + eval :: Env -> Exp -> EvalM Value eval env e = cata alg e env where @@ -320,18 +332,19 @@ show (parensList (map ppValue vs)) -- | Make a strict Expresso lambda value (forced arguments) from a --- Haskell lambda. +-- Haskell function (on Expresso values). mkStrictLam :: (Value -> EvalM Value) -> Value mkStrictLam f = VLam $ \x -> force x >>= f --- | As mkStrictLam, but accepts Haskell functions with two curried arguments. +-- | As @mkStrictLam@, but accepts Haskell functions with two curried arguments. mkStrictLam2 :: (Value -> Value -> EvalM Value) -> Value mkStrictLam2 f = mkStrictLam $ \v -> return $ mkStrictLam $ f v --- | As mkStrictLam, but accepts Haskell functions with three curried arguments. +-- | As @mkStrictLam@, but accepts Haskell functions with three curried arguments. mkStrictLam3 :: (Value -> Value -> Value -> EvalM Value) -> Value mkStrictLam3 f = mkStrictLam $ \v -> return $ mkStrictLam2 $ f v +-- | Force (evaluate) thunk and then project out the Haskell value. proj' :: HasValue a => Thunk -> EvalM a proj' = force >=> proj @@ -398,15 +411,11 @@ ------------------------------------------------------------ -- HasValue class and instances --- TODO generic derivation a la GG - --- TODO write pure evaluator in ST, carry type in class to get rid of Either/Maybe to get --- instance (HasValue b) => HasValue (a -> b) where instance (HasValue a, HasValue b) => HasValue (a -> EvalM b) where proj (VLam f) = return $ \x -> do r <- f (Thunk $ return $ inj x) proj r - proj v = failProj "VLam" v + proj v = typeMismatch "VLam" v inj f = VLam $ \v -> proj' v >>= fmap inj . f -- | A class of Haskell types that can be projected from or injected @@ -421,42 +430,54 @@ instance HasValue Integer where proj (VInt i) = return i - proj v = failProj "VInt" v + proj v = typeMismatch "VInt" v inj = VInt instance HasValue Double where proj (VDbl d) = return d - proj v = failProj "VDbl" v + proj v = typeMismatch "VDbl" v inj = VDbl instance HasValue Bool where proj (VBool b) = return b - proj v = failProj "VBool" v + proj v = typeMismatch "VBool" v inj = VBool instance HasValue Char where proj (VChar c) = return c - proj v = failProj "VChar" v + proj v = typeMismatch "VChar" v inj = VChar +instance HasValue String where + proj (VText s) = return $ T.unpack s + proj v = typeMismatch "VText" v + inj = VText . T.pack + instance HasValue Text where proj (VText s) = return s - proj v = failProj "VText" v + proj v = typeMismatch "VText" v inj = VText +instance HasValue a => HasValue (Maybe a) where + proj = choice [ ("Just", fmap Just . proj) + , ("Nothing", const $ pure Nothing) + ] + inj (Just x) = mkVariant "Just" (inj x) + inj Nothing = mkVariant "Nothing" unit + instance {-# OVERLAPS #-} HasValue a => HasValue [a] where proj (VList xs) = mapM proj xs - proj v = failProj "VList" v + proj v = typeMismatch "VList" v inj = VList . map inj instance {-# OVERLAPS #-} HasValue [Value] where proj (VList xs) = return xs - proj v = failProj "VList" v + proj v = typeMismatch "VList" v inj = VList instance HasValue a => HasValue (HashMap Name a) where proj (VRecord m) = mapM proj' m - proj v = failProj "VRecord" v + proj v = typeMismatch "VRecord" v inj = VRecord . fmap (Thunk . return . inj) instance {-# OVERLAPS #-} HasValue a => HasValue [(Name, a)] where @@ -465,13 +486,72 @@ instance {-# OVERLAPS #-} HasValue (HashMap Name Thunk) where proj (VRecord m) = return m - proj v = failProj "VRecord" v + proj v = typeMismatch "VRecord" v inj = VRecord instance {-# OVERLAPS #-} HasValue [(Name, Thunk)] where proj v = HashMap.toList <$> proj v inj = inj . HashMap.fromList -failProj :: String -> Value -> EvalM a -failProj desc v = throwError $ "Expected a " ++ desc ++ +instance {-# OVERLAPS #-} (HasValue a, HasValue b) => HasValue (a -> b) where + proj _ = throwError "proj not supported for pure functions" + inj f = mkStrictLam $ fmap (inj . f) . proj + +instance {-# OVERLAPS #-} (HasValue a, HasValue b, HasValue c) => HasValue (a -> b -> c) where + proj _ = throwError "proj not supported for pure functions" + inj f = inj $ \x -> inj (f x) + +instance {-# OVERLAPS #-} (HasValue a, HasValue b, HasValue c, HasValue d) => HasValue (a -> b -> c -> d) where + proj _ = throwError "proj not supported for pure functions" + inj f = inj $ \x -> inj (f x) + +instance {-# OVERLAPS #-} (HasValue a, HasValue b) => HasValue (a -> IO b) where + proj (VLam f) = return $ \x -> runEvalM' $ f (Thunk . return . inj $ x) >>= proj + proj v = typeMismatch "VLam" v + inj f = mkStrictLam $ \v -> proj v >>= \x -> inj <$> liftIO (f x) + +instance {-# OVERLAPS #-} (HasValue a, HasValue b, HasValue c) => HasValue (a -> b -> IO c) where + proj v = proj v >>= \f -> return $ \x -> f x + inj f = inj $ \x -> inj (f x) + +instance {-# OVERLAPS #-} (HasValue a, HasValue b, HasValue c, HasValue d) => HasValue (a -> b -> c -> IO d) where + proj v = proj v >>= \f -> return $ \x -> f x + inj f = inj $ \x -> inj (f x) + +-- | Throw a type mismatch error. +typeMismatch :: String -> Value -> EvalM a +typeMismatch expected v = throwError $ "Type mismatch: expected a " ++ expected ++ ", but got: " ++ show (ppValue v) + +-- | Project out a record field, fail with a type mismatch if it is not present. +(.:) :: HasValue a => Value -> Name -> EvalM a +(.:) (VRecord m) k = case HashMap.lookup k m of + Nothing -> throwError $ "Record label " ++ show k ++ " not present" + Just v -> proj' v +(.:) v _ = typeMismatch "VRecord" v + +-- | Pair up a field name and a value. Intended to be used with @mkRecord@ or @mkVariant@. +(.=) :: Name -> Value -> (Name, Thunk) +(.=) k v = (k, Thunk . return $ v) + +-- | Convenience for implementing @proj@ for a sum type. +choice :: HasValue a => [(Name, Value -> EvalM a)] -> Value -> EvalM a +choice alts = \case + VVariant k v + | Just f <- HashMap.lookup k m -> force v >>= f + | otherwise -> throwError $ "Missing label in alternatives: " ++ show k + v -> typeMismatch "VVariant" v + where + m = HashMap.fromList alts + +-- | Convenience constructor for a record value. +mkRecord :: [(Name, Thunk)] -> Value +mkRecord = VRecord . HashMap.fromList + +-- | Convenience constructor for a variant value. +mkVariant :: Name -> Value -> Value +mkVariant name = VVariant name . Thunk . return + +-- | Unit value. Equivalent to @()@ in Haskell. +unit :: Value +unit = VRecord mempty
+ src/Expresso/TH/QQ.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}++-- |+-- Module : Expresso.TH.QQ+-- Copyright : (c) Tim Williams 2017-2019+-- License : BSD3+--+-- Maintainer : info@timphilipwilliams.com+-- Stability : experimental+-- Portability : portable+--+-- Quasi-quoters for defining Expresso types in Haskell.+--+module Expresso.TH.QQ (expressoType) where++import Control.Exception++import Language.Haskell.TH (ExpQ, Loc(..), Q, location, runIO)+import Language.Haskell.TH.Quote (QuasiQuoter(..), dataToExpQ)++import qualified Text.Parsec as P+import qualified Text.Parsec.Pos as P+import Text.Parsec.String++import Expresso.Parser++-- | Expresso Quasi-Quoter for type declarations.+expressoType :: QuasiQuoter+expressoType = def { quoteExp = genTypeDecl }++def :: QuasiQuoter+def = QuasiQuoter+ { quoteExp = failure "expressions"+ , quotePat = failure "patterns"+ , quoteType = failure "types"+ , quoteDec = failure "declarations"+ }+ where+ failure kind =+ fail $ "This quasi-quoter does not support splicing " ++ kind++genTypeDecl :: String -> ExpQ+genTypeDecl str = do+ l <- location'+ c <- runIO $ parseIO (P.setPosition l *> topLevel pTypeAnn) str+ dataToExpQ (const Nothing) c++-- | find the current location in the Haskell source file and convert it to parsec @SourcePos@.+location' :: Q P.SourcePos+location' = aux <$> location+ where+ aux :: Loc -> P.SourcePos+ aux loc = uncurry (P.newPos (loc_filename loc)) (loc_start loc)++parseIO :: Parser a -> String -> IO a+parseIO p str =+ case P.parse p "" str of+ Left err -> throwIO (userError (show err))+ Right a -> return a