generalised lookup (static) (#55)

* Implement static generalised lookup

- plus add a required STG compile case
- extra pre exec validation

* A new //= assert op that doesn't pass through

* `then` function for pipeline if

Author: gmorpheme

lib/prelude.eu

@@ -73,6 +73,10 @@ cat: __CAT
     export: :suppress }
 if: __IF
 
+` { doc: "`then(t, f, c)` - for pipeline if: - `x? then(t, f)``"
+    export: :suppress }
+then(t, f, c): if(c, t, f)
+
 ##
 ## List basics
 ##
@@ -424,21 +428,30 @@ assertions: {
 ` { doc: "`validator(v)` - find the validator for a value `v` in its metadata" }
   validator(v): lookup-or(:assert, const(true), meta(v))
 
-` { doc: "`check(v)` - panic if value doesn't satisfy its validator" }
-  check(v): if(v validator(v), v, panic("assertion failed"))
+` { doc: "`check(v)` - true if v is valid according to assert metadata" }
+  check(v): v validator(v)
+
+` { doc: "`checked(v)` - panic if value doesn't satisfy its validator" }
+  checked(v): if(check(v), v, panic("assertion failed"))
 }
 
+` { doc: "`e //= v` - add metadata to check expression `e` evaluates to `v` and return whether valid"
+    export: :suppress 
+    associates: :left
+    precedence: :meta }
+(e //= v): e with-meta({ assert: __EQ(v)}) assertions.check
+
 ` { doc: "`e //=> v` - add metadata to assert expression `e` evaluates to `v` and return value of `e`."
     export: :suppress 
     associates: :left
     precedence: :meta }
-(e //=> v): e with-meta({ assert: __EQ(v)}) assertions.check
+(e //=> v): e with-meta({ assert: __EQ(v)}) assertions.checked
 
 ` { doc: "`e //=? f` - add metadata to assert expression `e` satisfies function `f` and return value of `e`."
     export: :suppress 
     associates: :left
     precedence: :meta }
-(e //=? f): e with-meta({ assert: f}) assertions.check
+(e //=? f): e with-meta({ assert: f}) assertions.checked
 
 
 #

src/Eucalypt/Core/Desugar.hs

@@ -128,6 +128,7 @@ recordImports imports =
   modify $ \s@TranslateState {trImports = old} -> s {trImports = old ++ imports}
 
 
+
 -- | Process names to vars as appropriate for a context where the
 -- exprs will be statically bound
 interpretForStaticBoundContext :: [CoreExpr] -> [CoreExpr]
@@ -141,6 +142,27 @@ interpretForStaticBoundContext exprs =
     toVar e _ = e
 
 
+
+-- | 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).
 --
@@ -154,7 +176,8 @@ interpretForStaticBoundContext exprs =
 -- resolved and which are just lookup keys.
 translateSoup :: [Expression] -> Translate CoreExpr
 translateSoup items =
-  anon CoreOpSoup . interpretForStaticBoundContext . concat <$>
+  anon CoreOpSoup .
+  processStaticGenLookup . interpretForStaticBoundContext . concat <$>
   traverse trans items
   where
     trans :: Expression -> Translate [CoreExpr]

src/Eucalypt/Core/Error.hs

@@ -17,7 +17,7 @@ import Eucalypt.Core.Pretty
 import Eucalypt.Core.SourceMap
 import Eucalypt.Core.Syn
 import Eucalypt.Reporting.Classes
-import qualified Text.PrettyPrint as T
+import Eucalypt.Reporting.Common
 
 data CoreExpShow = forall a. Show a => CoreExpShow (CoreExp a)
 
@@ -32,6 +32,7 @@ data CoreError
   | InvalidOperatorSequence CoreExpShow CoreExpShow
   | Bug String CoreExpShow
   | VerifyOperatorsFailed CoreExpShow
+  | VerifyNamesFailed CoreExpShow
   | VerifyUnresolvedVar CoreBindingName
   | NoSource
 
@@ -41,21 +42,23 @@ instance Show CoreError where
   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 (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 NoSource = "No source"
 
 instance Exception CoreError
 
 instance Reportable CoreError where
-  report = T.text . show
+  report = standardReport "CORE ERROR" . show
 
 instance HasSourceMapIds CoreError where
   toSourceMapIds (MultipleErrors es) = concatMap toSourceMapIds es
   toSourceMapIds (TooFewOperands op) = toSourceMapIds op
   toSourceMapIds (InvalidOperatorOutputStack exprs) = concatMap toSourceMapIds exprs
   toSourceMapIds (InvalidOperatorSequence l r) = concatMap toSourceMapIds [l, r]
   toSourceMapIds (VerifyOperatorsFailed expr) = toSourceMapIds expr
+  toSourceMapIds (VerifyNamesFailed expr) = toSourceMapIds expr
   toSourceMapIds (VerifyUnresolvedVar _) = []
   toSourceMapIds (Bug _ expr) = toSourceMapIds expr
   toSourceMapIds NoSource = []

src/Eucalypt/Core/Verify.hs

@@ -17,7 +17,10 @@ import Eucalypt.Core.Syn
 
 -- | Run all the check functions throughout the tree
 runChecks :: Show b => CoreExp b -> [CoreError]
-runChecks expr = verify noSoup expr ++ map (VerifyUnresolvedVar . show) (toList expr)
+runChecks expr =
+  verify cleanCore expr ++ map (VerifyUnresolvedVar . show) (toList expr)
+
+
 
 -- | Apply a check function to every level in the syntax tree
 verify ::
@@ -46,6 +49,16 @@ verify f e@(CoreOperator _ _ _ expr) =
   f e ++ verify f expr
 verify f e = f e
 
+
+cleanCore :: Show a => CoreExp a -> [CoreError]
+cleanCore e = noSoup e ++ noCoreName e
+
+
 noSoup :: Show a => CoreExp a -> [CoreError]
 noSoup o@(CoreOpSoup _ _) = [(VerifyOperatorsFailed . CoreExpShow) o]
 noSoup _ = []
+
+
+noCoreName :: Show a => CoreExp a -> [CoreError]
+noCoreName o@CoreName{} = [(VerifyNamesFailed . CoreExpShow) o]
+noCoreName _ = []

src/Eucalypt/Stg/Compiler.hs

@@ -156,7 +156,7 @@ compile envSize context _metaref (C.CoreApply _ f xs) =
         (CoreBuiltin _ n) -> ([], Ref $ Global n)
         (CoreVar _ a) -> ([], Ref $ context a)
         _ ->
-          ( [compileBinding envSize context ("<fn>", f)]
+          ( [compileBinding envSize context ("<anon>", f)]
           , Ref (Local $ fromIntegral envSize))
     acc (ps, xrs) x =
       case x of
@@ -172,6 +172,14 @@ compile envSize context _metaref (C.CoreApply _ f xs) =
         _ -> fn
 
 
+
+-- | Compile lambda into let to allocate and return fn
+compile envSize context _metaref f@CoreLambda{} =
+  let_ [compileBinding envSize context ("<anon>", f)]
+  $ Atom $ Local $ fromIntegral envSize
+
+
+
 compile envSize context _metaref (CoreLookup _ obj nm) =
   let_
     [compileBinding envSize context ("", obj)]
@@ -191,7 +199,6 @@ compile envSize context _ (CoreOperator _ _x _p expr) = compile envSize context
 compile _ _ _ CoreName{} = error "Cannot compile name"
 compile _ _ _ CoreArgTuple{} = error "Cannot compile arg tuple"
 compile _ _ _ CoreOpSoup{} = error "Cannot compile op soup"
-compile _ _ _ CoreLambda{} = error "Cannot compile lambda"
 
 -- | An empty context with no Refs for any Var
 emptyContext :: (Show v, Eq v) => v -> Ref

src/Eucalypt/Syntax/ParseExpr.hs

@@ -87,13 +87,26 @@ categorisedIdentifier =
   "identifier"
 
 
+-- | Any type of identifier
+categorisedNormalIdentifier :: Parser AtomicName
+categorisedNormalIdentifier =
+  try (NormalName <$> normalIdentifier <|>
+       NormalName <$> quotedIdentifier) <?>
+  "identifier"
+
 
 -- | An identifier as an expression
 name :: Parser Expression
 name = located (EName <$> categorisedIdentifier <?> "name")
 
 
 
+-- | A non-operator identifier as an expression
+nonOperatorName :: Parser Expression
+nonOperatorName = located (EName <$> categorisedNormalIdentifier <?> "property name")
+
+
+
 -- ? primitives
 --
 -- We treat integers and doubles separately despite their being
@@ -161,7 +174,11 @@ tuple = parens $ expression `sepBy1` comma
 -- call parser identifies both the anchor and the arg tuple and
 -- returns both to the expression parser for inclusion in opsoup. This
 -- is why 'element' returns more than one expression.
--- 
+--
+--
+-- Also note that instances of generalised lookup may have parentheses
+-- directly after a dot operator, e.g. @{a: 1}.(a+1)@. These must not
+-- be parsed as calls.
 rootCall :: Parser [Expression]
 rootCall = label "function call" $
            (\x y -> [x, y]) <$> callAnchorExpression <*> located (EApplyTuple <$> tuple)
@@ -174,7 +191,7 @@ call :: Parser [Expression]
 call = foldl invocation <$> rootCall <*> many tuple
 
 callAnchorExpression :: Parser Expression
-callAnchorExpression = try atom <|> parenExpression
+callAnchorExpression = try nonOperatorName <|> parenExpression
 
 listify :: Parser a -> Parser [a]
 listify = fmap (: [])

test/Eucalypt/Core/DesugarSpec.hs

@@ -103,6 +103,24 @@ soupSpec =
         , Syn.lookupOp
         , Syn.corename 3 "z"
         ]
+    it "handles static generalised lookup" $
+      processStaticGenLookup
+        [ ASyn.letexp [("a", ASyn.int 1)] $
+          ASyn.block [ASyn.element "a" (ASyn.var "a")]
+        , Syn.lookupOp
+        , ASyn.soup [ASyn.corename "a", ASyn.corename "+", ASyn.corename "a"]
+        ] `shouldBe`
+      [ ASyn.letexp [("a", ASyn.int 1)] $
+        ASyn.soup [ASyn.corename "a", ASyn.corename "+", ASyn.corename "a"]
+      ]
+    it "handles simple lookup on blocks" $
+      (processStaticGenLookup . interpretForStaticBoundContext)
+        [ ASyn.letexp [("a", ASyn.int 1)] $
+          ASyn.block [ASyn.element "a" (ASyn.var "a")]
+        , Syn.lookupOp
+        , ASyn.corename "a"
+        ] `shouldBe`
+      [ASyn.letexp [("a", ASyn.int 1)] $ ASyn.var "a"]
 
 blockSpec :: Spec
 blockSpec =

test/Eucalypt/Syntax/ParseExprSpec.hs

@@ -179,6 +179,13 @@ expressionSpec =
         , applyTuple [normalName "b"]
         , applyTuple [normalName "c"]
         ]
+    it "does not confuse gen lookup with call syntax" $
+      testParse expression "{ a: x }.(a + a)" `shouldParse`
+      opsoup
+        [ block [bare $ prop "a" $ normalName "x"]
+        , operatorName "."
+        , opsoupParens [normalName "a", operatorName "+", normalName "a"]
+        ]
     it "rejects lonely colons" $ do
       testParse expression `shouldFailOn` "a : a"
       testParse expression `shouldFailOn` "a:"