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

Add support for projecting a subset of record fields (#350)

Browse Source 
... as standardized in https://github.com/dhall-lang/dhall-lang/pull/126
This commit is contained in:
Gabriel Gonzalez 2018-04-05 07:13:12 -07:00 committed by GitHub
parent 14b083ba76
commit 4f2103a769
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
10 changed files with 170 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
dhall.cabal
View File

@ -83,6 +83,7 @@ Extra-Source-Files:
Prelude/Text/concatSep
tests/format/*.dhall
tests/normalization/tutorial/combineTypes/*.dhall
tests/normalization/tutorial/projection/*.dhall
tests/normalization/*.dhall
tests/normalization/examples/Bool/and/*.dhall
tests/normalization/examples/Bool/build/*.dhall

42
src/Dhall/Core.hs
View File

@ -60,8 +60,9 @@ import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
import Data.HashSet (HashSet)
import Data.String (IsString(..))
import Data.Scientific (Scientific)
import Data.Sequence (Seq, ViewL(..), ViewR(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (Seq, ViewL(..), ViewR(..))
import Data.Set (Set)
import Data.Text.Lazy (Text)
import Data.Text.Lazy.Builder (Builder)
import Data.Text.Prettyprint.Doc (Pretty)
@ -76,6 +77,7 @@ import qualified Crypto.Hash
import qualified Data.HashMap.Strict.InsOrd
import qualified Data.HashSet
import qualified Data.Sequence
import qualified Data.Set
import qualified Data.Text
import qualified Data.Text.Lazy as Text
import qualified Data.Text.Lazy.Builder as Builder
@ -326,6 +328,8 @@ data Expr s a
| Constructors (Expr s a)
-- | > Field e x ~ e.x
| Field (Expr s a) Text
-- | > Project e xs ~ e.{ xs }
| Project (Expr s a) (Set Text)
-- | > Note s x ~ e
| Note s (Expr s a)
-- | > Embed path ~ path
@ -398,6 +402,7 @@ instance Monad (Expr s) where
Merge a b c >>= k = Merge (a >>= k) (b >>= k) (fmap (>>= k) c)
Constructors a >>= k = Constructors (a >>= k)
Field a b >>= k = Field (a >>= k) b
Project a b >>= k = Project (a >>= k) b
Note a b >>= k = Note a (b >>= k)
Embed a >>= k = k a
@ -460,6 +465,7 @@ instance Bifunctor Expr where
first k (Merge a b c ) = Merge (first k a) (first k b) (fmap (first k) c)
first k (Constructors a ) = Constructors (first k a)
first k (Field a b ) = Field (first k a) b
first k (Project a b ) = Project (first k a) b
first k (Note a b ) = Note (k a) (first k b)
first _ (Embed a ) = Embed a
@ -713,6 +719,9 @@ shift d v (Constructors a) = Constructors a'
shift d v (Field a b) = Field a' b
where
a' = shift d v a
shift d v (Project a b) = Project a' b
where
a' = shift d v a
shift d v (Note a b) = Note a b'
where
b' = shift d v b
@ -857,6 +866,9 @@ subst x e (Constructors a) = Constructors a'
subst x e (Field a b) = Field a' b
where
a' = subst x e a
subst x e (Project a b) = Project a' b
where
a' = subst x e a
subst x e (Note a b) = Note a b'
where
b' = subst x e b
@ -1115,6 +1127,10 @@ alphaNormalize (Field e₀ a) =
Field e₁ a
where
e₁ = alphaNormalize e₀
alphaNormalize (Project e₀ a) =
Project e₁ a
where
e₁ = alphaNormalize e₀
alphaNormalize (Note s e₀) =
Note s e₁
where
@ -1217,6 +1233,7 @@ denote (Prefer a b ) = Prefer (denote a) (denote b)
denote (Merge a b c ) = Merge (denote a) (denote b) (fmap denote c)
denote (Constructors a ) = Constructors (denote a)
denote (Field a b ) = Field (denote a) b
denote (Project a b ) = Project (denote a) b
denote (Embed a ) = Embed a
{-| Reduce an expression to its normal form, performing beta reduction and applying
@ -1566,6 +1583,21 @@ normalizeWith ctx e0 = loop (denote e0)
Just v -> loop v
Nothing -> Field (RecordLit (fmap loop kvs)) x
r' -> Field r' x
Project r xs ->
case loop r of
RecordLit kvs ->
case traverse adapt (Data.Set.toList xs) of
Just s ->
loop (RecordLit kvs')
where
kvs' = Data.HashMap.Strict.InsOrd.fromList s
Nothing ->
Project (RecordLit (fmap loop kvs)) xs
where
adapt x = do
v <- Data.HashMap.Strict.InsOrd.lookup x kvs
return (x, v)
r' -> Project r' xs
Note _ e' -> loop e'
Embed a -> Embed a
@ -1762,6 +1794,7 @@ isNormalized e = case denote e of
case t of
Union _ -> False
_ -> True
Field r x -> isNormalized r &&
case r of
RecordLit kvs ->
@ -1769,6 +1802,13 @@ isNormalized e = case denote e of
Just _ -> False
Nothing -> True
_ -> True
Project r xs -> isNormalized r &&
case r of
RecordLit kvs ->
if all (flip Data.HashMap.Strict.InsOrd.member kvs) xs
then False
else True
_ -> True
Note _ e' -> isNormalized e'
Embed _ -> True

37
src/Dhall/Diff.hs
View File

@ -20,6 +20,7 @@ import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
import Data.Monoid (Any(..))
import Data.Scientific (Scientific)
import Data.Semigroup
import Data.Set (Set)
import Data.String (IsString(..))
import Data.Text.Lazy (Text)
import Data.Text.Prettyprint.Doc (Doc, Pretty)
@ -166,6 +167,19 @@ diffPrimitive f l r
diffLabel :: Text -> Text -> Diff
diffLabel = diffPrimitive (token . Internal.prettyLabel)
diffLabels :: Set Text -> Set Text -> Diff
diffLabels ksL ksR =
braced (diffFieldNames <> (if anyEqual then [ ignore ] else []))
where
extraL = Data.Set.difference ksL ksR
extraR = Data.Set.difference ksR ksL
diffFieldNames = foldMap (adapt minus) extraL <> foldMap (adapt plus) extraR
where
adapt sign key = [ sign (token (Internal.prettyLabel key)) ]
anyEqual = not (Data.Set.null (Data.Set.intersection ksL ksR))
diffNatural :: Natural -> Natural -> Diff
diffNatural = diffPrimitive (token . Internal.prettyNatural)
@ -515,6 +529,14 @@ skeleton (Field {}) =
ignore
<> dot
<> ignore
skeleton (Project {}) =
ignore
<> dot
<> lbrace
<> " "
<> ignore
<> " "
<> rbrace
skeleton x = token (Pretty.pretty x)
mismatch :: Pretty a => Expr s a -> Expr s a -> Diff
@ -848,12 +870,27 @@ diffExprE l@(Field {}) r@(Field {}) =
where
docs (Field aL bL) (Field aR bR) =
Data.List.NonEmpty.cons (diffLabel bL bR) (docs aL aR)
docs (Project aL bL) (Project aR bR) =
Data.List.NonEmpty.cons (diffLabels bL bR) (docs aL aR)
docs aL aR =
pure (diffExprF aL aR)
diffExprE l@(Field {}) r =
mismatch l r
diffExprE l r@(Field {}) =
mismatch l r
diffExprE l@(Project {}) r@(Project {}) =
enclosed' " " (dot <> " ") (Data.List.NonEmpty.reverse (docs l r))
where
docs (Field aL bL) (Field aR bR) =
Data.List.NonEmpty.cons (diffLabel bL bR) (docs aL aR)
docs (Project aL bL) (Project aR bR) =
Data.List.NonEmpty.cons (diffLabels bL bR) (docs aL aR)
docs aL aR =
pure (diffExprF aL aR)
diffExprE l@(Project {}) r =
mismatch l r
diffExprE l r@(Project {}) =
mismatch l r
diffExprE l r =
diffExprF l r

36
src/Dhall/Parser.hs
View File

@ -26,9 +26,10 @@ import Control.Monad (MonadPlus)
import Data.ByteArray.Encoding (Base(..))
import Data.Functor (void)
import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
import Data.Sequence (ViewL(..))
import Data.Semigroup (Semigroup(..))
import Data.Scientific (Scientific)
import Data.Semigroup (Semigroup(..))
import Data.Sequence (ViewL(..))
import Data.Set (Set)
import Data.String (IsString(..))
import Data.Text.Lazy (Text)
import Data.Text.Lazy.Builder (Builder)
@ -50,6 +51,7 @@ import qualified Data.HashMap.Strict.InsOrd
import qualified Data.HashSet
import qualified Data.List
import qualified Data.Sequence
import qualified Data.Set
import qualified Data.Text
import qualified Data.Text.Lazy
import qualified Data.Text.Lazy.Builder
@ -286,6 +288,29 @@ label = (do
whitespace
return t ) <?> "label"
noDuplicates :: Ord a => [a] -> Parser (Set a)
noDuplicates = go Data.Set.empty
where
go found [] = return found
go found (x:xs) =
if Data.Set.member x found
then fail "Duplicate key"
else go (Data.Set.insert x found) xs
labels :: Parser (Set Text)
labels = do
_openBrace
xs <- nonEmptyLabels <|> emptyLabels
_closeBrace
return xs
where
emptyLabels = pure Data.Set.empty
nonEmptyLabels = do
x <- label
xs <- many (do _ <- _comma; label)
noDuplicates (x : xs)
doubleQuotedChunk :: Parser a -> Parser (Chunks Src a)
doubleQuotedChunk embedded =
choice
@ -1190,8 +1215,11 @@ applicationExpression embedded = do
selectorExpression :: Parser a -> Parser (Expr Src a)
selectorExpression embedded = noted (do
a <- primitiveExpression embedded
b <- many (try (do _dot; label))
return (foldl Field a b) )
let left x e = Field e x
let right xs e = Project e xs
b <- many (try (do _dot; fmap left label <|> fmap right labels))
return (foldl (\e k -> k e) a b) )
primitiveExpression :: Parser a -> Parser (Expr Src a)
primitiveExpression embedded =

17
src/Dhall/Pretty/Internal.hs
View File

@ -21,6 +21,7 @@ module Dhall.Pretty.Internal (
, prettyConst
, prettyLabel
, prettyLabels
, prettyNatural
, prettyNumber
, prettyScientific
@ -59,6 +60,7 @@ import Data.Foldable
import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
import Data.Monoid ((<>))
import Data.Scientific (Scientific)
import Data.Set (Set)
import Data.Text.Lazy (Text)
import Data.Text.Lazy.Builder (Builder)
import Data.Text.Prettyprint.Doc (Doc, Pretty, space)
@ -71,6 +73,7 @@ import qualified Data.Char
import qualified Data.HashMap.Strict.InsOrd
import qualified Data.HashSet
import qualified Data.List
import qualified Data.Set
import qualified Data.Text.Lazy as Text
import qualified Data.Text.Lazy.Builder as Builder
import qualified Data.Text.Prettyprint.Doc as Pretty
@ -277,6 +280,13 @@ prettyLabel a = label doc
-> Pretty.pretty a
_ -> backtick <> Pretty.pretty a <> backtick
prettyLabels :: Set Text -> Doc Ann
prettyLabels a
| Data.Set.null a =
lbrace <> rbrace
| otherwise =
braces (map (duplicate . prettyLabel) (Data.Set.toList a))
prettyNumber :: Integer -> Doc Ann
prettyNumber = literal . Pretty.pretty
@ -662,9 +672,10 @@ prettyExprD a0 = case a0 of
docs b = [ prettyExprE b ]
prettyExprE :: Pretty a => Expr s a -> Doc Ann
prettyExprE (Field a b) = prettyExprE a <> dot <> prettyLabel b
prettyExprE (Note _ b) = prettyExprE b
prettyExprE a = prettyExprF a
prettyExprE (Field a b) = prettyExprE a <> dot <> prettyLabel b
prettyExprE (Project a b) = prettyExprE a <> dot <> prettyLabels b
prettyExprE (Note _ b) = prettyExprE b
prettyExprE a = prettyExprF a
prettyExprF :: Pretty a => Expr s a -> Doc Ann
prettyExprF (Var a) =

14
src/Dhall/Tutorial.hs
View File

@ -602,6 +602,20 @@ import Dhall
-- > >>> input auto "{ foo = True, bar = 2, baz = 4.2 }.baz" :: IO Double
-- > 4.2
--
-- ... and you can project out multiple fields into a new record using this
-- syntax:
--
-- > someRecord.{ field₀, field₁, … }
--
-- For example:
--
-- > $ dhall
-- > { x = 1, y = True, z = "ABC" }.{ x, y }
-- > <Ctrl-D>
-- > { x : Integer, y : Bool }
-- >
-- > { x = 1, y = True }
--
-- __Exercise__: What is the type of this record:
--
-- > { foo = 1

33
src/Dhall/TypeCheck.hs
View File

@ -28,7 +28,7 @@ import Data.Sequence (Seq, ViewL(..))
import Data.Set (Set)
import Data.Text.Lazy (Text)
import Data.Text.Lazy.Builder (Builder)
import Data.Text.Prettyprint.Doc (Pretty(..))
import Data.Text.Prettyprint.Doc (Doc, Pretty(..))
import Data.Traversable (forM)
import Data.Typeable (Typeable)
import Dhall.Core (Const(..), Chunks(..), Expr(..), Var(..))
@ -47,11 +47,17 @@ import qualified Dhall.Context
import qualified Dhall.Core
import qualified Dhall.Diff
import qualified Dhall.Pretty
import qualified Dhall.Pretty.Internal
traverseWithIndex_ :: Applicative f => (Int -> a -> f b) -> Seq a -> f ()
traverseWithIndex_ k xs =
Data.Foldable.sequenceA_ (Data.Sequence.mapWithIndex k xs)
docToLazyText :: Doc a -> Text
docToLazyText = Pretty.renderLazy . Pretty.layoutPretty opts
where
opts = Pretty.LayoutOptions { Pretty.layoutPageWidth = Pretty.Unbounded }
axiom :: Const -> Either (TypeError s a) Const
axiom Type = return Kind
axiom Kind = Left (TypeError Dhall.Context.empty (Const Kind) Untyped)
@ -691,7 +697,24 @@ typeWithA tpa = loop
case Data.HashMap.Strict.InsOrd.lookup x kts of
Just t' -> return t'
Nothing -> Left (TypeError ctx e (MissingField x t))
_ -> Left (TypeError ctx e (NotARecord x r t))
_ -> do
let text = docToLazyText (Dhall.Pretty.Internal.prettyLabel x)
Left (TypeError ctx e (NotARecord text r t))
loop ctx e@(Project r xs ) = do
t <- fmap Dhall.Core.normalize (loop ctx r)
case t of
Record kts -> do
_ <- loop ctx t
let process k =
case Data.HashMap.Strict.InsOrd.lookup k kts of
Just t' -> return (k, t')
Nothing -> Left (TypeError ctx e (MissingField k t))
let adapt = Record . Data.HashMap.Strict.InsOrd.fromList
fmap adapt (traverse process (Data.Set.toList xs))
_ -> do
let text = docToLazyText (Dhall.Pretty.Internal.prettyLabels xs)
Left (TypeError ctx e (NotARecord text r t))
loop ctx (Note s e' ) = case loop ctx e' of
Left (TypeError ctx' (Note s' e'') m) -> Left (TypeError ctx' (Note s' e'') m)
Left (TypeError ctx' e'' m) -> Left (TypeError ctx' (Note s e'') m)
@ -3042,7 +3065,7 @@ prettyTypeMessage (ConstructorsRequiresAUnionType expr0 expr1) = ErrorMessages {
txt0 = build expr0
txt1 = build expr1
prettyTypeMessage (NotARecord k expr0 expr1) = ErrorMessages {..}
prettyTypeMessage (NotARecord lazyText0 expr0 expr1) = ErrorMessages {..}
where
short = "Not a record"
@ -3087,7 +3110,7 @@ prettyTypeMessage (NotARecord k expr0 expr1) = ErrorMessages {..}
\ \n\
\────────────────────────────────────────────────────────────────────────────────\n\
\ \n\
\You tried to access a field named: \n\
\You tried to access the field(s): \n\
\ \n\
\↳ " <> txt0 <> " \n\
\ \n\
@ -3099,7 +3122,7 @@ prettyTypeMessage (NotARecord k expr0 expr1) = ErrorMessages {..}
\ \n\
\↳ " <> txt2 <> " \n"
where
txt0 = build k
txt0 = build lazyText0
txt1 = build expr0
txt2 = build expr1

1
tests/Normalization.hs
View File

@ -38,6 +38,7 @@ tutorialExamples :: TestTree
tutorialExamples =
testGroup "Tutorial examples"
[ shouldNormalize "⩓" "./tutorial/combineTypes/0"
, shouldNormalize "projection" "./tutorial/projection/0"
]
preludeExamples :: TestTree

1
tests/normalization/tutorial/projection/0A.dhall Normal file
View File

@ -0,0 +1 @@
{ x = 1, y = True, z = "ABC" }.{ x, y }

1
tests/normalization/tutorial/projection/0B.dhall Normal file
View File

@ -0,0 +1 @@
{ x = 1, y = True }