Split the Dhall.Syntax module

dhall/dhall.cabal

@@ -616,7 +616,10 @@ Library
         Dhall.Normalize
         Dhall.Parser.Combinators
         Dhall.Pretty.Internal
+        Dhall.Shift
         Dhall.Syntax
+        Dhall.Syntax.Import
+        Dhall.Syntax.Optics
         Dhall.URL
         Paths_dhall
     Autogen-Modules:

dhall/src/Dhall/Binary.hs

@@ -32,21 +32,23 @@ import Dhall.Syntax
     , Chunks (..)
     , Const (..)
     , DhallDouble (..)
-    , Directory (..)
     , Expr (..)
+    , FunctionBinding (..)
+    , MultiLet (..)
+    , PreferAnnotation (..)
+    , RecordField (..)
+    , Var (..)
+    )
+import Dhall.Syntax.Import
+    ( Directory (..)
     , File (..)
     , FilePrefix (..)
-    , FunctionBinding (..)
     , Import (..)
     , ImportHashed (..)
     , ImportMode (..)
     , ImportType (..)
-    , MultiLet (..)
-    , PreferAnnotation (..)
-    , RecordField (..)
     , Scheme (..)
     , URL (..)
-    , Var (..)
     )
 
 import Data.Foldable (toList)

dhall/src/Dhall/Core.hs

@@ -1,5 +1,7 @@
-{-# LANGUAGE RankNTypes      #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedLists   #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes        #-}
+{-# LANGUAGE RecordWildCards   #-}
 
 {-| This module contains the core calculus for the Dhall language.
 
@@ -76,24 +78,27 @@ module Dhall.Core (
     , Eval.textShow
     , censorExpression
     , censorText
-    , Syntax.desugarWith
+    , desugarWith
     ) where
 
 import Control.Exception      (Exception)
 import Control.Monad.IO.Class (MonadIO (..))
+import Data.List.NonEmpty     (NonEmpty (..))
 import Data.Text              (Text)
 import Dhall.Normalize
 import Dhall.Pretty.Internal
 import Dhall.Src              (Src (..))
 import Dhall.Syntax
+import Dhall.Syntax.Import
+import Dhall.Syntax.Optics
 import Instances.TH.Lift      ()
 import Lens.Family            (over)
 import Prettyprinter          (Pretty)
 
 import qualified Control.Exception
 import qualified Data.Text
 import qualified Dhall.Eval        as Eval
-import qualified Dhall.Syntax      as Syntax
+import qualified Dhall.Optics      as Optics
 
 -- | Pretty-print a value
 pretty :: Pretty a => a -> Text
@@ -145,6 +150,30 @@ throws (Left  e) = liftIO (Control.Exception.throwIO e)
 throws (Right r) = return r
 {-# INLINABLE throws #-}
 
+-- | Desugar all @with@ expressions
+desugarWith :: Expr s a -> Expr s a
+desugarWith = Optics.rewriteOf subExpressions rewrite
+  where
+    rewrite e@(With record (key :| []) value) =
+        Just
+            (Prefer
+                mempty
+                (PreferFromWith e)
+                record
+                (RecordLit [ (key, makeRecordField value) ])
+            )
+    rewrite e@(With record (key0 :| key1 : keys) value) =
+        Just
+            (Let
+                (makeBinding "_" record)
+                (Prefer mempty (PreferFromWith e) "_"
+                    (RecordLit
+                        [ (key0, makeRecordField $ With (Field "_" (FieldSelection Nothing key0 Nothing)) (key1 :| keys) (shift 1 "_" value)) ]
+                    )
+                )
+            )
+    rewrite _ = Nothing
+
 {- $setup
 >>> import qualified Codec.Serialise
 >>> import qualified Dhall.Binary

dhall/src/Dhall/Freeze.hs

@@ -24,13 +24,13 @@ module Dhall.Freeze
 import Data.Foldable       (for_)
 import Data.List.NonEmpty  (NonEmpty)
 import Data.Maybe          (fromMaybe)
-import Dhall.Pretty        (CharacterSet, detectCharacterSet)
-import Dhall.Syntax
+import Dhall.Core
     ( Expr (..)
     , Import (..)
     , ImportHashed (..)
     , ImportType (..)
     )
+import Dhall.Pretty        (CharacterSet, detectCharacterSet)
 import Dhall.Util
     ( Censor
     , CheckFailed (..)

dhall/src/Dhall/Import.hs

@@ -172,9 +172,8 @@ import Data.Maybe                 (fromMaybe)
 import Data.Text                  (Text)
 import Data.Typeable              (Typeable)
 import Data.Void                  (Void, absurd)
-import Dhall.TypeCheck            (TypeError)
 
-import Dhall.Syntax
+import Dhall.Core
     ( Chunks (..)
     , Directory (..)
     , Expr (..)
@@ -190,6 +189,7 @@ import Dhall.Syntax
     , recordFieldExprs
     )
 
+import Dhall.TypeCheck            (TypeError)
 import System.FilePath ((</>))
 import Text.Megaparsec (SourcePos (SourcePos), mkPos)
 
@@ -244,7 +244,7 @@ import qualified Text.Parser.Token
 
 {- $setup
 
-    >>> import Dhall.Syntax
+    >>> import Dhall.Syntax.Import
 -}
 
 -- | An import failed because of a cycle in the import graph

dhall/src/Dhall/Lint.hs

@@ -21,7 +21,7 @@ module Dhall.Lint
 import Control.Applicative ((<|>))
 import Data.List.NonEmpty  (NonEmpty (..))
 
-import Dhall.Syntax
+import Dhall.Core
     ( Binding (..)
     , Chunks (..)
     , Directory (..)

dhall/src/Dhall/Normalize.hs

@@ -14,7 +14,7 @@ module Dhall.Normalize (
     , ReifiedNormalizer (..)
     , judgmentallyEqual
     , subst
-    , Syntax.shift
+    , shift
     , isNormalized
     , isNormalizedWith
     , freeIn
@@ -26,6 +26,7 @@ import Data.Functor.Identity (Identity (..))
 import Data.List.NonEmpty    (NonEmpty (..))
 import Data.Sequence         (ViewL (..), ViewR (..))
 import Data.Traversable
+import Dhall.Shift           (shift)
 import Instances.TH.Lift     ()
 import Prelude               hiding (succ)
 
@@ -43,11 +44,12 @@ import Dhall.Syntax
 
 import qualified Data.Sequence
 import qualified Data.Set
-import qualified Data.Text     as Text
-import qualified Dhall.Eval    as Eval
+import qualified Data.Text           as Text
+import qualified Dhall.Eval          as Eval
 import qualified Dhall.Map
-import qualified Dhall.Syntax  as Syntax
-import qualified Lens.Family   as Lens
+import qualified Dhall.Syntax        as Syntax
+import qualified Dhall.Syntax.Optics as Syntax.Optics
+import qualified Lens.Family         as Lens
 
 {-| Returns `True` if two expressions are α-equivalent and β-equivalent and
     `False` otherwise
@@ -69,24 +71,24 @@ subst (V x n) e (Lam cs (FunctionBinding src0 y src1 src2 _A) b) =
     Lam cs (FunctionBinding src0 y src1 src2 _A') b'
   where
     _A' = subst (V x n )                         e  _A
-    b'  = subst (V x n') (Syntax.shift 1 (V y 0) e)  b
+    b'  = subst (V x n') (shift 1 (V y 0) e)  b
     n'  = if x == y then n + 1 else n
 subst (V x n) e (Pi cs y _A _B) = Pi cs y _A' _B'
   where
     _A' = subst (V x n )                         e  _A
-    _B' = subst (V x n') (Syntax.shift 1 (V y 0) e) _B
+    _B' = subst (V x n') (shift 1 (V y 0) e) _B
     n'  = if x == y then n + 1 else n
 subst v e (Var v') = if v == v' then e else Var v'
 subst (V x n) e (Let (Binding src0 f src1 mt src2 r) b) =
     Let (Binding src0 f src1 mt' src2 r') b'
   where
-    b' = subst (V x n') (Syntax.shift 1 (V f 0) e) b
+    b' = subst (V x n') (shift 1 (V f 0) e) b
       where
         n' = if x == f then n + 1 else n
 
     mt' = fmap (fmap (subst (V x n) e)) mt
     r'  =             subst (V x n) e  r
-subst x e expression = Lens.over Syntax.subExpressions (subst x e) expression
+subst x e expression = Lens.over Syntax.Optics.subExpressions (subst x e) expression
 
 {-| This function is used to determine whether folds like @Natural/fold@ or
     @List/fold@ should be lazy or strict in their accumulator based on the type
@@ -194,9 +196,9 @@ normalizeWithM ctx e0 = loop (Syntax.denote e0)
               case f' of
                 Lam _ (FunctionBinding _ x _ _ _A) b₀ -> do
 
-                    let a₂ = Syntax.shift 1 (V x 0) a'
+                    let a₂ = shift 1 (V x 0) a'
                     let b₁ = subst (V x 0) a₂ b₀
-                    let b₂ = Syntax.shift (-1) (V x 0) b₁
+                    let b₂ = shift (-1) (V x 0) b₁
 
                     loop b₂
                 _ ->
@@ -256,7 +258,7 @@ normalizeWithM ctx e0 = loop (Syntax.denote e0)
                         pure (TextLit (Chunks [] (Text.pack (show n))))
                     App (App ListBuild _A₀) g -> loop (App (App (App g list) cons) nil)
                       where
-                        _A₁ = Syntax.shift 1 "a" _A₀
+                        _A₁ = shift 1 "a" _A₀
 
                         list = App List _A₀
 
@@ -383,9 +385,9 @@ normalizeWithM ctx e0 = loop (Syntax.denote e0)
                             Just app' -> loop app'
     Let (Binding _ f _ _ _ r) b -> loop b''
       where
-        r'  = Syntax.shift   1  (V f 0) r
+        r'  = shift   1  (V f 0) r
         b'  = subst (V f 0) r' b
-        b'' = Syntax.shift (-1) (V f 0) b'
+        b'' = shift (-1) (V f 0) b'
     Annot x _ -> loop x
     Bool -> pure Bool
     BoolLit b -> pure (BoolLit b)
@@ -631,7 +633,7 @@ normalizeWithM ctx e0 = loop (Syntax.denote e0)
             RecordLit kvs ->
                 case Dhall.Map.lookup x kvs of
                     Just v  -> pure $ recordFieldValue v
-                    Nothing -> Field <$> (RecordLit <$> traverse (Syntax.recordFieldExprs loop) kvs) <*> pure k
+                    Nothing -> Field <$> (RecordLit <$> traverse (Syntax.Optics.recordFieldExprs loop) kvs) <*> pure k
             Project r_ _ -> loop (Field r_ k)
             Prefer cs _ (RecordLit kvs) r_ -> case Dhall.Map.lookup x kvs of
                 Just v -> pure (Field (Prefer cs PreferFromSource (singletonRecordLit v) r_) k)

dhall/src/Dhall/Parser.hs

@@ -25,11 +25,10 @@ import Control.Exception (Exception)
 import Data.Text         (Text)
 import Data.Void         (Void)
 import Dhall.Src         (Src (..))
-import Dhall.Syntax
 import Text.Megaparsec   (ParseErrorBundle (..), PosState (..))
 
 import qualified Data.Text       as Text
-import qualified Dhall.Core      as Core
+import           Dhall.Core      as Core
 import qualified Text.Megaparsec
 
 import Dhall.Parser.Combinators

dhall/src/Dhall/Parser/Expression.hs

@@ -14,6 +14,7 @@ import Data.List.NonEmpty      (NonEmpty (..))
 import Data.Text               (Text)
 import Dhall.Src               (Src (..))
 import Dhall.Syntax
+import Dhall.Syntax.Import
 import Text.Parser.Combinators (choice, try, (<?>))
 
 import qualified Control.Monad

dhall/src/Dhall/Parser/Token.hs

@@ -132,6 +132,7 @@ import Data.Functor            (void, ($>))
 import Data.Ratio              ((%))
 import Data.Text               (Text)
 import Dhall.Syntax
+import Dhall.Syntax.Import
 import Text.Parser.Combinators (choice, try, (<?>))
 
 import qualified Control.Monad              as Monad
@@ -671,7 +672,7 @@ pathComponent componentType = do
     let pathData =
             case componentType of
                 FileComponent ->
-                    Text.Megaparsec.takeWhile1P Nothing Dhall.Syntax.pathCharacter
+                    Text.Megaparsec.takeWhile1P Nothing Dhall.Syntax.Import.pathCharacter
                 URLComponent ->
                     star pchar
 

dhall/src/Dhall/Pretty/Internal.hs

@@ -96,6 +96,7 @@ import qualified Data.Maybe
 import qualified Data.Text                     as Text
 import qualified Data.Time                     as Time
 import qualified Dhall.Map                     as Map
+import qualified Dhall.Syntax.Optics           as Syntax.Optics
 import qualified Prettyprinter                 as Pretty
 import qualified Prettyprinter.Render.String   as Pretty
 import qualified Prettyprinter.Render.Terminal as Terminal
@@ -148,7 +149,7 @@ instance FromJSON CharacterSet where
 -- If any parts of the expression uses the Unicode syntax, the whole expression
 -- is deemed to be using the Unicode syntax.
 detectCharacterSet :: Expr Src a -> CharacterSet
-detectCharacterSet = foldOf (cosmosOf subExpressions . to exprToCharacterSet)
+detectCharacterSet = foldOf (cosmosOf Syntax.Optics.subExpressions . to exprToCharacterSet)
   where
     exprToCharacterSet = \case
         Embed _ -> mempty -- Don't go down the embed route, otherwise: <<loop>>

dhall/src/Dhall/Schemas.hs

@@ -20,11 +20,11 @@ import Control.Exception   (Exception)
 import Data.Maybe          (fromMaybe)
 import Data.Text           (Text)
 import Data.Void           (Void)
+import Dhall.Core          (Expr (..), Import, Var (..))
 import Dhall.Crypto        (SHA256Digest)
 import Dhall.Map           (Map)
 import Dhall.Pretty        (CharacterSet (..), detectCharacterSet)
 import Dhall.Src           (Src)
-import Dhall.Syntax        (Expr (..), Import, Var (..))
 import Dhall.Util
     ( Censor (..)
     , Header (..)
@@ -46,7 +46,6 @@ import qualified Dhall.Optics                       as Optics
 import qualified Dhall.Parser                       as Parser
 import qualified Dhall.Pretty
 import qualified Dhall.Substitution                 as Substitution
-import qualified Dhall.Syntax                       as Syntax
 import qualified Dhall.TypeCheck                    as TypeCheck
 import qualified Dhall.Util                         as Util
 import qualified Prettyprinter                      as Pretty
@@ -136,7 +135,7 @@ decodeSchemas (RecordLit keyValues) = do
     let typeMetadata = Data.Map.fromList $ do
             (name, (_Type, _default)) <- Map.toList m
 
-            return (Import.hashExpression (Syntax.denote _Type), (name, _default))
+            return (Import.hashExpression (Core.denote _Type), (name, _default))
 
     return typeMetadata
 decodeSchemas  _ =
@@ -174,7 +173,7 @@ rewriteWithSchemas _schemas expression = do
                     Left _ ->
                         empty
                     Right subExpressionType ->
-                        return (Import.hashExpression (Syntax.denote subExpressionType))
+                        return (Import.hashExpression (Core.denote subExpressionType))
 
                 (name, _default) <- Data.Map.lookup hash typeMetadata
 
@@ -196,10 +195,10 @@ rewriteWithSchemas _schemas expression = do
 
     let rewrittenExpression :: Expr Src Import
         rewrittenExpression =
-            fmap Void.absurd (Optics.transformOf Syntax.subExpressions schemasRewrite normalizedExpression)
+            fmap Void.absurd (Optics.transformOf Core.subExpressions schemasRewrite normalizedExpression)
 
     if Normalize.freeIn (V "schemas" 0) rewrittenExpression
-        then return (Let (Syntax.makeBinding "schemas" _schemas) rewrittenExpression)
+        then return (Let (Core.makeBinding "schemas" _schemas) rewrittenExpression)
         else return expression
 
 -- | Errors that can be thrown by `rewriteWithSchemas`