add TH support for nested higher kinded types

dhall/src/Dhall/TH.hs

@@ -46,6 +46,7 @@ import Language.Haskell.TH.Syntax (DerivClause (..), DerivStrategy (..))
 
 import qualified Data.List as List
 import qualified Data.Map as Map
+import qualified Data.Maybe as Maybe
 import qualified Data.Set as Set
 import qualified Data.Text as Text
 import qualified Data.Time as Time
@@ -132,8 +133,6 @@ toNestedHaskellType
  -> Q Type
 toNestedHaskellType typeParams haskellTypes = loop
  where
- predicate dhallType haskellType = Core.judgmentallyEqual (code haskellType) dhallType
-
  document dhallType =
  mconcat
  [ "Unsupported nested type\n"
@@ -207,17 +206,91 @@ toNestedHaskellType typeParams haskellTypes = loop
 
  Var v
  | Just (V param index) <- List.find (v ==) typeParams -> do
- let name = Syntax.mkName $ (Text.unpack param) ++ (show index)
-
- return (VarT name)
+ return $ VarT $ Syntax.mkName $ (Text.unpack param) ++ (show index)
 
  | otherwise -> fail $ message v
 
- _ | Just haskellType <- List.find (predicate dhallType) haskellTypes -> do
- let name = Syntax.mkName (Text.unpack (typeName haskellType))
+ _ -> do
+ res <- mapM (judgementallyEqualNested dhallType) haskellTypes
+
+ maybe (fail $ message dhallType) return $ Maybe.listToMaybe $ Maybe.catMaybes res
+
+ haskellTypeToConT haskellType = ConT $ Syntax.mkName (Text.unpack (typeName haskellType))
+
+ judgementallyEqualNested dhallType haskellType = case partitionTypeVars (code haskellType) of
+ ([], haskellType')
+ | Core.judgmentallyEqual haskellType' dhallType -> 
+ return $ Just $ haskellTypeToConT haskellType
+
+ | otherwise -> return Nothing 
+
+ (params, bareHaskellType)
+ | Just nested <- gatherNestedVars Map.empty bareHaskellType dhallType -> do
+ let con = haskellTypeToConT haskellType
+
+ nestedTypes <- mapM (toNestedHaskellType typeParams haskellTypes)
+ $ Maybe.mapMaybe (`Map.lookup` nested) params
+
+ return $ Just $ foldr (flip AppT) con $ reverse nestedTypes
+
+ | otherwise -> return Nothing
+
+ gatherNestedVars nested haskellType dhallType = case (haskellType, dhallType) of
+
+ -- if haskellType has a typevar, store whatever the dhallType has unless
+ -- this typevar already has an existing dhalltype which doesn't match
+ ((Var v), newDhallType) -> case Map.lookup v nested of
+ Just oldDhallType
+ | Core.judgmentallyEqual oldDhallType newDhallType -> Just nested
+
+ | otherwise -> Nothing
+
+ Nothing -> Just $ Map.insert v newDhallType nested
 
- return (ConT name)
- | otherwise -> fail $ message dhallType
+ -- iterate through all records one level down
+ (Record m1, Record m2)
+ | Dhall.Map.keysSet m1 == Dhall.Map.keysSet m2
+ -> gatherNestedVarsAcross (Just nested)
+ $ Dhall.Map.elems
+ $ Dhall.Map.intersectionWith combineRec m1 m2
+
+ | otherwise -> Nothing
+
+ -- ditto for unions, except here we need to check if each alternate
+ -- has either no type or a matching type
+ (Union m1, Union m2) 
+ | Dhall.Map.keysSet m1 == Dhall.Map.keysSet m2 -> do
+ es <- sequence $ Dhall.Map.elems $ Dhall.Map.intersectionWith combineUnion m1 m2
+ gatherNestedVarsAcross (Just nested) $ Maybe.catMaybes es
+
+ | otherwise -> Nothing
+
+ -- otherwise there is nothing to store and no further levels into which
+ -- to drill futher, so compare directly
+ (i, j)
+ | Core.judgmentallyEqual i j -> Just nested
+
+ | otherwise -> Nothing
+
+ gatherNestedVarsAcross nested [] = nested
+ gatherNestedVarsAcross Nothing _ = Nothing
+ gatherNestedVarsAcross (Just nested) ((ht, dt):rest) =
+ gatherNestedVarsAcross (gatherNestedVars nested ht dt) rest
+
+ combineRec x y = (Core.recordFieldValue x, Core.recordFieldValue y)
+
+ combineUnion (Just x) (Just y) = Just (Just (x, y)) -- two alts with types (valid)
+ combineUnion Nothing Nothing = Just Nothing -- two alts with no types (valid)
+ combineUnion _ _ = Nothing -- anything else (invalid)
+
+
+-- | Split expression into type variables (from leading lambdas if present) and
+-- its nested expression.
+partitionTypeVars :: Expr s a -> ([Var], Expr s a)
+partitionTypeVars = first (reverse . numberConsecutive) . go []
+ where
+ go acc (Lam _ (FunctionBinding _ v _ _ _) rest) = go (v:acc) rest
+ go acc rest = (acc, rest)
 
 -- | A deriving clause for `Generic`.
 derivingGenericClause :: DerivClause
@@ -252,14 +325,9 @@ toDeclaration
  -> Q [Dec]
 toDeclaration generateOptions@GenerateOptions{..} haskellTypes typ =
  case typ of
- SingleConstructor{..} -> uncurry (fromSingle typeName constructorName) $ getTypeParams code
- MultipleConstructors{..} -> uncurry (fromMulti typeName) $ getTypeParams code
+ SingleConstructor{..} -> uncurry (fromSingle typeName constructorName) $ partitionTypeVars code
+ MultipleConstructors{..} -> uncurry (fromMulti typeName) $ partitionTypeVars code
  where
- getTypeParams = first numberConsecutive . getTypeParams_ []
-
- getTypeParams_ acc (Lam _ (FunctionBinding _ v _ _ _) rest) = getTypeParams_ (v:acc) rest
- getTypeParams_ acc rest = (acc, rest)
-
  derivingClauses = [ derivingGenericClause | generateFromDhallInstance || generateToDhallInstance ]
 
  interpretOptions = generateToInterpretOptions generateOptions typ
@@ -337,7 +405,7 @@ toDeclaration generateOptions@GenerateOptions{..} haskellTypes typ =
 
 -- | Number each variable, starting at 0
 numberConsecutive :: [Text.Text] -> [Var]
-numberConsecutive = snd . List.mapAccumR go Map.empty . reverse
+numberConsecutive = reverse . snd . List.mapAccumR go Map.empty . reverse
  where
  go m k =
  let (i, m') = Map.updateLookupWithKey (\_ j -> Just $ j + 1) k m

dhall/tests/Dhall/Test/TH.hs

@@ -116,10 +116,16 @@ Dhall.TH.makeHaskellTypesWith (Dhall.TH.defaultGenerateOptions
  })
  [ SingleConstructor "MyHKSingle" "HKSingle" "./tests/th/HigherKindSingle.dhall"
  , MultipleConstructors "MyHKUnion" "./tests/th/HigherKindUnion.dhall"
+ , SingleConstructor "MyHKInnerS" "HKInnerS" "(./tests/th/HigherKindNested.dhall).InnerS"
+ , MultipleConstructors "MyHKInnerU" "(./tests/th/HigherKindNested.dhall).InnerU"
+ , SingleConstructor "MyHKOuter" "HKOuter" "(./tests/th/HigherKindNested.dhall).Outer"
  ]
 
 type MyHKSingle_ = MyHKSingle Maybe Int
 type MyHKUnion_ = MyHKUnion Bool Int
+type MyHKInnerS_ = MyHKInnerS Bool Data.Text.Text
+type MyHKInnerU_ = MyHKInnerU Int Data.Text.Text
+type MyHKOuter_ = MyHKOuter Bool Int
 
 deriving instance Eq MyHKSingle_
 deriving instance Show MyHKSingle_
@@ -133,6 +139,24 @@ deriving instance Dhall.Generic MyHKUnion_
 instance Dhall.FromDhall MyHKUnion_
 instance Dhall.ToDhall MyHKUnion_
 
+deriving instance Eq MyHKInnerS_
+deriving instance Show MyHKInnerS_
+deriving instance Dhall.Generic MyHKInnerS_
+instance Dhall.FromDhall MyHKInnerS_
+instance Dhall.ToDhall MyHKInnerS_
+
+deriving instance Eq MyHKInnerU_
+deriving instance Show MyHKInnerU_
+deriving instance Dhall.Generic MyHKInnerU_
+instance Dhall.FromDhall MyHKInnerU_
+instance Dhall.ToDhall MyHKInnerU_
+
+deriving instance Eq MyHKOuter_
+deriving instance Show MyHKOuter_
+deriving instance Dhall.Generic MyHKOuter_
+instance Dhall.FromDhall MyHKOuter_
+instance Dhall.ToDhall MyHKOuter_
+
 testMakeHaskellTypesWith :: TestTree
 testMakeHaskellTypesWith = Tasty.HUnit.testCase "makeHaskellTypesWith" $ do
  let text0 = "let T = ./tests/th/example.dhall in T.A { x = True, y = [] : List Text }"
@@ -167,6 +191,10 @@ testMakeHaskellTypesWith = Tasty.HUnit.testCase "makeHaskellTypesWith" $ do
  refHKUnion1 = MyBar 1 :: MyHKUnion_
  myTest textHKUnion1 refHKUnion1
 
+ let textHKOuter = "let T = (./tests/th/HigherKindNested.dhall) in T.Outer Bool Int { oFoo = { iFoo = True, iBar = \"\" }, oBar = T.InnerU.Ifoo +1 }"
+ refHKOuter = MyHKOuter { myObar = MyIfoo 1, myOfoo = (MyHKInnerS { myIbar = "", myIfoo = True }) } :: MyHKOuter_
+ myTest textHKOuter refHKOuter
+
  where
  myTest text ref = do
  expr <- Dhall.inputExpr text

dhall/tests/th/HigherKindNested.dhall

@@ -0,0 +1,10 @@
+let InnerS = \(x : Type) -> \(y : Type) -> { ifoo : x, ibar : y }
+
+let InnerU = \(x : Type) -> \(y : Type) -> < Ifoo : x | Ibar : y >
+
+let Outer =
+ \(i : Type) ->
+ \(j : Type) ->
+ { ofoo : InnerS i Text, obar : InnerU j Text }
+
+in { InnerS, InnerU, Outer }