diff options
| -rw-r--r-- | src/Parser/Expr.hs | 6 | ||||
| -rw-r--r-- | src/Run.hs | 4 | ||||
| -rw-r--r-- | src/Test.hs | 32 |
3 files changed, 29 insertions, 13 deletions
diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs index eefc5cc..70649b2 100644 --- a/src/Parser/Expr.hs +++ b/src/Parser/Expr.hs @@ -289,10 +289,10 @@ someExpr = join inner <?> "expression" SomeExpr e <- p let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat [ T.pack "value of type ", textExprType e, T.pack " does not have member '", m, T.pack "'" ] - maybe err return $ applyRecordSelector e <$> lookup m recordMembers + maybe err return $ applyRecordSelector m e <$> lookup m recordMembers - applyRecordSelector :: ExprType a => Expr a -> RecordSelector a -> SomeExpr - applyRecordSelector e (RecordSelector f) = SomeExpr $ f <$> e + applyRecordSelector :: ExprType a => Text -> Expr a -> RecordSelector a -> SomeExpr + applyRecordSelector m e (RecordSelector f) = SomeExpr $ App (AnnRecord m) (pure f) e literal = label "literal" $ choice [ return <$> numberLiteral @@ -266,8 +266,8 @@ exprFailed desc (SourceLine sline) pname expr = do let prompt = maybe T.empty textProcName pname exprVars <- gatherVars expr outLine OutputMatchFail (Just prompt) $ T.concat [desc, T.pack " failed on ", sline] - forM_ exprVars $ \(name, value) -> - outLine OutputMatchFail (Just prompt) $ T.concat [T.pack " ", textVarName name, T.pack " = ", textSomeVarValue value] + forM_ exprVars $ \((name, sel), value) -> + outLine OutputMatchFail (Just prompt) $ T.concat [" ", textVarName name, T.concat (map ("."<>) sel), " = ", textSomeVarValue value] throwError Failed expect :: SourceLine -> Process -> Expr Regex -> [TypedVarName Text] -> TestRun () -> TestRun () diff --git a/src/Test.hs b/src/Test.hs index 398fa03..e336858 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -11,6 +11,7 @@ module Test ( ExprListUnpacker(..), ExprEnumerator(..), Expr(..), eval, gatherVars, + AppAnnotation(..), Regex(RegexPart, RegexString), regexMatch, ) where @@ -137,22 +138,25 @@ data ExprEnumerator a = ExprEnumerator (a -> a -> [a]) (a -> a -> a -> [a]) data Expr a where Variable :: ExprType a => VarName -> Expr a Pure :: a -> Expr a - App :: Expr (a -> b) -> Expr a -> Expr b + App :: AppAnnotation b -> Expr (a -> b) -> Expr a -> Expr b Concat :: [Expr Text] -> Expr Text Regex :: [Expr Regex] -> Expr Regex RootNetwork :: Expr Network +data AppAnnotation b = AnnNone + | ExprType b => AnnRecord Text + instance Functor Expr where - fmap f x = Pure f `App` x + fmap f x = Pure f <*> x instance Applicative Expr where pure = Pure - (<*>) = App + (<*>) = App AnnNone eval :: MonadEval m => Expr a -> m a eval (Variable name) = fromSomeVarValue name =<< lookupVar name eval (Pure value) = return value -eval (App f x) = eval f <*> eval x +eval (App _ f x) = eval f <*> eval x eval (Concat xs) = T.concat <$> mapM eval xs eval (Regex xs) = mapM eval xs >>= \case [re@RegexCompiled {}] -> return re @@ -161,17 +165,29 @@ eval (Regex xs) = mapM eval xs >>= \case Right re -> return re eval (RootNetwork) = rootNetwork -gatherVars :: forall a m. MonadEval m => Expr a -> m [(VarName, SomeVarValue)] +gatherVars :: forall a m. MonadEval m => Expr a -> m [((VarName, [Text]), SomeVarValue)] gatherVars = fmap (uniqOn fst . sortOn fst) . helper where - helper :: forall b. Expr b -> m [(VarName, SomeVarValue)] - helper (Variable var) = (:[]) . (var,) <$> lookupVar var + helper :: forall b. Expr b -> m [((VarName, [Text]), SomeVarValue)] + helper (Variable var) = (:[]) . ((var, []),) <$> lookupVar var helper (Pure _) = return [] - helper (App f x) = (++) <$> helper f <*> helper x + helper e@(App (AnnRecord sel) _ x) + | Just (var, sels) <- gatherSelectors x + = do val <- SomeVarValue <$> eval e + return [((var, sels ++ [sel]), val)] + | otherwise = helper x + helper (App _ f x) = (++) <$> helper f <*> helper x helper (Concat es) = concat <$> mapM helper es helper (Regex es) = concat <$> mapM helper es helper (RootNetwork) = return [] + gatherSelectors :: forall b. Expr b -> Maybe (VarName, [Text]) + gatherSelectors = \case + Variable var -> Just (var, []) + App (AnnRecord sel) _ x -> do + (var, sels) <- gatherSelectors x + return (var, sels ++ [sel]) + _ -> Nothing data Regex = RegexCompiled Text RE.Regex | RegexPart Text |