Implement dynamic instances of generalised lookup (#85)

* Enhance CoreLookup to allow optional default

* Restrict static gen lookup.

Was too eager and exposes extra vars to lookup blocks.

Also preserve SMIDs better on substitution

* Gen lookup to module & initial dynamic impl

* Implemented dynamic gen lookup.

Need to fix poor quality unique id in impl.

* Tidy ups.

src/Eucalypt/Core/AnonSyn.hs

@@ -39,6 +39,9 @@ lam = anon Syn.lam
 letexp :: [(Syn.CoreBindingName, Syn.CoreExpr)] -> Syn.CoreExpr -> Syn.CoreExpr
 letexp = anon Syn.letexp
 
+letblock :: [(Syn.CoreBindingName, Syn.CoreExpr)] -> Syn.CoreExpr -> Syn.CoreExpr
+letblock = anon Syn.letblock
+
 app :: Syn.CoreExp a -> [Syn.CoreExp a] -> Syn.CoreExp a
 app = anon Syn.app
 
@@ -78,3 +81,7 @@ corebool = anon Syn.corebool
 corelookup
   :: Syn.CoreExp a -> Syn.CoreRelativeName -> Syn.CoreExp a
 corelookup = anon Syn.corelookup
+
+dynlookup ::
+     Syn.CoreExp a -> Syn.CoreRelativeName -> Syn.CoreExp a -> Syn.CoreExp a
+dynlookup = anon Syn.dynlookup

src/Eucalypt/Core/BlockAnaphora.hs

@@ -50,12 +50,12 @@ 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) =
+transform False expr@(CoreLet smid bs b cl) =
   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'
+          in CoreLet smid bs' b' cl
 transform False (CoreLambda smid inl ns b) =
   let b' = toScope (transform False (fromScope b))
    in CoreLambda smid inl ns b'
@@ -80,10 +80,11 @@ 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) =
+transform False (CoreLookup smid o n d) =
   let anaphoric = hasNakedBlockAnaphora o
       o' = transform anaphoric o
-  in CoreLookup smid o' n
+      d' = transform anaphoric <$> d
+  in CoreLookup smid o' n d'
 transform False expr@(CoreApply smid f xs) =
   let anaphoric = hasNakedBlockAnaphora expr
       f' = transform anaphoric f

src/Eucalypt/Core/Cook.hs

@@ -21,6 +21,7 @@ import Data.List (foldl')
 import Data.Monoid
 import Eucalypt.Core.Anaphora
 import Eucalypt.Core.Error
+import Eucalypt.Core.GenLookup (eliminateLookupOp)
 import Eucalypt.Core.Syn
 import Safe (headMay)
 
@@ -44,7 +45,8 @@ throwEvalError = Interpreter . Left
 -- binding to (*) = (Lambda body)
 --
 distributeFixities :: CoreExp a -> CoreExp a
-distributeFixities (CoreLet smid bs b) = CoreLet smid prunedBindings newBody
+distributeFixities (CoreLet smid bs b _) =
+  CoreLet smid prunedBindings newBody OtherLet
   where
     newBody = modifyBoundVars bindSiteReplace $ distributeScopeFixities b
     distBindings =
@@ -137,7 +139,8 @@ cookBottomUp anaphoric (CoreApply smid f exprs) =
   traverse (cookBottomUp anaphoric) exprs
 cookBottomUp anaphoric (CoreLambda smid i n body) =
   CoreLambda smid i n <$> runInterpreter (cookScope anaphoric body)
-cookBottomUp anaphoric (CoreLet smid bs body) = CoreLet smid <$> newBindings <*> newBody
+cookBottomUp anaphoric (CoreLet smid bs body _) =
+  CoreLet smid <$> newBindings <*> newBody <*> pure OtherLet
   where
     newBody = runInterpreter (cookScope anaphoric body)
     newBindings =
@@ -230,7 +233,7 @@ popOne =
 formApply :: CoreExp a -> [CoreExp a] -> CoreExp a
 formApply (CoreBuiltin _ "*CALL*") [f, CoreArgTuple smid as] =
   CoreApply smid f as
-formApply (CoreBuiltin _ "*DOT*") [o, CoreName smid n] = CoreLookup smid o n
+formApply (CoreBuiltin _ "*DOT*") [o, x] = eliminateLookupOp o x
 formApply f as = CoreApply (sourceMapId f) f as
 
 -- | Apply the given operator to the argument(s) at the top of the

src/Eucalypt/Core/Desugar.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving  #-}
 {-|
-Module      : Eucalypt.Core.Syn
+Module      : Eucalypt.Core.Desugar
 Description : Desugar from surface syntax to core syntax
 Copyright   : (c) Greg Hawkins, 2018
 License     :
@@ -12,11 +12,10 @@ module Eucalypt.Core.Desugar
 where
 
 import Control.Monad.State.Strict
-import Data.Char (isUpper)
-import Data.List (isPrefixOf)
 import Data.Maybe (mapMaybe)
 import qualified Data.Set as S
 import Eucalypt.Core.Anaphora ()
+import Eucalypt.Core.GenLookup (processGenLookup)
 import Eucalypt.Core.Syn as Syn
 import Eucalypt.Core.SourceMap
 import Eucalypt.Core.Metadata
@@ -84,15 +83,6 @@ relativeName n =
 
 
 
--- | Names that aren't in lookup positions need to become variables or
--- builtins as appropriate
-name2Var :: SMID -> String -> CoreExpr
-name2Var smid n
-  | "__" `isPrefixOf` n && isUpper (n !! 2) = CoreBuiltin smid (drop 2 n)
-  | otherwise = CoreVar smid n
-
-
-
 -- | Ignore splices for now TODO: splice expressions
 declarations :: Block -> [Annotated DeclarationForm]
 declarations Located{locatee=(Block elements)} = mapMaybe toDecl elements
@@ -102,15 +92,6 @@ declarations Located{locatee=(Block elements)} = mapMaybe toDecl elements
 
 
 
--- | In contexts where single names should become variables (evaluand
--- rather than individual lookup elements for instance), this converts
--- to vars.
-varify :: CoreExpr -> CoreExpr
-varify (CoreName smid n) = name2Var smid n
-varify e = e
-
-
-
 -- | Record the current stack as a path into the namespaces with name
 -- of target and any associated documentation
 recordTarget :: String -> String -> Maybe String -> Translate ()
@@ -131,8 +112,8 @@ recordImports imports =
 
 -- | Process names to vars as appropriate for a context where the
 -- exprs will be statically bound
-interpretForStaticBoundContext :: [CoreExpr] -> [CoreExpr]
-interpretForStaticBoundContext exprs =
+varifyLookupTargets :: [CoreExpr] -> [CoreExpr]
+varifyLookupTargets exprs =
   zipWith toVar exprs (anon corenull : exprs)
   where
     toVar :: CoreExpr -> CoreExpr -> CoreExpr
@@ -143,26 +124,6 @@ interpretForStaticBoundContext exprs =
 
 
 
--- | Process static instances of generalised lookup
---
--- Assumes call operator is highest precedence
-processStaticGenLookup :: [CoreExpr] -> [CoreExpr]
-processStaticGenLookup =
-  result . head . dropWhile (not . done) . iterate stepOne . initState
-  where
-    initState es = ([], False, es)
-    stepOne (o@CoreLet {}:os, False, CoreOperator _ InfixLeft _ (CoreBuiltin _ "*DOT*"):es) =
-      (o : os, True, es)
-    stepOne (out, False, e:es) = (e : out, False, es)
-    stepOne (o@CoreLet {}:os, True, e:es) =
-      (rebody o (varify e) : os, False, es)
-    stepOne _ = error "Unhandled step while processing gen lookups"
-    done (_, _, []) = True
-    done _ = False
-    result (out, _, _) = reverse out
-
-
-
 -- | Desugar Ast op soup into core op soup (to be cooked into better
 -- tree later, once fixity and precedence of all ops is resolved).
 --
@@ -177,7 +138,7 @@ processStaticGenLookup =
 translateSoup :: [Expression] -> Translate CoreExpr
 translateSoup items =
   anon CoreOpSoup .
-  processStaticGenLookup . interpretForStaticBoundContext . concat <$>
+  processGenLookup . varifyLookupTargets . concat <$>
   traverse trans items
   where
     trans :: Expression -> Translate [CoreExpr]
@@ -258,7 +219,7 @@ translateBlock loc blk = do
       popKey
       return (declMeta, k, valMeta, expr)
   b <- body dforms
-  mint2 letexp loc (bindings dforms) b
+  mint2 letblock loc (bindings dforms) b
   where
     extractKey Annotated {content = Located {locatee = decl}} =
       let name =

src/Eucalypt/Core/Eliminate.hs

@@ -17,14 +17,14 @@ import qualified Data.Set as Set
 
 -- | Eliminate unused bindings from let expressions.
 prune :: CoreExp a -> CoreExp a
-prune (CoreLet smid bs b) =
+prune (CoreLet smid bs b _) =
   let prunedB = pruneScope b
       usedInB = foldMapBound Set.singleton prunedB
       prunedBs = map (second pruneScope) bs
       setsBoundByBs = map (foldMapBound Set.singleton . snd) prunedBs
       usedInBs = mconcat $ removeSelfReferences setsBoundByBs
       used = usedInB <> usedInBs
-   in CoreLet smid (blankUnused used prunedBs) prunedB
+   in CoreLet smid (blankUnused used prunedBs) prunedB OtherLet
   where
     pruneScope = toScope . prune . fromScope
     blankUnused u binds = map (blankNon u) (zip [0 ..] binds)
@@ -56,19 +56,20 @@ removeSelfReferences boundSets = zipWith f boundSets [0..]
 -- | Remove let bindings that have been overwritten by CoreEliminated
 -- in the 'prune' step
 compress :: CoreExp a -> CoreExp a
-compress (CoreLet smid bs b) =
+compress (CoreLet smid bs b _) =
   let compressedB = compressScope b
       compressedBs = map (second compressScope) bs
       indexRemapping = newBindIndexes $ map bindingIsNotEliminated compressedBs
       editedBindings =
         map (second $ remapBindings indexRemapping) $
         filter bindingIsNotEliminated compressedBs
-   in
-    if null editedBindings
-    then
-      instantiate (const CoreEliminated) compressedB
-    else
-      CoreLet smid editedBindings $ remapBindings indexRemapping compressedB
+   in if null editedBindings
+        then instantiate (const CoreEliminated) compressedB
+        else CoreLet
+               smid
+               editedBindings
+               (remapBindings indexRemapping compressedB)
+               OtherLet
   where
     compressScope = toScope . compress . fromScope
     bindingIsNotEliminated = not . isEliminated . unscope . snd

src/Eucalypt/Core/Error.hs

@@ -33,20 +33,31 @@ data CoreError
   | Bug String CoreExpShow
   | VerifyOperatorsFailed CoreExpShow
   | VerifyNamesFailed CoreExpShow
-  | VerifyUnresolvedVar CoreBindingName
+  | VerifyUnresolvedVar CoreExpShow
   | VerifyNoEliminated CoreExpShow
   | NoSource
 
 instance Show CoreError where
   show (MultipleErrors es) = foldl1 (++) (map ((++ "\n") . show) es)
-  show (TooFewOperands (CoreExpShow op)) = "Too few operands available for operator " ++ pprint op
-  show (InvalidOperatorOutputStack exprs) = "Invalid output stack while cooking operator soup: [" ++ intercalate "," (map (\(CoreExpShow s) -> pprint s) exprs) ++ "]"
-  show (InvalidOperatorSequence (CoreExpShow l) (CoreExpShow r)) = "Invalid sequence of operators:" ++ pprint l ++ " " ++ pprint r
-  show (VerifyOperatorsFailed (CoreExpShow expr)) = "Unresolved operator in " ++ pprint expr
-  show (VerifyNoEliminated (CoreExpShow expr)) = "Eliminated code found " ++ pprint expr
-  show (VerifyNamesFailed (CoreExpShow expr)) = "Found name nodes, not translated to vars:" ++ pprint expr
-  show (VerifyUnresolvedVar name) = "Unresolved variable in " ++ name
-  show (Bug message (CoreExpShow expr)) = "BUG! " ++ message ++ " - " ++ pprint expr
+  show (TooFewOperands (CoreExpShow op)) =
+    "Too few operands available for operator " ++ pprint op
+  show (InvalidOperatorOutputStack exprs) =
+    "Invalid output stack while cooking operator soup: [" ++
+    intercalate "," (map (\(CoreExpShow s) -> pprint s) exprs) ++ "]"
+  show (InvalidOperatorSequence (CoreExpShow l) (CoreExpShow r)) =
+    "Invalid sequence of operators:" ++ pprint l ++ " " ++ pprint r
+  show (VerifyOperatorsFailed (CoreExpShow expr)) =
+    "Unresolved operator in " ++ pprint expr
+  show (VerifyNoEliminated (CoreExpShow expr)) =
+    "Eliminated code found " ++ pprint expr
+  show (VerifyNamesFailed (CoreExpShow expr)) =
+    "Found name nodes, not translated to vars:" ++ pprint expr
+  show (VerifyUnresolvedVar (CoreExpShow (CoreUnresolved _ v))) =
+    "Unresolved variable: " ++ v
+  show (VerifyUnresolvedVar (CoreExpShow expr)) =
+    "Unresolved variable: " ++ pprint expr
+  show (Bug message (CoreExpShow expr)) =
+    "BUG! " ++ message ++ " - " ++ pprint expr
   show NoSource = "No source"
 
 instance Exception CoreError
@@ -61,6 +72,6 @@ instance HasSourceMapIds CoreError where
   toSourceMapIds (InvalidOperatorSequence l r) = concatMap toSourceMapIds [l, r]
   toSourceMapIds (VerifyOperatorsFailed expr) = toSourceMapIds expr
   toSourceMapIds (VerifyNamesFailed expr) = toSourceMapIds expr
-  toSourceMapIds (VerifyUnresolvedVar _) = []
+  toSourceMapIds (VerifyUnresolvedVar expr) = toSourceMapIds expr
   toSourceMapIds (Bug _ expr) = toSourceMapIds expr
   toSourceMapIds _ = []