module Tests.FreeVars import Quox.Pretty import Quox.Syntax import Quox.FreeVars import AstExtra import TAP import Derive.Prelude %language ElabReflection private data FailureType = Dim | Term %runElab derive "FailureType" [Show] private record Failure where constructor Fail type : FailureType expected, got : FreeVars n private ToInfo Failure where toInfo f = [("type", show f.type), ("expected", show f.expected), ("got", show f.got)] private testFreeVars1 : {d : Nat} -> HasFreeVars f => (f d -> String) -> f d -> FreeVars' d -> Test testFreeVars1 lbl tm dims = test (lbl tm) $ do let dims = FV dims; dims' = fv tm unless (dims == dims') $ Left $ Fail Dim dims dims' Right () private testFreeVars : {d, n : Nat} -> (HasFreeVars (f d), HasFreeDVars f) => (f d n -> String) -> f d n -> FreeVars' d -> FreeVars' n -> Test testFreeVars lbl tm dims terms = test (lbl tm) $ do let dims = FV dims; terms = FV terms dims' = fdv tm; terms' = fv tm unless (dims == dims') $ Left $ Fail Dim dims dims' unless (terms == terms') $ Left $ Fail Term terms terms' Right () private Doc80 : Type Doc80 = Doc $ Opts 80 private prettyWith : (a -> Eff Pretty Doc80) -> a -> String prettyWith f = trim . render _ . runPretty . f parameters {d : Nat} (ds : BContext d) private withContext1 : Doc80 -> Eff Pretty Doc80 withContext1 doc = if null ds then pure $ hsep ["⊢", doc] else pure $ sep [hsep [!(ctx1 ds), "⊢"], doc] where ctx1 : forall k. BContext k -> Eff Pretty Doc80 ctx1 [<] = pure "·" ctx1 ctx = fillSeparateTight !commaD . toList' <$> traverse' (pure . prettyBind') ctx private testFreeVarsD : Dim d -> FreeVars' d -> Test testFreeVarsD = testFreeVars1 $ prettyWith $ withContext1 <=< prettyDim ds parameters {d, n : Nat} (ds : BContext d) (ts : BContext n) private withContext : Doc80 -> Eff Pretty Doc80 withContext doc = if null ds && null ts then pure $ hsep ["⊢", doc] else pure $ sep [hsep [!(ctx1 ds), "|", !(ctx1 ts), "⊢"], doc] where ctx1 : forall k. BContext k -> Eff Pretty Doc80 ctx1 [<] = pure "·" ctx1 ctx = fillSeparateTight !commaD . toList' <$> traverse' (pure . prettyBind') ctx private testFreeVarsT : Term d n -> FreeVars' d -> FreeVars' n -> Test testFreeVarsT = testFreeVars $ prettyWith $ withContext <=< prettyTerm ds ts private testFreeVarsE : Elim d n -> FreeVars' d -> FreeVars' n -> Test testFreeVarsE = testFreeVars $ prettyWith $ withContext <=< prettyElim ds ts export tests : Test tests = "free variables (fv/fdv)" :- [ testFreeVarsD [<] (^K Zero) [<], testFreeVarsD [<"i", "j"] (^K Zero) [