Implement block anaphora (#65)

* Extend anaphora logic to allow block anaphora

* Implement block anaphora.

Author: gmorpheme

src/Eucalypt/Core/Anaphora.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-|
 Module      : Eucalypt.Core.Syn
 Description : Facilities for handling anaphoric params in Eucalypt syntax
@@ -13,21 +14,25 @@ module Eucalypt.Core.Anaphora where
 -- syntax, notably expression anaphora ('_', '_0', '_1'), and string
 -- anaphora ({}, {0}, {1}).
 --
--- This typeclass allows us to treat them similarly
-class (Eq a, Show a) => Anaphora a where
+-- This typeclass allows us to treat them similarly.
+--
+-- 't' is the anaphor type (block, expression, string...)
+-- 'a' is the binding name type that expresses the anaphor (e.g.
+-- 'CoreBindingName' or 'Var')
+class (Eq a, Show a) => Anaphora t a where
 
   -- | The unnumberedAnaphor for this type (e.g. '_') where the index
   -- is implicitly inferred from sequenc
-  unnumberedAnaphor :: a
+  unnumberedAnaphor :: t -> a
 
   -- | Is a an anaphor (numbered or not)
-  isAnaphor :: a -> Bool
+  isAnaphor :: t -> a -> Bool
 
   -- | Read the index from an anaphor if it is numbered
-  toNumber :: a -> Maybe Int
+  toNumber :: t -> a -> Maybe Int
 
   -- | Create an anaphor for the specified number
-  fromNumber :: Int -> a
+  fromNumber :: t -> Int -> a
 
   -- | A name for rendering
-  toName :: a -> String
+  toName :: t -> a -> String

src/Eucalypt/Core/BlockAnaphora.hs

@@ -0,0 +1,96 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-|
+Module      : Eucalypt.Core.BlockAnaphora
+Description : Process block anaphora to turn anaphoric blocks to lambdas
+Copyright   : (c) Greg Hawkins, 2018
+License     :
+Maintainer  : greg@curvelogic.co.uk
+Stability   : experimental
+-}
+module Eucalypt.Core.BlockAnaphora
+  ( anaphorise
+  , hasNakedBlockAnaphora
+  ) where
+
+import Bound
+import Data.Bifunctor (second)
+import Eucalypt.Core.Anaphora
+import Eucalypt.Core.Syn
+
+
+-- | Process block expressions containing block anaphora into lambdas.
+--
+-- This processing assumes that all CoreLets represent blocks and so
+-- should be applied early in the pipeline - directly after desugaring
+-- so that it is not disrupted by any transformations or optimisations
+-- which disturb lets.
+anaphorise :: (Anaphora SymbolicAnaphora a) => CoreExp a -> CoreExp a
+anaphorise = transform False
+
+
+
+-- | Search from this level to see if we have any block anaphora which
+-- are not contained within a block expression.
+hasNakedBlockAnaphora :: (Anaphora SymbolicAnaphora a) => CoreExp a -> Bool
+hasNakedBlockAnaphora (CoreVar _ n) = isAnaphor blockAnaphora n
+hasNakedBlockAnaphora CoreLet{} = False
+hasNakedBlockAnaphora (CoreLambda _ _ _ b) =
+  (hasNakedBlockAnaphora . fromScope) b
+hasNakedBlockAnaphora (CoreMeta _ m e) =
+  hasNakedBlockAnaphora m || hasNakedBlockAnaphora e
+hasNakedBlockAnaphora CoreBlock{} = False
+hasNakedBlockAnaphora (CoreList _ exprs) = any hasNakedBlockAnaphora exprs
+hasNakedBlockAnaphora (CoreArgTuple _ exprs) = any hasNakedBlockAnaphora exprs
+hasNakedBlockAnaphora (CoreOperator _ _ _ expr) = hasNakedBlockAnaphora expr
+hasNakedBlockAnaphora (CoreOpSoup _ exprs) = any hasNakedBlockAnaphora exprs
+hasNakedBlockAnaphora (CoreApply _ f xs) = any hasNakedBlockAnaphora (f : xs)
+hasNakedBlockAnaphora _ = False
+
+
+-- | Transform any anaphoric blocks into Lambdas
+transform :: (Anaphora SymbolicAnaphora a) => Bool -> CoreExp a -> CoreExp a
+transform True expr = expr
+transform False expr@(CoreLet smid bs b) =
+  if any hasNakedBlockAnaphora $ map fromScope (b : map snd bs)
+    then (bindAnaphora blockAnaphora . numberAnaphora blockAnaphora) expr
+    else let b' = toScope $ transform False (fromScope b)
+             bs' = map (second (toScope . transform False . fromScope)) bs
+          in CoreLet smid bs' b'
+transform False (CoreLambda smid inl ns b) =
+  let b' = toScope (transform False (fromScope b))
+   in CoreLambda smid inl ns b'
+transform False expr@(CoreMeta smid m e) =
+  let anaphoric = hasNakedBlockAnaphora expr
+      m' = transform anaphoric m
+      e' = transform anaphoric e
+   in CoreMeta smid m' e'
+transform False (CoreBlock smid e) =
+  let anaphoric = hasNakedBlockAnaphora e
+      e' = transform anaphoric e
+   in CoreBlock smid e'
+transform False (CoreList smid es) =
+  let anaphoric = any hasNakedBlockAnaphora es
+      es' = map (transform anaphoric) es
+  in CoreList smid es'
+transform False (CoreArgTuple smid es) =
+  let anaphoric = any hasNakedBlockAnaphora es
+      es' = map (transform anaphoric) es
+  in CoreArgTuple smid es'
+transform False (CoreOperator smid x p e) =
+  let anaphoric = hasNakedBlockAnaphora e
+      e' = transform anaphoric e
+  in CoreOperator smid x p e'
+transform False (CoreLookup smid o n) =
+  let anaphoric = hasNakedBlockAnaphora o
+      o' = transform anaphoric o
+  in CoreLookup smid o' n
+transform False expr@(CoreApply smid f xs) =
+  let anaphoric = hasNakedBlockAnaphora expr
+      f' = transform anaphoric f
+      xs' = map (transform anaphoric) xs
+   in CoreApply smid f' xs'
+transform False (CoreOpSoup smid xs) =
+  let anaphoric = any hasNakedBlockAnaphora xs
+      xs' = map (transform anaphoric) xs
+   in CoreOpSoup smid xs'
+transform False expr = expr

src/Eucalypt/Core/Cook.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE LambdaCase #-}
@@ -64,31 +65,37 @@ distributeFixities e = e
 
 -- | A core pass prior to evaluation to cook all soup that can be
 -- cooked.
-cookAllSoup :: Anaphora a => CoreExp a -> Interpreter (CoreExp a)
+cookAllSoup ::
+     (Anaphora SymbolicAnaphora a) => CoreExp a -> Interpreter (CoreExp a)
 cookAllSoup = Interpreter . cookBottomUp False
 
 -- | Entrypoint for evaluator if soup is discovered at runtime
-cook :: Anaphora a => [CoreExp a] -> Interpreter (CoreExp a)
+cook :: (Anaphora SymbolicAnaphora a) => [CoreExp a] -> Interpreter (CoreExp a)
 cook es = case cookSoup False es of
   Right expr -> return expr
   Left err -> throwEvalError err
 
 -- | Take sequence of expression in operator soup and rearrange into
 -- non-soup expression using operator fixity.
-cookSoup :: Anaphora a => Bool -> [CoreExp a] -> Either CoreError (CoreExp a)
+cookSoup ::
+     (Anaphora SymbolicAnaphora a)
+  => Bool
+  -> [CoreExp a]
+  -> Either CoreError (CoreExp a)
 cookSoup parentAnaphoric es = do
   subcooked <- cookSubsoups inAnaphoricLambda filled
   expr <- evalState shunt (initState subcooked inAnaphoricLambda)
   if wrap
-    then return $ (bindAnaphora . numberAnaphora) expr
+    then return $ processAnaphora expr
     else return expr
   where
     (filled, imAnaphoric) = precook es
     wrap = imAnaphoric && not parentAnaphoric
     inAnaphoricLambda = parentAnaphoric || imAnaphoric
+    processAnaphora = bindAnaphora expressionAnaphora . numberAnaphora expressionAnaphora
 
 cookScope ::
-     (Anaphora a, Eq b, Show b)
+     (Eq b, Show b, Anaphora SymbolicAnaphora a)
   => Bool
   -> Scope b CoreExp a
   -> Interpreter (Scope b CoreExp a)
@@ -99,18 +106,25 @@ cookScope anaphoric scope =
 --
 -- Go through each filling first so and determine whether there are
 -- anaphora at this level
-precook :: Anaphora a => [CoreExp a] -> ([CoreExp a], Bool)
+precook :: (Anaphora SymbolicAnaphora a) => [CoreExp a] -> ([CoreExp a], Bool)
 precook = fillGaps
 
 
 
 -- | Recurse down cooking any operator soups from the bottom upwards
-cookSubsoups :: Anaphora a => Bool -> [CoreExp a] -> Either CoreError [CoreExp a]
+cookSubsoups ::
+     (Anaphora SymbolicAnaphora a)
+  => Bool
+  -> [CoreExp a]
+  -> Either CoreError [CoreExp a]
 cookSubsoups anaphoric = mapM (cookBottomUp anaphoric)
 
 
 cookBottomUp ::
-     Anaphora a => Bool -> CoreExp a -> Either CoreError (CoreExp a)
+     (Anaphora SymbolicAnaphora a)
+  => Bool
+  -> CoreExp a
+  -> Either CoreError (CoreExp a)
 cookBottomUp anaphoric (CoreOpSoup _ exprs) = cookSoup anaphoric exprs
 cookBottomUp anaphoric (CoreArgTuple smid exprs) =
   CoreArgTuple smid <$> traverse (cookBottomUp anaphoric) exprs
@@ -133,7 +147,9 @@ cookBottomUp _ e = Right e
 
 
 -- | Run the shunting algorithm until finished or errored
-shunt :: Anaphora a => State (ShuntState a) (Either CoreError (CoreExp a))
+shunt ::
+     (Show a, Anaphora SymbolicAnaphora a)
+  => State (ShuntState a) (Either CoreError (CoreExp a))
 shunt = (shunt1 `untilM_` finished) >> result
   where
     finished = complete <$> get
@@ -157,7 +173,7 @@ data ShuntState a = ShuntState
   , shuntInsideAnaphoricLambda :: Bool
   } deriving (Show)
 
-initState :: Anaphora a => [CoreExp a] -> Bool -> ShuntState a
+initState :: [CoreExp a] -> Bool -> ShuntState a
 initState es anaphoric =
   ShuntState
     { shuntOutput = []
@@ -298,7 +314,10 @@ pushback e = state $ \s -> ((), s {shuntSource = e : shuntSource s})
 -- | Check the expression can be safely followed by what's coming up
 -- in next in the source and insert catenation operator or implicit
 -- parameter otherwise (giving us haskell style "sections" @(+)@ etc.)
-ensureValidSequence :: Anaphora a => Maybe (CoreExp a) -> State (ShuntState a) ()
+ensureValidSequence ::
+     (Anaphora SymbolicAnaphora a)
+  => Maybe (CoreExp a)
+  -> State (ShuntState a) ()
 ensureValidSequence lhs =
   peekSource >>= \rhs ->
   case validExprSeq lhs rhs of
@@ -307,7 +326,7 @@ ensureValidSequence lhs =
     Nothing -> return ()
 
 -- | A step of the shunting yard algorithm
-shunt1 :: Anaphora a => State (ShuntState a) ()
+shunt1 :: (Anaphora SymbolicAnaphora a) => State (ShuntState a) ()
 shunt1 =
   popNext >>= \case
     Just expr@CoreOperator {} -> ensureValidSequence (Just expr) >> seatOp expr
@@ -333,32 +352,38 @@ bindSides Nothing = (OpLike, OpLike)
 
 -- | Two exprs are valid together if one is OpLike and one is
 -- ValueLike on the sides that touch
-validExprSeq :: Anaphora a => Maybe (CoreExp a) -> Maybe (CoreExp a) -> Maybe (CoreExp a)
+validExprSeq ::
+     (Anaphora SymbolicAnaphora a)
+  => Maybe (CoreExp a)
+  -> Maybe (CoreExp a)
+  -> Maybe (CoreExp a)
 validExprSeq l r = filler ((snd . bindSides) l) ((fst . bindSides) r)
 
 -- | We can make an invalid sequence valid by inserting a catenation
 -- op or an anaphoric parameter
-filler :: Anaphora a => BindSide -> BindSide -> Maybe (CoreExp a)
+filler :: (Anaphora SymbolicAnaphora a) => BindSide -> BindSide -> Maybe (CoreExp a)
 filler ValueLike ValueLike = Just catOp
-filler OpLike OpLike = Just $ return unnumberedAnaphor
+filler OpLike OpLike = Just $ return $ unnumberedAnaphor expressionAnaphora
 filler _ _ = Nothing
 
 -- | Make a given expression valid by inserting catenation and
 -- anaphora as required and track whether the sequence contains any
 -- anaphora.
-fillGaps :: Anaphora a => [CoreExp a] -> ([CoreExp a], Bool)
+fillGaps :: (Anaphora SymbolicAnaphora a) => [CoreExp a] -> ([CoreExp a], Bool)
 fillGaps exprs =
   let (es, anaphoric) = foldl' accum ([], False) sides
-  in (reverse es, anaphoric)
+   in (reverse es, anaphoric)
   where
     sides = map Just exprs ++ [Nothing]
-    anaphoricMaybe = getAny . foldMap Any . fmap isAnaphoricVar
+    anaphoricMaybe =
+      getAny . foldMap Any . fmap (isAnaphoricVar expressionAnaphora)
     accum (l, b) e =
-      let (l', b') = case validExprSeq (headMay l) e of
-                       Just v
-                         | isAnaphoricVar v -> (v : l, True)
-                         | otherwise -> (v : l, b || anaphoricMaybe e)
-                       Nothing -> (l, b || anaphoricMaybe e)
-      in case e of
-        Just x -> (x: l', b')
-        Nothing -> (l', b')
+      let (l', b') =
+            case validExprSeq (headMay l) e of
+              Just v
+                | isAnaphoricVar expressionAnaphora v -> (v : l, True)
+                | otherwise -> (v : l, b || anaphoricMaybe e)
+              Nothing -> (l, b || anaphoricMaybe e)
+       in case e of
+            Just x -> (x : l', b')
+            Nothing -> (l', b')

src/Eucalypt/Core/Desugar.hs

@@ -290,9 +290,7 @@ translateBlock loc blk = do
 translateStringPattern :: SourceSpan -> [StringChunk] -> Translate CoreExpr
 translateStringPattern loc cs = do
   smid <- recordSpan loc
-  return $
-    bindAnaphora (numberAnaphora $ conc smid) >>= \(Reference v) ->
-      anon Syn.var v
+  return $ processAnaphora (conc smid) >>= \(Reference v) -> anon Syn.var v
   where
     sub :: StringChunk -> CoreExp Target
     sub (Interpolation InterpolationRequest {refTarget = t}) =
@@ -301,7 +299,7 @@ translateStringPattern loc cs = do
     exprs = map sub cs
     conc smid =
       Syn.app smid (anon Syn.bif "JOIN") [CoreList smid exprs, anon Syn.str ""]
-
+    processAnaphora = bindAnaphora () . numberAnaphora ()
 
 
 -- | Descend through the AST, translating to CoreExpr and recording