syntactic 1.7.1 → 1.8

raw patch · 4 files changed

+23/−20 lines, 4 files

Files

• examples/NanoFeldspar/Core.hs +5/−5
• examples/NanoFeldspar/Extra.hs +1/−1
• src/Language/Syntactic/Sharing/SimpleCodeMotion.hs +16/−11
• syntactic.cabal +1/−3

@@ -165,23 +165,23 @@  -- | Show the expression showExpr :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> String-showExpr = render . reifySmart canShareDict+showExpr = render . reifySmart (const True) canShareDict  -- | Print the expression printExpr :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> IO ()-printExpr = Syntactic.printExpr . reifySmart canShareDict+printExpr = Syntactic.printExpr . reifySmart (const True) canShareDict  -- | Draw the syntax tree using ASCII showAST :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> String-showAST = Syntactic.showAST . reifySmart canShareDict+showAST = Syntactic.showAST . reifySmart (const True) canShareDict  -- | Draw the syntax tree on the terminal using ASCII drawAST :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> IO ()-drawAST = Syntactic.drawAST . reifySmart canShareDict+drawAST = Syntactic.drawAST . reifySmart (const True) canShareDict  -- | Evaluation eval :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> Internal a-eval = evalBind . reifySmart canShareDict+eval = evalBind . reifySmart (const True) canShareDict   

@@ -82,7 +82,7 @@ reifySimp :: (Syntactic a, Domain a ~ FeldDomainAll) =>     a -> ASTF ((FODomain (Let :+: (FeldDomain :|| Eq :| Show))) Typeable Top) (Internal a) reifySimp = flip evalState 0 .-    (   codeMotion prjDictFO canShareDict+    (   codeMotion (const True) prjDictFO canShareDict     .   optimize constFold     <=< reifyM     .   desugar

@@ -120,11 +120,12 @@ -- | Choose a sub-expression to share choose :: forall dom a     .  AlphaEq dom dom dom [(VarId,VarId)]-    => PrjDict dom+    => (forall c. ASTF dom c -> Bool)+    -> PrjDict dom     -> MkInjDict dom     -> ASTF dom a     -> Maybe (Chosen dom a)-choose pd mkId a = chooseEnv initEnv a+choose hoistOver pd mkId a = chooseEnv initEnv a   where     initEnv = Env         { inLambda     = False@@ -137,7 +138,9 @@         | liftable pd env b         , Just id <- mkId b a         = Just $ Chosen id b-    chooseEnv env b = chooseEnvSub env b+    chooseEnv env b+        | hoistOver b = chooseEnvSub env b+        | otherwise       = Nothing      -- | Like 'chooseEnv', but does not consider the top expression for sharing     chooseEnvSub :: Env dom -> AST dom b -> Maybe (Chosen dom a)@@ -159,27 +162,28 @@     .  ( ConstrainedBy dom Typeable        , AlphaEq dom dom dom [(VarId,VarId)]        )-    => PrjDict dom+    => (forall c. ASTF dom c -> Bool)  -- ^ Control wether a sub-expression can be hoisted over the given expression+    -> PrjDict dom     -> MkInjDict dom     -> ASTF dom a     -> State VarId (ASTF dom a)-codeMotion pd mkId a-    | Just (Chosen id b) <- choose pd mkId a = share id b+codeMotion hoistOver pd mkId a+    | Just (Chosen id b) <- choose hoistOver pd mkId a = share id b     | otherwise = descend a   where     share :: InjDict dom b a -> ASTF dom b -> State VarId (ASTF dom a)     share id b = do-        b' <- codeMotion pd mkId b+        b' <- codeMotion hoistOver pd mkId b         v  <- get; put (v+1)         let x = Sym (injVariable id v)-        body <- codeMotion pd mkId $ substitute b x a+        body <- codeMotion hoistOver pd mkId $ substitute b x a         return             $  Sym (injLet id)             :$ b'             :$ (Sym (injLambda id v) :$ body)      descend :: AST dom b -> State VarId (AST dom b)-    descend (f :$ a) = liftM2 (:$) (descend f) (codeMotion pd mkId a)+    descend (f :$ a) = liftM2 (:$) (descend f) (codeMotion hoistOver pd mkId a)     descend a        = return a  @@ -198,10 +202,11 @@        , Domain a ~ HODomain dom p pVar        , p :< Typeable        )-    => MkInjDict (FODomain dom p pVar)+    => (forall c. ASTF (FODomain dom p pVar) c -> Bool)+    -> MkInjDict (FODomain dom p pVar)     -> a     -> ASTF (FODomain dom p pVar) (Internal a)-reifySmart mkId = flip evalState 0 . (codeMotion prjDictFO mkId <=< reifyM . desugar)+reifySmart hoistOver mkId = flip evalState 0 . (codeMotion hoistOver prjDictFO mkId <=< reifyM . desugar)   

@@ -1,5 +1,5 @@ Name:           syntactic-Version:        1.7.1+Version:        1.8 Synopsis:       Generic abstract syntax, and utilities for embedded languages Description:    This library provides:                 .@@ -174,8 +174,6 @@   hs-source-dirs: tests examples    main-is: NanoFeldsparTree.hs--  other-modules:    default-language: Haskell2010