diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Changelog for composite-dhall + +## v0.0.1.0 + +* Add `ToDhall` and `FromDhall` instances for composite `Record`s. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2021 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,4 @@ +# composite-dhall + +`ToDhall` and `FromDhall` instances for +[composite](https://hackage.haskell.org/package/composite-base) records. diff --git a/composite-dhall.cabal b/composite-dhall.cabal new file mode 100644 --- /dev/null +++ b/composite-dhall.cabal @@ -0,0 +1,39 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: composite-dhall +version: 0.0.1.0 +synopsis: Dhall instances for composite records. +description: Dhall instances for composite records. +category: Dhall +author: Daniel Firth +maintainer: dan.firth@homotopic.tech +copyright: 2021 Daniel Firth +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://gitlab.com/homotopic-tech/composite-dhall + +library + exposed-modules: + Composite.Dhall + other-modules: + Paths_composite_dhall + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , composite-base >=0.7.0.0 && <0.7.7 + , dhall >=1.39.0 && <1.40 + , lens >=5.0.0 && <5.1 + , text >=1.0 && <1.4 + default-language: Haskell2010 diff --git a/src/Composite/Dhall.hs b/src/Composite/Dhall.hs new file mode 100644 --- /dev/null +++ b/src/Composite/Dhall.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Composite.Dhall () where + +import Composite.Record +import Composite.TH +import Control.Applicative +import qualified Control.Lens as L +import Data.Functor.Contravariant +import Data.Text (Text) +import qualified Data.Text as T +import Data.Void +import qualified Dhall as D +import Dhall.Core hiding (File, Text, field) +import Dhall.Map +import Dhall.Src +import GHC.TypeLits + +unsafeExpectRecordLit :: + Text -> Expr Src Void -> Dhall.Map.Map Text (RecordField Src Void) +unsafeExpectRecordLit _ (RecordLit kvs) = + kvs +unsafeExpectRecordLit name expression = + Dhall.Core.internalError + (name <> ": Unexpected constructor: " <> Dhall.Core.pretty expression) + +unsafeExpectRecord :: + Text -> Expr Src Void -> Dhall.Map.Map Text (RecordField Src Void) +unsafeExpectRecord _ (Record kts) = + kts +unsafeExpectRecord name expression = + Dhall.Core.internalError + (name <> ": Unexpected constructor: " <> Dhall.Core.pretty expression) + +instance D.ToDhall (Record '[]) where + injectWith = pure (D.Encoder {..}) + where + embed _ = RecordLit mempty + declared = Record mempty + +instance (KnownSymbol s, D.ToDhall (Record xs), D.ToDhall x) => D.ToDhall (Record (s :-> x ': xs)) where + injectWith = do + let f :: s :-> x + f = undefined + let name = valName f + let D.Encoder embedL declaredL = D.inject + let D.Encoder embedR declaredR = D.inject + let embed (s :*: xs) = RecordLit (Dhall.Map.insert name (Dhall.Core.makeRecordField (embedL $ s)) mapR) + where + mapR = unsafeExpectRecordLit "Composite Record" $ embedR xs + let declared = Record (Dhall.Map.insert name (Dhall.Core.makeRecordField (declaredL)) mapR) + where + mapR = unsafeExpectRecord "Composite Record" declaredR + pure $ D.Encoder {..} + +instance D.FromDhall (Record '[]) where + autoWith _ = D.Decoder {..} + where + extract _ = pure RNil + expected = pure $ Record (Dhall.Map.fromList []) + +instance (KnownSymbol s, D.FromDhall (Record xs), D.FromDhall x) => D.FromDhall (Record (s :-> x ': xs)) where + autoWith = do + let nL :: s :-> x + nL = undefined + + let nameL = valName nL + + D.Decoder extractL expectedL <- D.autoWith @x + + D.Decoder extractR expectedR <- D.autoWith @(Record xs) + + let ktsR = unsafeExpectRecord "Composite Record" <$> expectedR + + let expected = Record <$> (Dhall.Map.insert nameL . Dhall.Core.makeRecordField <$> expectedL <*> ktsR) + let extract expression = do + let die = D.typeError expected expression + + case expression of + RecordLit kvs -> + case Dhall.Core.recordFieldValue <$> Dhall.Map.lookup nameL kvs of + Just expressionL -> + liftA2 + (:*:) + (extractL expressionL) + (extractR expression) + _ -> die + _ -> die + pure (D.Decoder extract expected)