diff --git a/lib/haskell/natural4/src/LS/Renamer.hs b/lib/haskell/natural4/src/LS/Renamer.hs index 3efc5da5e..5b6350f0e 100644 --- a/lib/haskell/natural4/src/LS/Renamer.hs +++ b/lib/haskell/natural4/src/LS/Renamer.hs @@ -410,9 +410,11 @@ scanTypeDeclName tracer mtexprs = do -- | -- Lexical Scoping rules for hornlike rules: -- --- GIVETH's are global --- GIVEN's are local --- DECIDE head term in "IS" clauses is global +-- * GIVENs are local to the rule +-- * A GIVETH can be referred to in other rules up the scope hierarchy +-- * The head in DECIDE clauses can also be referred to by other rules in scope hierarchy +-- * WHERE clauses are local to the rule +-- renameRules :: (Traversable f) => Tracer Log -> f Rule -> Renamer (f RnRule) renameRules tracer rules = do rulesWithLocalDefs <- diff --git a/lib/haskell/natural4/src/LS/Renamer/Scope.hs b/lib/haskell/natural4/src/LS/Renamer/Scope.hs index b27074b2f..51ffea3fa 100644 --- a/lib/haskell/natural4/src/LS/Renamer/Scope.hs +++ b/lib/haskell/natural4/src/LS/Renamer/Scope.hs @@ -61,8 +61,8 @@ data ScopeTable = ScopeTable unionScopeTable :: ScopeTable -> ScopeTable -> ScopeTable unionScopeTable tbl1 tbl2 = ScopeTable - { _stVariables = Map.union tbl1._stVariables tbl2._stVariables - , _stFunction = Map.union tbl1._stFunction tbl2._stFunction + { _stVariables = Map.union tbl2._stVariables tbl1._stVariables + , _stFunction = Map.union tbl2._stFunction tbl1._stFunction } differenceScopeTable :: ScopeTable -> ScopeTable -> ScopeTable diff --git a/lib/haskell/natural4/src/LS/XPile/Simala/Transpile.hs b/lib/haskell/natural4/src/LS/XPile/Simala/Transpile.hs index 833811f69..f9a1ff373 100644 --- a/lib/haskell/natural4/src/LS/XPile/Simala/Transpile.hs +++ b/lib/haskell/natural4/src/LS/XPile/Simala/Transpile.hs @@ -6,7 +6,28 @@ {-# LANGUAGE QuasiQuotes #-} {-# OPTIONS_GHC -Wall #-} -module LS.XPile.Simala.Transpile where +module LS.XPile.Simala.Transpile ( + -- * Main entry point to the transpiler + transpile, + + -- * Transpiler monad + Transpiler (..), + runSimalaTranspiler, + + -- * Utilities to work with simala terms in naturalL4 + render, + + -- * Internal types that sometimes may be helpful + SimalaTerm (..), + + -- * Typed errors and renderers + TranspilerError (..), + AssertionError (..), + renderTranspilerError, + + -- * Debugging utilities + debugTranspileRule, +) where import Control.Monad.Error.Class (MonadError (..)) import Control.Monad.Trans.Except @@ -32,10 +53,31 @@ import TextuaL4.Transform qualified as Parser import AnyAll.BoolStruct qualified as AA import LS.Log qualified as Log +import LS.Renamer.Rules import Simala.Expr.Parser qualified as Simala import Simala.Expr.Render qualified as Simala import Simala.Expr.Type qualified as Simala -import LS.Renamer.Rules +import Data.Proxy + +-- ---------------------------------------------------------------------------- +-- Top Level transpilation functions and test helpers +-- ---------------------------------------------------------------------------- + +newtype Transpiler a = Transpiler {runTranspiler :: Except TranspilerError a} + deriving newtype (Functor, Applicative, Monad) + deriving newtype (MonadError TranspilerError) + +runSimalaTranspiler :: [RnRule] -> Either TranspilerError [Simala.Decl] +runSimalaTranspiler = runExcept . runTranspiler . transpile + +transpile :: [RnRule] -> Transpiler [Simala.Decl] +transpile rules = do + simalaTerms <- Maybe.catMaybes <$> traverse ruleToSimala rules + traverse toSimalaDecl simalaTerms + +-- ---------------------------------------------------------------------------- +-- Transpiler specific intermediate representations (called IR) +-- ---------------------------------------------------------------------------- -- | A @'SimalaTerm'@ is like a 'Simala.Expr' but in an unsaturated form. -- By "unsaturated", we mean that there might be holes in the expression that @@ -101,125 +143,6 @@ data SimalaTerm TermExpr Simala.Expr deriving (Show) --- ---------------------------------------------------------------------------- --- Typed Error --- ---------------------------------------------------------------------------- - -data TranspilerError - = TermToDeclUnsupported SimalaTerm - | UnsupportedLocalTerm Text SimalaTerm - | UnsupportedMultiTerm RnMultiTerm - | UnsupportedEmptyMultiTerm - | ImpossibleLeftSide SimalaTerm - | UnsupportedLeftSide RnMultiTerm - | UnsupportedRightSide RnMultiTerm - | NotImplemented Text - | UnsupportedPredicate LS.RPRel - | FailedToCombineTerms SimalaTerm SimalaTerm - | AssertErr AssertionError - -data ExpectedSize - = SizeExact !Int - | SizeAtLeast !Int - -data AssertionError - = forall a. (Show a) => UnexpectedNonEmptyList [a] - | NotTermAttribute SimalaTerm - | NotSingletonList Text !Int - | NotTermExpr SimalaTerm - | NotMultiTerm Text RnRelationalPredicate - | NotRecord Simala.Expr - | NotSelectorChain SimalaTerm - | forall a. (Show a) => NotEquals a a - | UnexpectedEmptyList - | UnexpectedListSize ExpectedSize !Int - -throwAssertion :: AssertionError -> Transpiler a -throwAssertion = throwError . AssertErr - -renderTranspilerError :: TranspilerError -> Text -renderTranspilerError = \case - TermToDeclUnsupported term -> - "Cannot convert SimalaTerm to Decl: " <> tshow term - UnsupportedLocalTerm herald term -> - herald <> ": Unexpected local term: " <> tshow term - UnsupportedMultiTerm multiTerm -> - "Unsupported RnMultiTerms: " <> tshow multiTerm - UnsupportedEmptyMultiTerm -> - "Unexpected empty list of RnMultiTerms" - ImpossibleLeftSide term -> - "The following SimalaTerm cannot occur on the left hand side of an assignment: " <> tshow term - UnsupportedLeftSide multiTerm -> - "Unsupported on the left side of an assignment: " <> tshow multiTerm - UnsupportedRightSide multiTerm -> - "Unsupported on the right side of an assignment: " <> tshow multiTerm - NotImplemented herald -> - herald <> ": unsupported" - UnsupportedPredicate relPred -> - "Unsupported RelationalPredicate: " <> tshow relPred - FailedToCombineTerms term1 term2 -> - "Can't wrap terms in an if-then-else.\nFirst term: " - <> tshow term1 - <> "\nSecond term: " - <> tshow term2 - AssertErr assertionErr -> case assertionErr of - UnexpectedNonEmptyList list -> - "Expected empty list, but got: " <> tshow list - NotTermAttribute term -> - "Expected TermAttribute, but got: " <> tshow term - NotSingletonList herald size -> - herald <> ": Expected singleton list, but got: " <> tshow size - NotTermExpr term -> - "Expected TermAttribute, but got: " <> tshow term - NotMultiTerm herald rnPred -> - herald <> ": Expected MultiTerm, but got: " <> tshow rnPred - NotRecord expr -> - "Expected Record, but got: " <> tshow expr - NotSelectorChain term -> - "Expected TermAttribute with non-empty selectors, but got: " <> tshow term - NotEquals a b -> - "Not equal: " <> tshow a <> ", " <> tshow b - UnexpectedEmptyList -> - "Expected non-empty list" - UnexpectedListSize len n -> - "Expected list of " - <> ( case len of - SizeExact i -> "size " <> tshow i - SizeAtLeast i -> "at least size " <> tshow i - ) - <> ", but got " - <> tshow n - -tshow :: (Show a) => a -> Text -tshow = Text.pack . show - --- ---------------------------------------------------------------------------- --- Top Level transpilation functions and test helpers --- ---------------------------------------------------------------------------- - -newtype Transpiler a = Transpiler {runTranspiler :: Except TranspilerError a} - deriving newtype (Functor, Applicative, Monad) - deriving newtype (MonadError TranspilerError) - -runSimalaTranspiler :: [RnRule] -> Either TranspilerError [Simala.Decl] -runSimalaTranspiler = runExcept . runTranspiler . transpile - -transpile :: [RnRule] -> Transpiler [Simala.Decl] -transpile rules = do - simalaTerms <- Maybe.catMaybes <$> traverse ruleToSimala rules - traverse toSimalaDecl simalaTerms - -toSimalaDecl :: SimalaTerm -> Transpiler Simala.Decl -toSimalaDecl (TermLetIn t name expr) = do - pure $ Simala.NonRec t name expr -toSimalaDecl (TermFunction t name params expr) = do - pure $ Simala.NonRec t name $ mkFunctionDecl t params expr -toSimalaDecl term = do - throwError $ TermToDeclUnsupported term - -render :: [Simala.Decl] -> Text -render = Text.unlines . fmap Simala.render - -- ---------------------------------------------------------------------------- -- Main translation helpers -- ---------------------------------------------------------------------------- @@ -239,6 +162,17 @@ ruleToSimala (Hornlike hornlike) = do localDefinitions <- traverse ruleToSimala hornlike.wwhere Just <$> addLocalDefinitions mainDefinition (Maybe.catMaybes localDefinitions) +toSimalaDecl :: SimalaTerm -> Transpiler Simala.Decl +toSimalaDecl (TermLetIn t name expr) = do + pure $ Simala.NonRec t name expr +toSimalaDecl (TermFunction t name params expr) = do + pure $ Simala.NonRec t name $ mkFunctionDecl t params expr +toSimalaDecl term = do + throwError $ TermToDeclUnsupported term + +render :: [Simala.Decl] -> Text +render = Text.unlines . fmap Simala.render + -- ---------------------------------------------------------------------------- -- Post Processing of rule translation. -- These steps include: @@ -441,14 +375,14 @@ relationalPredicateToSimala = \case | Just (fnName, fnParams) <- isFunctionDeclaration mtHead args -> do rhsExpr <- rhsMultiTermToSimala rhs mkFunctionTerm (toSimalaName fnName) (fmap toSimalaName fnParams) (TermExpr rhsExpr) - | Just (var, selectors) <- isAssignment mtHead args -> do + | Just (var, selectors) <- isVariableOrProjection mtHead args -> do rhsExpr <- rhsMultiTermToSimala rhs mkAssignmentTerm (toSimalaName var) (fmap toSimalaName selectors) rhsExpr | otherwise -> throwError $ UnsupportedMultiTerm lhs [] -> throwError UnsupportedEmptyMultiTerm RnConstraint lhs predicate rhs -> do lhsSimalaExpr' <- lhsMultiTermToSimala lhs - lhsSimalaExpr <- assertTermExpr lhsSimalaExpr' + lhsSimalaExpr <- toSimalaExpression lhsSimalaExpr' rhsSimalaExpr <- rhsMultiTermToSimala rhs predRelToBuiltIn predicate [lhsSimalaExpr, rhsSimalaExpr] RnNary LS.RPis (lhs : rhs) -> do @@ -458,12 +392,12 @@ relationalPredicateToSimala = \case case lhsSimalaTerm of TermApp fnName fnParams -> do fnExpr <- assertSingletonList "RnNary.TermApp" rhsExprs - rhsExpr <- assertTermExpr fnExpr + rhsExpr <- toSimalaExpression fnExpr mkFunctionTerm fnName fnParams (TermExpr rhsExpr) TermLetIn{} -> throwError $ ImpossibleLeftSide lhsSimalaTerm TermAttribute name selectors Simala.Undefined -> do someRhs <- assertSingletonList "RnNary.TermAttribute" rhsExprs - rhsExpr <- assertTermExpr someRhs + rhsExpr <- toSimalaExpression someRhs pure $ TermAttribute name selectors rhsExpr TermAttribute{} -> throwError $ ImpossibleLeftSide lhsSimalaTerm TermFunction{} -> throwError $ NotImplemented "RpNary RPis TermFunction" @@ -473,14 +407,14 @@ relationalPredicateToSimala = \case predicateToSimala predicate mt RnBoolStructR lhs predicate rhs -> do lhsTerm <- lhsMultiTermToSimala lhs - lhsExpr <- assertTermExpr lhsTerm + lhsExpr <- toSimalaExpression lhsTerm rhsSimalaExpr <- boolStructToSimala rhs predRelToBuiltIn predicate [lhsExpr, rhsSimalaExpr] predicateToSimala :: LS.RPRel -> [RnRelationalPredicate] -> Transpiler SimalaTerm predicateToSimala rp params' = do params <- traverse relationalPredicateToSimala params' - exprs <- traverse assertTermExpr params + exprs <- traverse toSimalaExpression params predRelToBuiltIn rp exprs predRelToBuiltIn :: LS.RPRel -> [Simala.Expr] -> Transpiler SimalaTerm @@ -523,45 +457,50 @@ fixedArity b arity params' = do pure $ TermExpr $ Simala.Builtin b params lhsMultiTermToSimala :: RnMultiTerm -> Transpiler SimalaTerm -lhsMultiTermToSimala [rnExpr] = pure $ TermExpr $ exprToSimala rnExpr +lhsMultiTermToSimala [rnExpr] = case rnExpr of + RnExprName name -> mkVariableTerm (toSimalaName name) Simala.Undefined + RnExprBuiltin builtin -> pure $ TermExpr $ builtinToSimala builtin + RnExprLit lit -> pure $ TermExpr $ litToSimala lit lhsMultiTermToSimala (mtHead : rest) | Just (fnName, fnParams) <- isFunctionDeclaration mtHead rest = mkFunctionHead (toSimalaName fnName) (fmap toSimalaName fnParams) - | Just (varName, selectors) <- isProjection mtHead rest = - mkRecordAssignmentTerm (toSimalaName varName) (fmap toSimalaName selectors) + | Just (varName, selectors) <- isVariableOrProjection mtHead rest = + mkAssignmentTerm (toSimalaName varName) (fmap toSimalaName selectors) Simala.Undefined lhsMultiTermToSimala exprs = throwError $ UnsupportedLeftSide exprs rhsMultiTermToSimala :: RnMultiTerm -> Transpiler Simala.Expr rhsMultiTermToSimala [rnExpr] = pure $ exprToSimala rnExpr rhsMultiTermToSimala (mtHead : rest) | Just _fnName <- isFunction mtHead = pure $ Simala.App (exprToSimala mtHead) $ fmap exprToSimala rest - | Just (varName, selectors) <- isProjection mtHead rest = pure $ applySelectors (toSimalaName varName) (fmap toSimalaName selectors) + | Just (varName, selectors) <- isVariableOrProjection mtHead rest = case selectors of + [] -> pure $ Simala.Var $ toSimalaName varName + (sel : ssel) -> pure $ applySelectors (toSimalaName varName) (fmap toSimalaName (sel :| ssel)) rhsMultiTermToSimala exprs = throwError $ UnsupportedRightSide exprs boolStructToSimala :: RnBoolStructR -> Transpiler Simala.Expr boolStructToSimala = \case AA.Leaf relationalPredicate -> do simalaTerm <- relationalPredicateToSimala relationalPredicate - assertTermExpr simalaTerm + toSimalaExpression simalaTerm AA.Any _lbl structs -> do simalaExprs <- traverse boolStructToSimala structs simalaAny <- flexibleArity Simala.Or simalaExprs - assertTermExpr simalaAny + toSimalaExpression simalaAny AA.All _lbl structs -> do simalaExprs <- traverse boolStructToSimala structs simalaAll <- flexibleArity Simala.And simalaExprs - assertTermExpr simalaAll + toSimalaExpression simalaAll AA.Not struct -> do simalaExpr <- boolStructToSimala struct simalaNot <- fixedArity Simala.Not 1 [simalaExpr] - assertTermExpr simalaNot + toSimalaExpression simalaNot -- ---------------------------------------------------------------------------- -- Rule pattern recognition -- ---------------------------------------------------------------------------- -isAssignment :: RnExpr -> [RnExpr] -> Maybe (RnName, [RnName]) -isAssignment name selectors = do +isVariableOrProjection :: RnExpr -> [RnExpr] -> Maybe (RnName, [RnName]) +isVariableOrProjection name selectors = do rnName <- isVariable name rnSelectors <- traverse isSelector selectors pure (rnName, rnSelectors) @@ -572,13 +511,6 @@ isFunctionDeclaration mtHead args = do argNames <- traverse isVariable args pure (fnName, argNames) -isProjection :: RnExpr -> [RnExpr] -> Maybe (RnName, NE.NonEmpty RnName) -isProjection mtHead args = do - varName <- isVariable mtHead - nonEmptyRest <- NE.nonEmpty args - selectors <- traverse isSelector nonEmptyRest - pure (varName, selectors) - -- ---------------------------------------------------------------------------- -- Renamed Names utilities -- ---------------------------------------------------------------------------- @@ -684,11 +616,6 @@ assertPredicateIsMultiTerm _errMsg (RnRelationalTerm mt) = pure mt assertPredicateIsMultiTerm errMsg predicate = throwAssertion $ NotMultiTerm errMsg predicate -assertTermExpr :: SimalaTerm -> Transpiler Simala.Expr -assertTermExpr (TermExpr expr) = pure expr -assertTermExpr term = - throwAssertion $ NotTermExpr term - assertEquals :: (Eq a, Show a) => a -> a -> Transpiler () assertEquals a b | a == b = pure () @@ -699,13 +626,6 @@ assertIsRecord :: Simala.Expr -> Transpiler (Simala.Row Simala.Expr) assertIsRecord (Simala.Record row) = pure row assertIsRecord simalaExpr = throwAssertion $ NotRecord simalaExpr -assertAttributeHasSelectors :: SimalaTerm -> Transpiler (NonEmpty Simala.Name, Simala.Expr) -assertAttributeHasSelectors (TermAttribute _ (x : xs) expr) = pure (x :| xs, expr) -assertAttributeHasSelectors expr@(TermAttribute _ [] _) = - throwAssertion $ NotSelectorChain expr -assertAttributeHasSelectors expr = - throwAssertion $ NotTermAttribute expr - -- | If we can't handle transpiling certain list of things, we just hope that -- the parser doesn't give us a list with any elements. -- We throwError if the list is not @'null'@. @@ -717,31 +637,31 @@ assertEmptyList xs = throwError $ AssertErr $ UnexpectedNonEmptyList xs -- Construction helpers for simala terms -- ---------------------------------------------------------------------------- +toSimalaExpression :: SimalaTerm -> Transpiler Simala.Expr +toSimalaExpression = \case + TermExpr expr -> pure expr + TermAttribute name [] Simala.Undefined -> pure $ Simala.Var name + TermAttribute name (sel:ssels) Simala.Undefined -> pure $ applySelectors name (sel:|ssels) + t@TermAttribute{} -> throwError $ UnexpectedSimalaTerm "TermExpr or TermAttribute" t + t@TermApp{} -> throwError $ UnexpectedSimalaTerm "TermExpr or TermAttribute" t + t@TermFunction{} -> throwError $ UnexpectedSimalaTerm "TermExpr or TermAttribute" t + t@TermLetIn{} -> throwError $ UnexpectedSimalaTerm "TermExpr or TermAttribute" t + mkUndefinedTerm :: SimalaTerm mkUndefinedTerm = TermExpr Simala.Undefined mkAssignmentTerm :: Simala.Name -> [Simala.Name] -> Simala.Expr -> Transpiler SimalaTerm mkAssignmentTerm name selectors expr = pure $ TermAttribute name selectors expr +mkVariableTerm :: Simala.Name -> Simala.Expr -> Transpiler SimalaTerm +mkVariableTerm name expr = pure $ TermAttribute name [] expr + mkFunctionHead :: Simala.Name -> [Simala.Name] -> Transpiler SimalaTerm mkFunctionHead funcName funcParams = pure $ TermApp funcName funcParams -mkRecordAssignmentTerm :: Simala.Name -> NE.NonEmpty Simala.Name -> Transpiler SimalaTerm -mkRecordAssignmentTerm varName selectors = - pure $ - TermAttribute - varName - (NE.toList selectors) - Simala.Undefined - -mkLetInTerm :: Simala.Name -> SimalaTerm -> Transpiler SimalaTerm -mkLetInTerm var term = do - body <- assertTermExpr term - pure $ TermLetIn Simala.Transparent var body - mkFunctionTerm :: Simala.Name -> [Simala.Name] -> SimalaTerm -> Transpiler SimalaTerm mkFunctionTerm fnName fnParams term = do - body <- assertTermExpr term + body <- toSimalaExpression term pure $ TermFunction Simala.Transparent fnName fnParams body -- | Combine two 'SimalaTerm's via a Simala 'if-then-else' expression. @@ -856,6 +776,98 @@ mergeRecordUpdates rows = do mergedRows <- mergeRecordUpdates recordRows pure (name, mergedRows) +-- ---------------------------------------------------------------------------- +-- Typed Error +-- ---------------------------------------------------------------------------- + +data TranspilerError + = TermToDeclUnsupported SimalaTerm + | UnsupportedLocalTerm Text SimalaTerm + | UnsupportedMultiTerm RnMultiTerm + | UnsupportedEmptyMultiTerm + | ImpossibleLeftSide SimalaTerm + | UnsupportedLeftSide RnMultiTerm + | UnsupportedRightSide RnMultiTerm + | UnexpectedSimalaTerm !Text SimalaTerm + | NotImplemented Text + | UnsupportedPredicate LS.RPRel + | FailedToCombineTerms SimalaTerm SimalaTerm + | AssertErr AssertionError + +data ExpectedSize + = SizeExact !Int + | SizeAtLeast !Int + +data AssertionError + = forall a. (Show a) => UnexpectedNonEmptyList [a] + | NotTermAttribute !SimalaTerm + | NotSingletonList !Text !Int + | NotMultiTerm !Text !RnRelationalPredicate + | NotRecord !Simala.Expr + | NotSelectorChain !SimalaTerm + | forall a. (Show a) => NotEquals !a !a + | UnexpectedEmptyList + | UnexpectedListSize !ExpectedSize !Int + +throwAssertion :: AssertionError -> Transpiler a +throwAssertion = throwError . AssertErr + +renderTranspilerError :: TranspilerError -> Text +renderTranspilerError = \case + TermToDeclUnsupported term -> + "Cannot convert SimalaTerm to Decl: " <> tshow term + UnsupportedLocalTerm herald term -> + herald <> ": Unexpected local term: " <> tshow term + UnsupportedMultiTerm multiTerm -> + "Unsupported RnMultiTerms: " <> tshow multiTerm + UnsupportedEmptyMultiTerm -> + "Unexpected empty list of RnMultiTerms" + ImpossibleLeftSide term -> + "The following SimalaTerm cannot occur on the left hand side of an assignment: " <> tshow term + UnsupportedLeftSide multiTerm -> + "Unsupported on the left side of an assignment: " <> tshow multiTerm + UnsupportedRightSide multiTerm -> + "Unsupported on the right side of an assignment: " <> tshow multiTerm + UnexpectedSimalaTerm herald term -> + "Expected " <> herald <> ", but got: " <> tshow term + NotImplemented herald -> + herald <> ": unsupported" + UnsupportedPredicate relPred -> + "Unsupported RelationalPredicate: " <> tshow relPred + FailedToCombineTerms term1 term2 -> + "Can't wrap terms in an if-then-else.\nFirst term: " + <> tshow term1 + <> "\nSecond term: " + <> tshow term2 + AssertErr assertionErr -> case assertionErr of + UnexpectedNonEmptyList list -> + "Expected empty list, but got: " <> tshow list + NotTermAttribute term -> + "Expected TermAttribute, but got: " <> tshow term + NotSingletonList herald size -> + herald <> ": Expected singleton list, but got: " <> tshow size + NotMultiTerm herald rnPred -> + herald <> ": Expected MultiTerm, but got: " <> tshow rnPred + NotRecord expr -> + "Expected Record, but got: " <> tshow expr + NotSelectorChain term -> + "Expected TermAttribute with non-empty selectors, but got: " <> tshow term + NotEquals a b -> + "Not equal: " <> tshow a <> ", " <> tshow b + UnexpectedEmptyList -> + "Expected non-empty list" + UnexpectedListSize len n -> + "Expected list of " + <> ( case len of + SizeExact i -> "size " <> tshow i + SizeAtLeast i -> "at least size " <> tshow i + ) + <> ", but got " + <> tshow n + +tshow :: (Show a) => a -> Text +tshow = Text.pack . show + -- ---------------------------------------------------------------------------- -- Debugger helpers -- ---------------------------------------------------------------------------- @@ -882,5 +894,5 @@ debugTranspileRule ruleSrc = do run :: String -> Either String LS.Rule run = fmap Parser.transRule . Parser.pRule . Parser.myLexer -runList :: String -> Either String [LS.Rule] -runList = fmap (fmap Parser.transRule) . Parser.pListRule . Parser.myLexer +-- runList :: String -> Either String [LS.Rule] +-- runList = fmap (fmap Parser.transRule) . Parser.pListRule . Parser.myLexer diff --git a/lib/haskell/natural4/test/LS/RenamerSpec.hs b/lib/haskell/natural4/test/LS/RenamerSpec.hs index 4b2895dfa..c1c662d6c 100644 --- a/lib/haskell/natural4/test/LS/RenamerSpec.hs +++ b/lib/haskell/natural4/test/LS/RenamerSpec.hs @@ -110,6 +110,25 @@ spec = do GIVEN x DECIDE x g IS x |] + test' "function-with-name-shadowing" + [i| + GIVEN x + DECIDE f x IS g x + WHERE ( + GIVEN x DECIDE g x IS x + ) + |] + test' + "function-with-name-shadowing-with-where-rules" + [i| + GIVEN x + DECIDE f x IS y + WHERE ( + GIVETH y DECIDE y IS g x + § + GIVEN d DECIDE g d IS y WHERE y IS SUM(d, d) + ) + |] where test' :: String -> String -> SpecWith (Arg (IO (Golden TL.Text))) test' fname ruleSource = diff --git a/lib/haskell/natural4/test/LS/XPile/SimalaSpec.hs b/lib/haskell/natural4/test/LS/XPile/SimalaSpec.hs index 8b7e4ef86..468e56a26 100644 --- a/lib/haskell/natural4/test/LS/XPile/SimalaSpec.hs +++ b/lib/haskell/natural4/test/LS/XPile/SimalaSpec.hs @@ -178,6 +178,36 @@ basicTests = do y IS A Number DECIDE x `discounted by` y IS SUM(x, MINUS(1, y)) |] + transpilerTest "function-with-name-shadowing" + [i| + GIVEN x + DECIDE f x IS g x + WHERE ( + GIVEN x DECIDE g x IS x + ) + |] + transpilerTest + "function-with-name-shadowing-with-where-rules-1" + [i| + GIVEN x + DECIDE f x IS y + WHERE ( + GIVETH y DECIDE y IS g x + § + GIVEN d DECIDE g d IS y WHERE y IS SUM(d, d) + ) + |] + transpilerTest + "function-with-name-shadowing-with-where-rules-2" + [i| + GIVEN x + DECIDE f x IS y + WHERE ( + GIVEN d DECIDE g d IS y WHERE y IS SUM(d, d) + § + GIVETH y DECIDE y IS g x + ) + |] multiRuleTests :: Spec multiRuleTests = describe "multi-rules" do diff --git a/lib/haskell/natural4/test/testdata/golden/renamer/function-with-name-shadowing-with-where-rules.expected b/lib/haskell/natural4/test/testdata/golden/renamer/function-with-name-shadowing-with-where-rules.expected new file mode 100644 index 000000000..4a99cbc1b --- /dev/null +++ b/lib/haskell/natural4/test/testdata/golden/renamer/function-with-name-shadowing-with-where-rules.expected @@ -0,0 +1,308 @@ +Right + [ Hornlike + ( RnHornlike + { name = + [ RnExprName + ( RnName + { rnOccName = MTT "f" :| [] + , rnUniqueId = 1 + , rnNameType = RnFunction + } + ) + , RnExprName + ( RnName + { rnOccName = MTT "x" :| [] + , rnUniqueId = 0 + , rnNameType = RnVariable + } + ) + ] + , super = Nothing + , keyword = Decide + , given = Just + ( RnParamText + { mkParamText = RnTypedMulti + { rnTypedMultiExpr = RnExprName + ( RnName + { rnOccName = MTT "x" :| [] + , rnUniqueId = 0 + , rnNameType = RnVariable + } + ) :| [] + , rnTypedMultiTypeSig = Nothing + } :| [] + } + ) + , giveth = Nothing + , upon = Nothing + , clauses = + [ RnHornClause + { rnHcHead = RnConstraint + [ RnExprName + ( RnName + { rnOccName = MTT "f" :| [] + , rnUniqueId = 1 + , rnNameType = RnFunction + } + ) + , RnExprName + ( RnName + { rnOccName = MTT "x" :| [] + , rnUniqueId = 0 + , rnNameType = RnVariable + } + ) + ] RPis + [ RnExprName + ( RnName + { rnOccName = MTT "y" :| [] + , rnUniqueId = 2 + , rnNameType = RnVariable + } + ) + ] + , rnHcBody = Nothing + } + ] + , rlabel = Nothing + , lsource = Nothing + , wwhere = + [ Hornlike + ( RnHornlike + { name = + [ RnExprName + ( RnName + { rnOccName = MTT "y" :| [] + , rnUniqueId = 2 + , rnNameType = RnVariable + } + ) + ] + , super = Nothing + , keyword = Where + , given = Nothing + , giveth = Just + ( RnParamText + { mkParamText = RnTypedMulti + { rnTypedMultiExpr = RnExprName + ( RnName + { rnOccName = MTT "y" :| [] + , rnUniqueId = 2 + , rnNameType = RnVariable + } + ) :| [] + , rnTypedMultiTypeSig = Nothing + } :| [] + } + ) + , upon = Nothing + , clauses = + [ RnHornClause + { rnHcHead = RnConstraint + [ RnExprName + ( RnName + { rnOccName = MTT "y" :| [] + , rnUniqueId = 2 + , rnNameType = RnVariable + } + ) + ] RPis + [ RnExprName + ( RnName + { rnOccName = MTT "g" :| [] + , rnUniqueId = 4 + , rnNameType = RnFunction + } + ) + , RnExprName + ( RnName + { rnOccName = MTT "x" :| [] + , rnUniqueId = 0 + , rnNameType = RnVariable + } + ) + ] + , rnHcBody = Nothing + } + ] + , rlabel = Nothing + , lsource = Nothing + , wwhere = [] + , srcref = Just + ( SrcRef + { url = "test/Spec" + , short = "test/Spec" + , srcrow = 1 + , srccol = 1 + , version = Nothing + } + ) + , defaults = [] + , symtab = [] + } + ) + , Hornlike + ( RnHornlike + { name = + [ RnExprName + ( RnName + { rnOccName = MTT "g" :| [] + , rnUniqueId = 4 + , rnNameType = RnFunction + } + ) + , RnExprName + ( RnName + { rnOccName = MTT "d" :| [] + , rnUniqueId = 3 + , rnNameType = RnVariable + } + ) + ] + , super = Nothing + , keyword = Where + , given = Just + ( RnParamText + { mkParamText = RnTypedMulti + { rnTypedMultiExpr = RnExprName + ( RnName + { rnOccName = MTT "d" :| [] + , rnUniqueId = 3 + , rnNameType = RnVariable + } + ) :| [] + , rnTypedMultiTypeSig = Nothing + } :| [] + } + ) + , giveth = Nothing + , upon = Nothing + , clauses = + [ RnHornClause + { rnHcHead = RnConstraint + [ RnExprName + ( RnName + { rnOccName = MTT "g" :| [] + , rnUniqueId = 4 + , rnNameType = RnFunction + } + ) + , RnExprName + ( RnName + { rnOccName = MTT "d" :| [] + , rnUniqueId = 3 + , rnNameType = RnVariable + } + ) + ] RPis + [ RnExprName + ( RnName + { rnOccName = MTT "y" :| [] + , rnUniqueId = 2 + , rnNameType = RnVariable + } + ) + ] + , rnHcBody = Nothing + } + ] + , rlabel = Nothing + , lsource = Nothing + , wwhere = + [ Hornlike + ( RnHornlike + { name = + [ RnExprName + ( RnName + { rnOccName = MTT "y" :| [] + , rnUniqueId = 2 + , rnNameType = RnVariable + } + ) + ] + , super = Nothing + , keyword = Where + , given = Nothing + , giveth = Nothing + , upon = Nothing + , clauses = + [ RnHornClause + { rnHcHead = RnNary RPis + [ RnRelationalTerm + [ RnExprName + ( RnName + { rnOccName = MTT "y" :| [] + , rnUniqueId = 2 + , rnNameType = RnVariable + } + ) + ] + , RnNary RPsum + [ RnRelationalTerm + [ RnExprName + ( RnName + { rnOccName = MTT "d" :| [] + , rnUniqueId = 3 + , rnNameType = RnVariable + } + ) + ] + , RnRelationalTerm + [ RnExprName + ( RnName + { rnOccName = MTT "d" :| [] + , rnUniqueId = 3 + , rnNameType = RnVariable + } + ) + ] + ] + ] + , rnHcBody = Nothing + } + ] + , rlabel = Nothing + , lsource = Nothing + , wwhere = [] + , srcref = Just + ( SrcRef + { url = "test/Spec" + , short = "test/Spec" + , srcrow = 1 + , srccol = 1 + , version = Nothing + } + ) + , defaults = [] + , symtab = [] + } + ) + ] + , srcref = Just + ( SrcRef + { url = "test/Spec" + , short = "test/Spec" + , srcrow = 1 + , srccol = 1 + , version = Nothing + } + ) + , defaults = [] + , symtab = [] + } + ) + ] + , srcref = Just + ( SrcRef + { url = "test/Spec" + , short = "test/Spec" + , srcrow = 1 + , srccol = 1 + , version = Nothing + } + ) + , defaults = [] + , symtab = [] + } + ) + ] \ No newline at end of file diff --git a/lib/haskell/natural4/test/testdata/golden/renamer/function-with-name-shadowing.expected b/lib/haskell/natural4/test/testdata/golden/renamer/function-with-name-shadowing.expected new file mode 100644 index 000000000..08178ed9c --- /dev/null +++ b/lib/haskell/natural4/test/testdata/golden/renamer/function-with-name-shadowing.expected @@ -0,0 +1,172 @@ +Right + [ Hornlike + ( RnHornlike + { name = + [ RnExprName + ( RnName + { rnOccName = MTT "f" :| [] + , rnUniqueId = 1 + , rnNameType = RnFunction + } + ) + , RnExprName + ( RnName + { rnOccName = MTT "x" :| [] + , rnUniqueId = 0 + , rnNameType = RnVariable + } + ) + ] + , super = Nothing + , keyword = Decide + , given = Just + ( RnParamText + { mkParamText = RnTypedMulti + { rnTypedMultiExpr = RnExprName + ( RnName + { rnOccName = MTT "x" :| [] + , rnUniqueId = 0 + , rnNameType = RnVariable + } + ) :| [] + , rnTypedMultiTypeSig = Nothing + } :| [] + } + ) + , giveth = Nothing + , upon = Nothing + , clauses = + [ RnHornClause + { rnHcHead = RnConstraint + [ RnExprName + ( RnName + { rnOccName = MTT "f" :| [] + , rnUniqueId = 1 + , rnNameType = RnFunction + } + ) + , RnExprName + ( RnName + { rnOccName = MTT "x" :| [] + , rnUniqueId = 0 + , rnNameType = RnVariable + } + ) + ] RPis + [ RnExprName + ( RnName + { rnOccName = MTT "g" :| [] + , rnUniqueId = 3 + , rnNameType = RnFunction + } + ) + , RnExprName + ( RnName + { rnOccName = MTT "x" :| [] + , rnUniqueId = 0 + , rnNameType = RnVariable + } + ) + ] + , rnHcBody = Nothing + } + ] + , rlabel = Nothing + , lsource = Nothing + , wwhere = + [ Hornlike + ( RnHornlike + { name = + [ RnExprName + ( RnName + { rnOccName = MTT "g" :| [] + , rnUniqueId = 3 + , rnNameType = RnFunction + } + ) + , RnExprName + ( RnName + { rnOccName = MTT "x" :| [] + , rnUniqueId = 2 + , rnNameType = RnVariable + } + ) + ] + , super = Nothing + , keyword = Where + , given = Just + ( RnParamText + { mkParamText = RnTypedMulti + { rnTypedMultiExpr = RnExprName + ( RnName + { rnOccName = MTT "x" :| [] + , rnUniqueId = 2 + , rnNameType = RnVariable + } + ) :| [] + , rnTypedMultiTypeSig = Nothing + } :| [] + } + ) + , giveth = Nothing + , upon = Nothing + , clauses = + [ RnHornClause + { rnHcHead = RnConstraint + [ RnExprName + ( RnName + { rnOccName = MTT "g" :| [] + , rnUniqueId = 3 + , rnNameType = RnFunction + } + ) + , RnExprName + ( RnName + { rnOccName = MTT "x" :| [] + , rnUniqueId = 2 + , rnNameType = RnVariable + } + ) + ] RPis + [ RnExprName + ( RnName + { rnOccName = MTT "x" :| [] + , rnUniqueId = 2 + , rnNameType = RnVariable + } + ) + ] + , rnHcBody = Nothing + } + ] + , rlabel = Nothing + , lsource = Nothing + , wwhere = [] + , srcref = Just + ( SrcRef + { url = "test/Spec" + , short = "test/Spec" + , srcrow = 1 + , srccol = 1 + , version = Nothing + } + ) + , defaults = [] + , symtab = [] + } + ) + ] + , srcref = Just + ( SrcRef + { url = "test/Spec" + , short = "test/Spec" + , srcrow = 1 + , srccol = 1 + , version = Nothing + } + ) + , defaults = [] + , symtab = [] + } + ) + ] \ No newline at end of file diff --git a/lib/haskell/natural4/test/testdata/golden/xpile/simala/function-with-name-shadowing-with-where-rules-1.expected b/lib/haskell/natural4/test/testdata/golden/xpile/simala/function-with-name-shadowing-with-where-rules-1.expected new file mode 100644 index 000000000..24a9b23f5 --- /dev/null +++ b/lib/haskell/natural4/test/testdata/golden/xpile/simala/function-with-name-shadowing-with-where-rules-1.expected @@ -0,0 +1 @@ + f_f_1 = fun (v_x_0) => let v_y_2 = f_g_4(v_x_0) in let f_g_4 = fun (v_d_3) => let v_y_2 = v_d_3 + v_d_3 in v_y_2 in v_y_2 diff --git a/lib/haskell/natural4/test/testdata/golden/xpile/simala/function-with-name-shadowing-with-where-rules-2.expected b/lib/haskell/natural4/test/testdata/golden/xpile/simala/function-with-name-shadowing-with-where-rules-2.expected new file mode 100644 index 000000000..45dc895bc --- /dev/null +++ b/lib/haskell/natural4/test/testdata/golden/xpile/simala/function-with-name-shadowing-with-where-rules-2.expected @@ -0,0 +1 @@ + f_f_1 = fun (v_x_0) => let f_g_3 = fun (v_d_2) => let v_y_4 = v_d_2 + v_d_2 in v_y_4 in let v_y_4 = f_g_3(v_x_0) in v_y_4 diff --git a/lib/haskell/natural4/test/testdata/golden/xpile/simala/function-with-name-shadowing.expected b/lib/haskell/natural4/test/testdata/golden/xpile/simala/function-with-name-shadowing.expected new file mode 100644 index 000000000..5cd13f10a --- /dev/null +++ b/lib/haskell/natural4/test/testdata/golden/xpile/simala/function-with-name-shadowing.expected @@ -0,0 +1 @@ + f_f_1 = fun (v_x_0) => let f_g_3 = fun (v_x_2) => v_x_2 in f_g_3(v_x_0)