hypertypes 0.1.0.1 → 0.1.0.2

raw patch · 13 files changed

+40/−30 lines, 13 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• README.md +1/−1
• hypertypes.cabal +2/−2
• src/Hyper/Class/Functor.hs +3/−3
• src/Hyper/Class/Nodes.hs +1/−1
• src/Hyper/Combinator/ANode.hs +1/−1
• src/Hyper/Combinator/Ann.hs +1/−1
• src/Hyper/Combinator/Compose.hs +1/−1
• src/Hyper/Recurse.hs +1/−1
• src/Hyper/TH/Internal/Utils.hs +16/−9
• src/Hyper/TH/Morph.hs +8/−5
• src/Hyper/TH/Nodes.hs +3/−3
• src/Hyper/Unify/Generalize.hs +1/−1
• test/LangD.hs +1/−1

@@ -6,7 +6,7 @@  > The goal is to define a data type by cases, where one can add new cases to the data type and new functions over the data type, without recompiling existing code, and while retaining static type safety. -[*Data types a la carte*](http://www.cs.ru.nl/~W.Swierstra/Publications/DataTypesALaCarte.pdf) (DTALC, Swierstra, 2008) offers a solution for the expression problem which is only applicable for recursive expressions, without support for mutually recursive types. In practice, programming language ASTs do tend to be mutually recursive. [`multirec`](http://hackage.haskell.org/package/multirec) (Rodriguez et al, 2009) uses GADTs to encode mutually recursive types but in comparison to DTALC it lacks in the ability to construct the types from re-usable components.+[*Data types a la carte*](http://www.cs.ru.nl/~W.Swierstra/Publications/DataTypesALaCarte.pdf) (DTALC, Swierstra, 2008) offers a solution for the expression problem which is only applicable for simple recursive expressions, without support for mutually recursive types. In practice, programming language ASTs do tend to be mutually recursive. [`multirec`](http://hackage.haskell.org/package/multirec) (Rodriguez et al, 2009) uses GADTs to encode mutually recursive types but in comparison to DTALC it lacks in the ability to construct the types from re-usable components.  Hypertypes allow constructing expressions from re-usable terms like DTALC, which can be rich mutually recursive types like in `multirec`. 

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: d25a0b3f8c7b76db97429b9b8756f4f2966f3352a921733dd51db840869bb422+-- hash: 2cd28816c22eeee72d7eaf5cbf22e66156807737fd967437f6ccdd5108df3649  name:           hypertypes-version:        0.1.0.1+version:        0.1.0.2 synopsis:       Typed ASTs description:    Please see the README on GitHub at <https://github.com/lamdu/hypertypes#readme> category:       Algorithms, Compilers/Interpreters, Language, Logic, Unification

@@ -8,7 +8,7 @@     , hiso     ) where -import Control.Lens (Setter, Iso', sets, iso)+import Control.Lens (Setter, Iso', AnIso', sets, iso, cloneIso) import GHC.Generics import Hyper.Class.Nodes (HNodes(..), HWitness(..), _HWitness, (#>)) import Hyper.Type (type (#))@@ -66,6 +66,6 @@ -- TODO: Is there an equivalent for this in lens that we can name this after? hiso ::     HFunctor h =>-    (forall n. HWitness h n -> Iso' (p # n) (q # n)) ->+    (forall n. HWitness h n -> AnIso' (p # n) (q # n)) ->     Iso' (h # p) (h # q)-hiso f = iso (hmap (\w -> (^. f w))) (hmap (\w -> (f w #)))+hiso f = iso (hmap (\w -> (^. cloneIso (f w)))) (hmap (\w -> (cloneIso (f w) #)))

@@ -96,7 +96,7 @@ {-# INLINE (#*#) #-} (#*#) ::     (HNodes h, HNodesConstraint h c) =>-    Proxy c -> (HWitness h n -> (c n => r)) -> HWitness h n -> r+    Proxy c -> (c n => HWitness h n -> r) -> HWitness h n -> r (#*#) p r w = (p #> r) w w  -- | Defunctionalized HNodesConstraint which can be curried

@@ -41,4 +41,4 @@     data instance MorphWitness (ANode a) (ANode b) _ _ where         M_ANode :: MorphWitness (ANode a) (ANode b) a b     morphMap f = _ANode %~ f M_ANode-    morphLiftConstraint M_ANode _ = id+    morphLiftConstraint M_ANode _ x = x

@@ -29,7 +29,7 @@ instance RNodes h => HNodes (HFlip Ann h) where     type HNodesConstraint (HFlip Ann h) c = (Recursive c, c h)     type HWitnessType (HFlip Ann h) = HRecWitness h-    hLiftConstraint (HWitness HRecSelf) = const id+    hLiftConstraint (HWitness HRecSelf) = \_ x -> x     hLiftConstraint (HWitness (HRecSub w0 w1)) = hLiftConstraintH w0 w1  -- TODO: Dedup this and similar code in Hyper.Unify.Generalize

@@ -193,5 +193,5 @@     _Pure . _HCompose .     hiso     ( Proxy @(Recursively HFunctor) #>-        _HCompose . hiso ( Proxy @(Recursively HFunctor) #> _HCompose . decompose')+        _HCompose . hiso (Proxy @(Recursively HFunctor) #> _HCompose . decompose')     )

@@ -151,5 +151,5 @@ {-# INLINE (#**#) #-} (#**#) ::     (Recursive c, c h, RNodes h) =>-    Proxy c -> (HRecWitness h n -> (c n => r)) -> HRecWitness h n -> r+    Proxy c -> (c n => HRecWitness h n -> r) -> HRecWitness h n -> r (#**#) p r w = (p #>> r) w w

@@ -22,13 +22,14 @@ import           Hyper.Type (AHyperType(..), GetHyperType, type (:#)) import           Language.Haskell.TH import qualified Language.Haskell.TH.Datatype as D+import           Language.Haskell.TH.Datatype.TyVarBndr  import           Hyper.Internal.Prelude  data TypeInfo = TypeInfo     { tiName :: Name     , tiInstance :: Type-    , tiParams :: [TyVarBndr]+    , tiParams :: [TyVarBndrUnit]     , tiHyperParam :: Name     , tiConstructors :: [(Name, D.ConstructorVariant, [Either Type CtrTypePattern])]     } deriving Show@@ -69,10 +70,13 @@     case D.datatypeVars info of     [] -> fail "expected type constructor which requires arguments"     xs ->-        case last xs of-        KindedTV var (ConT aHyper) | aHyper == ''AHyperType -> pure (res, var)-        PlainTV var -> pure (res, var)-        _ -> fail "expected last argument to be a AHyperType variable"+        elimTV+        (pure . (,) res)+        ( \var c ->+            case c of+            ConT aHyper | aHyper == ''AHyperType -> pure (res, var)+            _ -> fail "expected last argument to be a AHyperType variable"+        ) (last xs)         where             res =                 foldl AppT (ConT (D.datatypeName info)) (init xs <&> VarT . D.tvName)@@ -219,8 +223,7 @@  makeNodeOf :: TypeInfo -> ([Type -> Q Con], NodeWitnesses) makeNodeOf info =-    ( (nodes <&> Lens._1 %~ nodeGadtType) <> (embeds <&> Lens._1 %~ embedGadtType)-        <&> \(t, n) c -> t c <&> GadtC [n] []+    ( (nodes <&> nodeGadtType) <> (embeds <&> embedGadtType)     , NodeWitnesses         { nodeWit = nodes & Map.fromList & getWit <&> \x -> [|HWitness $(conE x)|]         , embedWit = embeds & Map.fromList & getWit <&> \x -> [|HWitness . $(conE x)|]@@ -240,7 +243,7 @@         nodesForPat (InContainer _ pat) = nodesForPat pat         nodesForPat (FlatEmbed x) = tiConstructors x ^.. traverse . Lens._3 . traverse . Lens._Right >>= nodesForPat         nodesForPat _ = []-        nodeGadtType t n = n `AppT` t & pure+        nodeGadtType (t, n) c = gadtC [n] [] (pure (c `AppT` t))         embeds =             pats ^.. traverse . Lens._Right >>= embedsForPat & nub             <&> \t -> (t, mkName (embedBase <> mkNiceTypeName t))@@ -248,7 +251,11 @@         embedsForPat (InContainer _ pat) = embedsForPat pat         embedsForPat (FlatEmbed x) = tiConstructors x ^.. traverse . Lens._3 . traverse . Lens._Right >>= embedsForPat         embedsForPat _ = []-        embedGadtType t n = [t|HWitness $(pure t) $nodeVar -> $(pure n) $nodeVar|]+        embedGadtType (t, n) c =+            gadtC [n]+            [ bangType (bang noSourceUnpackedness noSourceStrictness)+                [t|HWitness $(pure t) $nodeVar|]+            ] [t|$(pure c) $nodeVar|]         nodeVar = mkName "node" & varT         getWit :: Map Type Name -> Type -> Name         getWit m h =

@@ -16,13 +16,14 @@ makeHMorph :: Name -> DecsQ makeHMorph typeName = makeTypeInfo typeName >>= makeHMorphForType +{-# ANN module "HLint: ignore Use id" #-} makeHMorphForType :: TypeInfo -> DecsQ makeHMorphForType info =     -- TODO: Contexts     instanceD (pure []) [t|HMorph $(pure src) $(pure dst)|]     [ D.tySynInstDCompat         ''MorphConstraint-        (Just [pure (PlainTV constraintVar)])+        (Just [pure (plainTV constraintVar)])         ([src, dst, VarT constraintVar] <&> pure)         (simplifyContext morphConstraint <&> toTuple)     , dataInstD@@ -56,9 +57,11 @@             let n = witPrefix <> mkNiceTypeName x & mkName in             ( x             , ( n-                , gadtC [n] []-                    [t|$(pure (ConT ''MorphWitness `appSubsts` x `AppT` varA `AppT` varB)) ->-                        $(pure morphWithNessOf) $(pure varA) $(pure varB)|])+                , gadtC [n]+                    [ bangType (bang noSourceUnpackedness noSourceStrictness)+                        (pure (ConT ''MorphWitness `appSubsts` x `AppT` varA `AppT` varB))+                    ] (pure (morphWithNessOf `AppT` varA `AppT` varB))+              )             )         witnesses = nodeWits <> embedWits & Map.fromList         varA = VarT (mkName "a")@@ -70,7 +73,7 @@             | otherwise =                 (nodeWits ^.. traverse . Lens._2 . Lens._1 <&> liftNodeConstraint) <>                 (embedWits ^.. traverse . Lens._2 . Lens._1 <&> liftEmbedConstraint)-        liftNodeConstraint n = clause [conP n [], wildP] (normalB [|id|]) []+        liftNodeConstraint n = clause [conP n [], wildP] (normalB [|\x -> x|]) []         liftEmbedConstraint n =             clause [conP n [varP varW], varP varProxy]             (normalB [|morphLiftConstraint $(varE varW) $(varE varProxy)|]) []

@@ -24,7 +24,7 @@     [ instanceD (simplifyContext (makeContext info)) [t|HNodes $(pure (tiInstance info))|]         [ D.tySynInstDCompat             ''HNodesConstraint-            (Just [pure (PlainTV constraintVar)])+            (Just [pure (plainTV constraintVar)])             [pure (tiInstance info), c]             (nodesConstraint >>= simplifyContext <&> toTuple)         , D.tySynInstDCompat ''HWitnessType Nothing [pure (tiInstance info)] witType@@ -39,7 +39,7 @@             | otherwise =                 ( tiParams info <&> varT . D.tvName & foldl appT (conT witTypeName)                 , [dataD (pure []) witTypeName-                    (tiParams info <> [PlainTV (mkName "node")])+                    (tiParams info <> [plainTV (mkName "node")])                     Nothing (nodeOfCons <&> (witType >>=)) []                     ]                 )@@ -69,7 +69,7 @@     | otherwise = clauses     where         clauses = (nodeWitCtrs wit <&> liftNode) <> (embedWitCtrs wit <&> liftEmbed)-        liftNode x = clause [conP 'HWitness [conP x []]] (normalB [|const id|]) []+        liftNode x = clause [conP 'HWitness [conP x []]] (normalB [|\_ r -> r|]) []         liftEmbed x =             clause [conP 'HWitness [conP x [varP witVar]]]             (normalB [|hLiftConstraint $(varE witVar)|]) []

@@ -49,7 +49,7 @@     type HNodesConstraint (HFlip GTerm a) c = (c a, Recursive c)     type HWitnessType (HFlip GTerm a) = HRecWitness a     {-# INLINE hLiftConstraint #-}-    hLiftConstraint (HWitness HRecSelf) = const id+    hLiftConstraint (HWitness HRecSelf) = \_ x -> x     hLiftConstraint (HWitness (HRecSub c n)) = hLiftConstraintH c n  hLiftConstraintH ::

@@ -6,8 +6,8 @@ newtype A i k = A (B i k) newtype B i k = B (i (k :# A i)) -makeHTraversableApplyAndBases ''A makeHTraversableApplyAndBases ''B+makeHTraversableApplyAndBases ''A  newtype C (k :: AHyperType) = C (C k) -- The following doesn't work: