Commits

Patrick Bahr committed f40cd3c Merge

merge

  • Participants
  • Parent commits 79228c2, 78d50a8
  • Tags version_0.4

Comments (0)

Files changed (16)

examples/Examples/MultiParam/DesugarEval.hs

          [''Const, ''Lam, ''App, ''Op, ''IfThenElse, ''Sug])
 $(derive [makeHFoldable, makeHTraversable]
          [''Const, ''App, ''Op])
-$(derive [smartConstructors] [''Fun])
 
 instance (Op :<: f, Const :<: f, Lam :<: f, App :<: f, HDifunctor f)
   => Desugar Sug f where
   desugHom' (Neg x)   = iConst (-1) `iMult` x
-  desugHom' (Let x y) = iLam y `iApp` x
+  desugHom' (Let x y) = inject (Lam y) `iApp` x
 
 -- Term evaluation algebra
 class Eval f v where
   evalAlg (App x y) = (projF x) y
 
 instance (Fun :<: v) => Eval Lam v where
-  evalAlg (Lam f) = iFun f
+  evalAlg (Lam f) = inject $ Fun f
 
 instance (Const :<: v) => Eval IfThenElse v where
   evalAlg (IfThenElse c v1 v2) = if projC c /= 0 then v1 else v2
 
 -- Example: evalEx = Just (iConst -6)
 evalEx :: Maybe (Term GValue Int)
-evalEx = evalG $ iLet (iConst 6) $ \x -> iNeg $ Place x
+evalEx = evalG $ iLet (iConst 6) $ \x -> iNeg x

examples/Examples/MultiParam/DesugarPos.hs

 instance (Op :<: f, Const :<: f, Lam :<: f, App :<: f, HDifunctor f)
   => Desugar Sug f where
   desugHom' (Neg x)   = iConst (-1) `iMult` x
-  desugHom' (Let x y) = iLam y `iApp` x
+  desugHom' (Let x y) = inject (Lam y) `iApp` x
 
 -- Example: desugPEx == iAApp (Pos 1 0)
--- (iALam (Pos 1 0) $ \x -> iAMult (Pos 1 2) (iAConst (Pos 1 2) (-1)) (Place x))
+-- (iALam (Pos 1 0) $ \x -> iAMult (Pos 1 2) (iAConst (Pos 1 2) (-1)) x)
 -- (iAConst (Pos 1 1) 6)
 desugPEx :: Term SigP Int
 desugPEx = desugarA (iALet (Pos 1 0)
                            (iAConst (Pos 1 1) 6)
-                           (\x -> iANeg (Pos 1 2) $ Place x :: Term SigP' Int))
+                           (\x -> iANeg (Pos 1 2) x :: Term SigP' Int))

examples/Examples/MultiParam/Eval.hs

          [''Const, ''Lam, ''App, ''Op])
 $(derive [makeHFoldable, makeHTraversable]
          [''Const, ''App, ''Op])
-$(derive [smartConstructors] [''Fun])
 
 -- Term evaluation algebra
 class Eval f v where
   evalAlg (App x y) = (projF x) y
 
 instance (Fun :<: v) => Eval Lam v where
-  evalAlg (Lam f) = iFun f
+  evalAlg (Lam f) = inject $ Fun f
 
 projC :: (Const :<: v) => Term v Int -> Int
 projC v = case project v of Just (Const n) -> n
 
 -- Example: evalEx = Just (iConst 4)
 evalEx :: Maybe (Term GValue Int)
-evalEx = evalG $ (iLam $ \x -> Place x `iAdd` Place x) `iApp` iConst 2
+evalEx = evalG $ (iLam $ \x -> x `iAdd` x) `iApp` iConst 2

examples/Examples/MultiParam/EvalI.hs

 
 -- Example: evalEx = 4
 evalEx :: Int
-evalEx = eval $ ((iLam $ \x -> Place x `iAdd` Place x) `iApp` iConst 2
-                 :: Term Sig Int)
+evalEx = eval $ ((iLam $ \x -> x `iAdd` x) `iApp` iConst 2 :: Term Sig Int)

examples/Examples/MultiParam/EvalM.hs

          [''Const, ''Lam, ''App, ''Op])
 $(derive [makeHFoldable, makeHTraversable]
          [''Const, ''App, ''Op])
-$(derive [smartConstructors] [''FunM])
 
 -- Term evaluation algebra.
 class EvalM f v where
                             (getCompose . f) =<< getCompose my
 
 instance (FunM Maybe :<: v) => EvalM Lam v where
-  evalAlgM (Lam f) = return $ iFunM f
+  evalAlgM (Lam f) = return $ inject $ FunM f
 
 projC :: (Const :<: v) => Term v Int -> Maybe Int
 projC v = case project v of
 
 -- Example: evalEx = Just (iConst 12) (3 * (2 + 2) = 12)
 evalMEx :: Maybe (Term GValue Int)
-evalMEx = evalMG $ (iLam $ \x -> iLam $ \y ->
-                                 Place y `iMult` (Place x `iAdd` Place x))
+evalMEx = evalMG $ (iLam $ \x -> iLam $ \y -> y `iMult` (x `iAdd` x))
                    `iApp` iConst 2 `iApp` iConst 3

examples/Examples/Param/DesugarEval.hs

          [''Const, ''Lam, ''App, ''Op, ''IfThenElse, ''Sug])
 $(derive [makeDitraversable]
          [''Const, ''App, ''Op])
-$(derive [smartConstructors] [''Fun])
 
 instance (Op :<: f, Const :<: f, Lam :<: f, App :<: f, Difunctor f)
   => Desugar Sug f where
   desugHom' (Neg x)   = iConst (-1) `iMult` x
-  desugHom' (Let x y) = iLam y `iApp` x
-  desugHom' Fix       = iLam $ \f ->
-                           (iLam $ \x -> Place f `iApp` (Place x `iApp` Place x))
-                           `iApp`
-                           (iLam $ \x -> Place f `iApp` (Place x `iApp` Place x))
+  desugHom' (Let x y) = inject (Lam y) `iApp` x
+  desugHom' Fix       = iLam $ \f -> (iLam $ \x -> f `iApp` (x `iApp` x)) `iApp`
+                                     (iLam $ \x -> f `iApp` (x `iApp` x))
 
 -- Term evaluation algebra
 class Eval f v where
   evalAlg (App x y) = (projF x) y
 
 instance (Fun :<: v) => Eval Lam v where
-  evalAlg (Lam f) = iFun f
+  evalAlg (Lam f) = inject $ Fun f
 
 instance (Const :<: v) => Eval IfThenElse v where
   evalAlg (IfThenElse c v1 v2) = if projC c /= 0 then v1 else v2
 fact = iFix `iApp`
        (iLam $ \f ->
           iLam $ \n ->
-              iIfThenElse
-              (Place n)
-              (Place n `iMult` (Place f `iApp` (Place n `iAdd` iConst (-1))))
-              (iConst 1))
+              iIfThenElse n  (n `iMult` (f `iApp` (n `iAdd` iConst (-1)))) (iConst 1))

examples/Examples/Param/DesugarPos.hs

 instance (Op :<: f, Const :<: f, Lam :<: f, App :<: f, Difunctor f)
   => Desugar Sug f where
   desugHom' (Neg x)   = iConst (-1) `iMult` x
-  desugHom' (Let x y) = iLam y `iApp` x
-  desugHom' Fix       = iLam $ \f ->
-                           (iLam $ \x -> Place f `iApp` (Place x `iApp` Place x))
-                           `iApp`
-                           (iLam $ \x -> Place f `iApp` (Place x `iApp` Place x))
+  desugHom' (Let x y) = inject (Lam y) `iApp` x
+  desugHom' Fix       = iLam $ \f -> (iLam $ \x -> f `iApp` (x `iApp` x)) `iApp`
+                                     (iLam $ \x -> f `iApp` (x `iApp` x))
 
 -- Example: desugPEx == iAApp (Pos 1 0)
---          (iALam (Pos 1 0) Place)
+--          (iALam (Pos 1 0) id)
 --          (iALam (Pos 1 1) $ \f ->
 --               iAApp (Pos 1 1)
 --                     (iALam (Pos 1 1) $ \x ->
---                          iAApp (Pos 1 1) (Place f) (iAApp (Pos 1 1) (Place x) (Place x)))
+--                          iAApp (Pos 1 1) f (iAApp (Pos 1 1) x x))
 --                     (iALam (Pos 1 1) $ \x ->
---                          iAApp (Pos 1 1) (Place f) (iAApp (Pos 1 1) (Place x) (Place x))))
+--                          iAApp (Pos 1 1) f (iAApp (Pos 1 1) x  x)))
 desugPEx :: Term SigP
-desugPEx = desugarA (iALet (Pos 1 0) (iAFix (Pos 1 1)) Place :: Term SigP')
+desugPEx = desugarA (iALet (Pos 1 0) (iAFix (Pos 1 1)) id :: Term SigP')

examples/Examples/Param/Eval.hs

          [''Const, ''Lam, ''App, ''Op])
 $(derive [makeDitraversable]
          [''Const, ''App, ''Op])
-$(derive [smartConstructors] [''Fun])
 
 -- Term evaluation algebra
 class Eval f v where
   evalAlg (App x y) = (projF x) y
 
 instance (Fun :<: v) => Eval Lam v where
-  evalAlg (Lam f) = iFun f
+  evalAlg (Lam f) = inject $ Fun f
 
 projC :: (Const :<: v) => Term v -> Int
 projC v = case project v of Just (Const n) -> n
 
 -- Example: evalEx = Just (iConst 4)
 evalEx :: Maybe (Term GValue)
-evalEx = evalG $ (iLam $ \x -> Place x `iAdd` Place x) `iApp` iConst 2
+evalEx = evalG $ (iLam $ \x -> x `iAdd` x) `iApp` iConst 2

examples/Examples/Param/EvalM.hs

          [''Const, ''Lam, ''App, ''Op])
 $(derive [makeDitraversable]
          [''Const, ''App, ''Op])
-$(derive [smartConstructors] [''FunM])
 
 -- Term evaluation algebra. Note that we cannot use @AlgM Maybe f (Term v)@
 -- because that would force @FunM@ to have the type @e -> e@ rather than
                             f =<< my
 
 instance (FunM Maybe :<: v) => EvalM Lam v where
-  evalAlgM (Lam f) = return $ iFunM $ f . return
+  evalAlgM (Lam f) = return $ inject $ FunM $ f . return
 
 projC :: (Const :<: v) => Term v -> Maybe Int
 projC v = do Const n <- project v
 
 -- Example: evalEx = Just (iConst 12) (3 * (2 + 2) = 12)
 evalMEx :: Maybe (Term GValue)
-evalMEx = evalMG $ (iLam $ \x -> iLam $ \y ->
-                                 Place y `iMult` (Place x `iAdd` Place x))
+evalMEx = evalMG $ (iLam $ \x -> iLam $ \y -> y `iMult` (x `iAdd` x))
                    `iApp` iConst 2 `iApp` iConst 3

examples/Examples/Param/Parsing.hs

 $(derive [makeDifunctor, makeDitraversable, makeEqD, makeShowD, smartConstructors]
          [''Const, ''Lam, ''App, ''Op, ''Abs, ''Var])
 
-type TransM = Reader (Map VarId Any)
+type TransM f = Reader (Map VarId (Term f))
 
 class PHOASTrans f g where
-  transAlg :: Alg f (TransM (Term g))
+  transAlg :: Alg f (TransM g (Term g))
 
 $(derive [liftSum] [''PHOASTrans])
 
 -- default translation
-instance (f :<: g, Ditraversable f TransM Any) => PHOASTrans f g where
+instance (f :<: g, Ditraversable f (TransM g) Any) => PHOASTrans f g where
   transAlg x = liftM inject $ disequence $ dimap (return . Place) id x
 
 instance (Lam :<: g) => PHOASTrans Abs g where
                           return $ iLam $ \y -> runReader b (Map.insert x y env)
 
 instance PHOASTrans Var g where
-  transAlg (Var x) = liftM (Place . fromJust) $ asks $ Map.lookup x
+  transAlg (Var x) = liftM fromJust $ asks $ Map.lookup x
 
 trans :: Term Sig -> Term Sig'
 trans x = runReader (cata transAlg x) Map.empty
 
--- Example: evalEx = iLam $ \a -> iApp (iLam $ \b -> iLam $ \c -> hole b) (hole a)
+-- Example: evalEx = iLam $ \a -> iApp (iLam $ \b -> iLam $ \c -> b) a
 transEx :: Term Sig'
 transEx = trans $ iAbs "y" $ (iAbs "x" $ iAbs "y" $ iVar "x") `iApp` (iVar "y")

src/Data/Comp/MultiParam/Derive/SmartAConstructors.hs

 -- Stability   :  experimental
 -- Portability :  non-portable (GHC Extensions)
 --
--- Automatically derive smart constructors with annotations.
+-- Automatically derive smart constructors with annotations for higher-order
+-- difunctors.
 --
 --------------------------------------------------------------------------------
 
 import Data.Comp.Derive.Utils
 import Data.Comp.MultiParam.Ops
 import Data.Comp.MultiParam.Term
+import Data.Comp.MultiParam.HDifunctor
 
 import Control.Monad
 
-{-| Derive smart constructors with products for a type constructor of any
-  parametric kind taking at least three arguments. The smart constructors are
-  similar to the ordinary constructors, but an 'injectA' is automatically
-  inserted. -}
+{-| Derive smart constructors with annotations for a higher-order difunctor. The
+ smart constructors are similar to the ordinary constructors, but a
+ 'injectA . hdimap Place id' is automatically inserted. -}
 smartAConstructors :: Name -> Q [Dec]
 smartAConstructors fname = do
     TyConI (DataD _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname
                 let pats = map varP (varPr : varNs)
                     vars = map varE varNs
                     val = appE [|injectA $(varE varPr)|] $
-                          appE [|inj|] $ foldl appE (conE name) vars
+                          appE [|inj . hdimap Place id|] $ foldl appE (conE name) vars
                     function = [funD sname [clause pats (normalB [|Term $val|]) []]]
                 sequence function

src/Data/Comp/MultiParam/Derive/SmartConstructors.hs

 -- Stability   :  experimental
 -- Portability :  non-portable (GHC Extensions)
 --
--- Automatically derive smart constructors for parametric types.
+-- Automatically derive smart constructors for higher-order difunctors.
 --
 --------------------------------------------------------------------------------
 
 import Data.Comp.Derive.Utils
 import Data.Comp.MultiParam.Sum
 import Data.Comp.MultiParam.Term
+import Data.Comp.MultiParam.HDifunctor
 import Control.Monad
 
-{-| Derive smart constructors for a type constructor of any parametric kind
- taking at least three arguments. The smart constructors are similar to the
- ordinary constructors, but an 'inject' is automatically inserted. -}
+{-| Derive smart constructors for a higher-order difunctor. The smart
+ constructors are similar to the ordinary constructors, but a
+ 'inject . hdimap Place id' is automatically inserted. -}
 smartConstructors :: Name -> Q [Dec]
 smartConstructors fname = do
     TyConI (DataD _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname
                     vars = map varE varNs
                     val = foldl appE (conE name) vars
                     sig = genSig targs tname sname args miTp
-                    function = [funD sname [clause pats (normalB [|inject $val|]) []]]
+                    function = [funD sname [clause pats (normalB [|inject (hdimap Place id $val)|]) []]]
                 sequence $ sig ++ function
               genSig targs tname sname 0 miTp = (:[]) $ do
                 hvar <- newName "h"

src/Data/Comp/Param/Derive/SmartAConstructors.hs

 -- Stability   :  experimental
 -- Portability :  non-portable (GHC Extensions)
 --
--- Automatically derive smart constructors with annotations.
+-- Automatically derive smart constructors with annotations for difunctors.
 --
 --------------------------------------------------------------------------------
 
 import Data.Comp.Derive.Utils
 import Data.Comp.Param.Ops
 import Data.Comp.Param.Term
+import Data.Comp.Param.Difunctor
 
 import Control.Monad
 
-{-| Derive smart constructors with products for a type constructor of any
-  parametric kind taking at least two arguments. The smart constructors are
-  similar to the ordinary constructors, but an 'injectA' is automatically
-  inserted. -}
+{-| Derive smart constructors with annotations for a difunctor. The smart
+ constructors are similar to the ordinary constructors, but a
+ 'injectA . dimap Place id' is automatically inserted. -}
 smartAConstructors :: Name -> Q [Dec]
 smartAConstructors fname = do
     TyConI (DataD _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname
                 let pats = map varP (varPr : varNs)
                     vars = map varE varNs
                     val = appE [|injectA $(varE varPr)|] $
-                          appE [|inj|] $ foldl appE (conE name) vars
+                          appE [|inj . dimap Place id|] $ foldl appE (conE name) vars
                     function = [funD sname [clause pats (normalB [|Term $val|]) []]]
                 sequence function

src/Data/Comp/Param/Derive/SmartConstructors.hs

 -- Stability   :  experimental
 -- Portability :  non-portable (GHC Extensions)
 --
--- Automatically derive smart constructors for parametric types.
+-- Automatically derive smart constructors for difunctors.
 --
 --------------------------------------------------------------------------------
 
 import Data.Comp.Derive.Utils
 import Data.Comp.Param.Sum
 import Data.Comp.Param.Term
+import Data.Comp.Param.Difunctor
 import Control.Monad
 
-{-| Derive smart constructors for a type constructor of any parametric kind
- taking at least two arguments. The smart constructors are similar to the
- ordinary constructors, but an 'inject' is automatically inserted. -}
+{-| Derive smart constructors for a difunctor. The smart constructors are
+ similar to the ordinary constructors, but a 'inject . dimap Place id' is
+ automatically inserted. -}
 smartConstructors :: Name -> Q [Dec]
 smartConstructors fname = do
     TyConI (DataD _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname
                     vars = map varE varNs
                     val = foldl appE (conE name) vars
                     sig = genSig targs tname sname args
-                    function = [funD sname [clause pats (normalB [|inject $val|]) []]]
+                    function = [funD sname [clause pats (normalB [|inject (dimap Place id $val)|]) []]]
                 sequence $ sig ++ function
               genSig targs tname sname 0 = (:[]) $ do
                 hvar <- newName "h"

testsuite/tests/Data/Comp/Examples/MultiParam.hs

 desugarEvalTest = DesugarEval.evalEx == Just (DesugarEval.iConst (-6))
 desugarPosTest = DesugarPos.desugPEx ==
                  DesugarPos.iAApp (DesugarPos.Pos 1 0)
-                                  (DesugarPos.iALam (DesugarPos.Pos 1 0) $ \x -> DesugarPos.iAMult (DesugarPos.Pos 1 2) (DesugarPos.iAConst (DesugarPos.Pos 1 2) (-1)) (Place x))
+                                  (DesugarPos.iALam (DesugarPos.Pos 1 0) $ \x -> DesugarPos.iAMult (DesugarPos.Pos 1 2) (DesugarPos.iAConst (DesugarPos.Pos 1 2) (-1)) x)
                                   (DesugarPos.iAConst (DesugarPos.Pos 1 1) 6)

testsuite/tests/Data/Comp/Examples/Param.hs

 desugarEvalTest = DesugarEval.evalEx == Just (DesugarEval.iConst 720)
 desugarPosTest = DesugarPos.desugPEx ==
                  DesugarPos.iAApp (DesugarPos.Pos 1 0)
-                                  (DesugarPos.iALam (DesugarPos.Pos 1 0) Place)
+                                  (DesugarPos.iALam (DesugarPos.Pos 1 0) id)
                                   (DesugarPos.iALam (DesugarPos.Pos 1 1) $ \f ->
                                        DesugarPos.iAApp (DesugarPos.Pos 1 1)
                                                         (DesugarPos.iALam (DesugarPos.Pos 1 1) $ \x ->
-                                                             DesugarPos.iAApp (DesugarPos.Pos 1 1) (Place f) (DesugarPos.iAApp (DesugarPos.Pos 1 1) (Place x) (Place x)))
+                                                             DesugarPos.iAApp (DesugarPos.Pos 1 1) f (DesugarPos.iAApp (DesugarPos.Pos 1 1) x x))
                                                         (DesugarPos.iALam (DesugarPos.Pos 1 1) $ \x ->
-                                                             DesugarPos.iAApp (DesugarPos.Pos 1 1) (Place f) (DesugarPos.iAApp (DesugarPos.Pos 1 1) (Place x) (Place x))))
-parsingTest = Parsing.transEx == (Parsing.iLam $ \a -> Parsing.iApp (Parsing.iLam $ \b -> Parsing.iLam $ \c -> Place b) (Place a))
+                                                             DesugarPos.iAApp (DesugarPos.Pos 1 1) f (DesugarPos.iAApp (DesugarPos.Pos 1 1) x x)))
+parsingTest = Parsing.transEx == (Parsing.iLam $ \a -> Parsing.iApp (Parsing.iLam $ \b -> Parsing.iLam $ \c -> b) a)